diff --git a/app/Main.hs b/app/Main.hs index 683a8de..0517ac6 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,4 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} + module Main where +import Brick +import Control.Monad +import qualified Graphics.Vty as Vty + +import Profold.LineNode +import Profold.UiState + +data UiName = UiViewport + deriving (Show, Eq, Ord) + +myAppDraw :: UiState -> [Widget UiName] +myAppDraw s = [viewport UiViewport Vertical $ renderUiState s] + +myHandleEvent :: UiState -> BrickEvent n e -> EventM n (Next UiState) +myHandleEvent s (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt s +myHandleEvent s (VtyEvent (Vty.EvKey Vty.KUp _)) = continue $ moveFocusUp s +myHandleEvent s (VtyEvent (Vty.EvKey Vty.KDown _)) = continue $ moveFocusDown s +myHandleEvent s (VtyEvent (Vty.EvKey (Vty.KChar 'q') _)) = halt s +myHandleEvent s (VtyEvent (Vty.EvKey (Vty.KChar 'k') _)) = continue $ moveFocusUp s +myHandleEvent s (VtyEvent (Vty.EvKey (Vty.KChar 'j') _)) = continue $ moveFocusDown s +myHandleEvent s (VtyEvent (Vty.EvKey (Vty.KChar '\t') _)) = continue $ toggleFold s +myHandleEvent s _ = continue s + +myAttrMap :: AttrMap +myAttrMap = attrMap Vty.defAttr + [ ("focused", Vty.defAttr `Vty.withStyle` Vty.reverseVideo) + ] + +myApp :: App UiState () UiName +myApp = App + { appDraw = \s -> [renderUiState s] + , appChooseCursor = neverShowCursor + , appHandleEvent = myHandleEvent + , appStartEvent = pure + , appAttrMap = const myAttrMap + } + main :: IO () -main = putStrLn "Nothing to see here" +main = void $ defaultMain myApp $ newUiState $ newLineNode "Hello world" + [ newLineNode " Child" [] + , newLineNode " More children" [] + ] diff --git a/package.yaml b/package.yaml index 49e3510..f4bcf91 100644 --- a/package.yaml +++ b/package.yaml @@ -14,10 +14,12 @@ extra-source-files: dependencies: - base >= 4.7 && < 5 +- brick - containers - megaparsec - text - vector +- vty library: source-dirs: src diff --git a/src/Profold/LineNode.hs b/src/Profold/LineNode.hs new file mode 100644 index 0000000..9473eb2 --- /dev/null +++ b/src/Profold/LineNode.hs @@ -0,0 +1,35 @@ +module Profold.LineNode + ( LineNode(..) + , newLineNode + , Path + , flatten + , modify + ) where + +import qualified Data.Text as T +import qualified Data.Vector as V + +import Profold.Util + +data LineNode = LineNode + { lineText :: T.Text + , lineChildren :: V.Vector LineNode + , lineFolded :: Bool + } deriving (Show) + +newLineNode :: T.Text -> [LineNode] -> LineNode +newLineNode text children = LineNode text (V.fromList children) True + +type Path = [Int] + +flatten :: LineNode -> V.Vector (Path, LineNode) +flatten ln + | lineFolded ln = V.singleton ([], ln) + | otherwise = + V.cons ([], ln) $ + V.imap (\i (is, n) -> (i : is, n)) $ V.concatMap flatten $ lineChildren ln + +modify :: (LineNode -> LineNode) -> Path -> LineNode -> LineNode +modify f [] ln = f ln +modify f (i:is) ln = + ln {lineChildren = modifyAtIndex i (modify f is) $ lineChildren ln} diff --git a/src/Profold/LineTree.hs b/src/Profold/LineTree.hs deleted file mode 100644 index 6ae2c81..0000000 --- a/src/Profold/LineTree.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Profold.LineTree - ( LineNode(..) - , Path - , onlyUnfolded - , flatten - , modify - , toggleFold - ) where - -import qualified Data.Text as T -import qualified Data.Vector as V - -import Profold.Util - -data LineNode = LineNode - { lineText :: T.Text - , lineChildren :: V.Vector LineNode - , lineFolded :: Bool - } deriving (Show) - -type Path = [Int] - -onlyUnfolded :: LineNode -> LineNode -onlyUnfolded ln - | lineFolded ln = ln{lineChildren = V.empty} - | otherwise = ln - -flatten :: LineNode -> V.Vector (Path, T.Text) -flatten ln = - V.cons ([], lineText ln) $ - V.imap (\i (is, t) -> (i : is, t)) $ - V.concatMap flatten $ - lineChildren ln - -modify :: (LineNode -> LineNode) -> Path -> LineNode -> LineNode -modify f [] ln = f ln -modify f (i:is) ln = ln{lineChildren = modifyAtIndex i (modify f is) $ lineChildren ln} - -toggleFold :: Path -> LineNode -> LineNode -toggleFold = modify $ \ln -> ln{lineFolded = not $ lineFolded ln} diff --git a/src/Profold/UiState.hs b/src/Profold/UiState.hs new file mode 100644 index 0000000..162d195 --- /dev/null +++ b/src/Profold/UiState.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Profold.UiState + ( UiState + , newUiState + -- * Modifying + , moveFocusUp + , moveFocusDown + , toggleFold + -- * Drawing + , renderUiState + ) where + +import Brick +import Data.Maybe +import qualified Data.Vector as V + +import Profold.LineNode +import Profold.Util + +data UiState = UiState + { uiTree :: LineNode + , uiFocused :: Path + } deriving (Show) + +newUiState :: LineNode -> UiState +newUiState ln = UiState ln [] + +moveFocusUp :: UiState -> UiState +moveFocusUp s = + fromMaybe s $ do + prev <- + fst <$> findSurrounding (\a -> fst a == uiFocused s) $ + flatten $ uiTree s + pure s {uiFocused = fst prev} + +moveFocusDown :: UiState -> UiState +moveFocusDown s = + fromMaybe s $ do + prev <- + snd <$> findSurrounding (\a -> fst a == uiFocused s) $ + flatten $ uiTree s + pure s {uiFocused = fst prev} + +toggleFold :: UiState -> UiState +toggleFold s = + s {uiTree = modify toggleFoldIfHasChildren (uiFocused s) (uiTree s)} + where + toggleFoldIfHasChildren ln + | V.null $ lineChildren ln = ln + | otherwise = ln {lineFolded = not $ lineFolded ln} + +wrapFolded :: Bool -> Widget n -> Widget n +wrapFolded False widget = withDefAttr "unfolded" $ str " " <+> widget +wrapFolded True widget = withDefAttr "folded" $ str "+" <+> widget + +wrapFocused :: Bool -> Widget n -> Widget n +wrapFocused False = withDefAttr "unfocused" +wrapFocused True = visible . withDefAttr "focused" + +renderLine :: Bool -> LineNode -> Widget n +renderLine focused ln = + wrapFocused focused $ + wrapFolded foldedWithChildren $ padRight Max $ txt $ lineText ln + where + foldedWithChildren = lineFolded ln && not (V.null $ lineChildren ln) + +renderUiState :: UiState -> Widget n +renderUiState s = + let flat = V.toList $ flatten $ uiTree s + focused = uiFocused s + rendered = map (\(p, ln) -> renderLine (p == focused) ln) flat + in vBox rendered diff --git a/src/Profold/Util.hs b/src/Profold/Util.hs index 79c2b75..7f7a7f2 100644 --- a/src/Profold/Util.hs +++ b/src/Profold/Util.hs @@ -1,9 +1,16 @@ module Profold.Util ( modifyAtIndex + , findSurrounding ) where +import Data.Maybe import qualified Data.Vector as V modifyAtIndex :: Int -> (a -> a) -> V.Vector a -> V.Vector a -- Yes, this function looks ugly, but it's short enough that I don't care. modifyAtIndex i f v = maybe v (\a -> v V.// [(i, f a)]) (v V.!? i) + +findSurrounding :: (a -> Bool) -> V.Vector a -> (Maybe a, Maybe a) +findSurrounding f v = fromMaybe (Nothing, Nothing) $ do + i <- V.findIndex f v + pure (v V.!? (i - 1), v V.!? (i + 1))