Implement basic UI

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" []
+  ]

package.yaml

@@ -14,10 +14,12 @@ extra-source-files:
 
 dependencies:
 - base >= 4.7 && < 5
+- brick
 - containers
 - megaparsec
 - text
 - vector
+- vty
 
 library:
   source-dirs: src

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}

src/Profold/LineTree.hs

@@ -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}

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

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))