[all] Reorganize haskell code into multiple packages

forest-tui/README.md

@@ -0,0 +1 @@
+# forest-tui

forest-tui/app/Main.hs

@@ -0,0 +1,12 @@
+module Main where
+
+import           Options.Applicative
+
+import           Forest.Client
+import           Forest.Client.Options
+import           Forest.Client.Websocket
+
+main :: IO ()
+main = do
+  opts <- execParser clientOptionsParserInfo
+  runWithEventChan opts runClient

forest-tui/forest-tui.cabal

@@ -0,0 +1,74 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.31.2.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: 9ca3a1fe555e2dceb3459b6ae920b1ed93aac76398d4909a7030d7992b79ce40
+
+name:           forest-tui
+version:        0.1.0.0
+synopsis:       A terminal-based client for forest
+description:    Please see the README at <https://github.com/Garmelon/forest#readme>
+homepage:       https://github.com/Garmelon/forest#readme
+bug-reports:    https://github.com/Garmelon/forest/issues
+author:         Garmelon <joscha@plugh.de>
+maintainer:     Garmelon <joscha@plugh.de>
+copyright:      2020 Garmelon
+license:        MIT
+build-type:     Simple
+extra-source-files:
+    README.md
+
+source-repository head
+  type: git
+  location: https://github.com/Garmelon/forest
+
+library
+  exposed-modules:
+      Forest.Client
+      Forest.Client.NodeUtil
+      Forest.Client.Options
+      Forest.Client.UiState
+      Forest.Client.Websocket
+      Forest.Client.Widgets.NodeEditor
+      Forest.Client.Widgets.WidgetTree
+  other-modules:
+      Paths_forest_tui
+  hs-source-dirs:
+      src
+  build-depends:
+      base >=4.7 && <5
+    , brick
+    , containers
+    , forest-common
+    , optparse-applicative
+    , safe
+    , text
+    , text-zipper
+    , vty
+    , websockets
+    , wuss
+  default-language: Haskell2010
+
+executable forest
+  main-is: Main.hs
+  other-modules:
+      Paths_forest_tui
+  hs-source-dirs:
+      app
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      base >=4.7 && <5
+    , brick
+    , containers
+    , forest-common
+    , forest-tui
+    , optparse-applicative
+    , safe
+    , text
+    , text-zipper
+    , vty
+    , websockets
+    , wuss
+  default-language: Haskell2010

forest-tui/package.yaml

@@ -0,0 +1,39 @@
+name: forest-tui
+version: 0.1.0.0
+license: MIT
+author: Garmelon <joscha@plugh.de>
+copyright: 2020 Garmelon
+
+synopsis: A terminal-based client for forest
+description: Please see the README at <https://github.com/Garmelon/forest#readme>
+github: Garmelon/forest
+
+extra-source-files:
+  - README.md
+
+dependencies:
+  - base >= 4.7 && < 5
+  - brick
+  - containers
+  - forest-common
+  - optparse-applicative
+  - safe
+  - text
+  - text-zipper
+  - vty
+  - websockets
+  - wuss
+
+library:
+  source-dirs: src
+
+executables:
+  forest:
+    source-dirs: app
+    main: Main.hs
+    ghc-options:
+      - -threaded
+      - -rtsopts
+      - -with-rtsopts=-N
+    dependencies:
+      - forest-tui

forest-tui/src/Forest/Client.hs

@@ -0,0 +1,150 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Forest.Client
+  ( ClientState
+  , newClientState
+  , runClient
+  ) where
+
+import           Brick
+import           Brick.BChan
+import           Brick.Widgets.Edit
+import           Control.Monad
+import           Control.Monad.IO.Class
+import qualified Graphics.Vty                     as Vty
+import qualified Network.WebSockets               as WS
+
+import           Forest.Api
+import           Forest.Client.UiState
+import           Forest.Client.Websocket
+import           Forest.Client.Widgets.WidgetTree
+import           Forest.Node
+import           Forest.Util
+
+data ResourceName = RnViewport | RnEditor
+  deriving (Show, Eq, Ord)
+
+data ClientState = ClientState
+  { csUiState :: UiState ResourceName
+  , csConn    :: WS.Connection
+  }
+
+newClientState :: WS.Connection -> Node -> ClientState
+newClientState conn node = ClientState
+  { csUiState = newUiState RnEditor node
+  , csConn    = conn
+  }
+
+{- Handling input events -}
+
+type ClientM a = EventM ResourceName a
+
+onUiState ::
+     ClientState
+  -> (UiState ResourceName -> UiState ResourceName)
+  -> ClientM (Next ClientState)
+onUiState cs f = continue cs {csUiState = f $ csUiState cs}
+
+onUiState' ::
+     ClientState
+  -> (UiState ResourceName -> ClientM (UiState ResourceName))
+  -> ClientM (Next ClientState)
+onUiState' cs f = do
+  s' <- f $ csUiState cs
+  continue cs {csUiState = s'}
+
+{- ... without active editor -}
+
+onKeyWithoutEditor :: ClientState -> Vty.Event -> ClientM (Next ClientState)
+onKeyWithoutEditor cs (Vty.EvKey k _)
+  | k `elem` quitKeys   = halt cs
+  | k `elem` foldKeys   = onUiState cs toggleFoldAtFocus
+  | k `elem` upKeys     = onUiState cs moveFocusUp
+  | k `elem` downKeys   = onUiState cs moveFocusDown
+  | k `elem` editKeys   = onUiState cs editCurrentNode
+  | k `elem` deleteKeys = do
+      when (flagDelete $ nodeFlags $ getFocusedNode $ csUiState cs) $
+        liftIO $ sendPacket (csConn cs) $ ClientDelete (getFocusedPath $ csUiState cs)
+      continue cs
+  | k `elem` replyKeys  = onUiState cs (replyToCurrentNode . unfoldAtFocus)
+  | k `elem` replyKeys' = onUiState cs replyAfterCurrentNode
+  | k `elem` actKeys    = do
+      when (flagAct $ nodeFlags $ getFocusedNode $ csUiState cs) $
+        liftIO $ sendPacket (csConn cs) $ ClientAct (getFocusedPath $ csUiState cs)
+      continue cs
+  where
+    quitKeys   = [Vty.KChar 'q', Vty.KEsc]
+    foldKeys   = [Vty.KChar '\t']
+    upKeys     = [Vty.KChar 'k', Vty.KUp]
+    downKeys   = [Vty.KChar 'j', Vty.KDown]
+    editKeys   = [Vty.KChar 'e']
+    deleteKeys = [Vty.KChar 'd']
+    replyKeys  = [Vty.KChar 'r']
+    replyKeys'  = [Vty.KChar 'R']
+    actKeys    = [Vty.KChar 'a', Vty.KChar ' ', Vty.KEnter]
+onKeyWithoutEditor cs _ = continue cs
+
+{- ... with active editor -}
+
+editResultToPacket :: EditResult -> ClientPacket
+editResultToPacket result
+  | erReply result = ClientReply (erPath result) (erText result)
+  | otherwise      = ClientEdit  (erPath result) (erText result)
+
+onKeyWithEditor :: ClientState -> Vty.Event -> ClientM (Next ClientState)
+-- Finish editing normally
+onKeyWithEditor cs (Vty.EvKey Vty.KEnter _) = do
+  let (s', maybeResult) = finishEditing $ csUiState cs
+  forM_ maybeResult $ liftIO . sendPacket (csConn cs) . editResultToPacket
+  continue cs {csUiState = s'}
+-- Abort editing with Escape
+onKeyWithEditor cs (Vty.EvKey Vty.KEsc _) = onUiState cs abortEditing
+-- Insert a newline on C-n
+onKeyWithEditor cs (Vty.EvKey (Vty.KChar 'n') m)
+  | Vty.MCtrl `elem` m = onUiState' cs $ updateEditor $ Vty.EvKey Vty.KEnter []
+-- Forward all other events as usual
+onKeyWithEditor cs ev = onUiState' cs $ updateEditor ev
+
+{- And the rest of the Brick application -}
+
+clientDraw :: ClientState -> [Widget ResourceName]
+clientDraw cs = [padTopBottom 1 $ padLeftRight 2 vp]
+  where
+    tree = renderUiState boxDrawingBranching $ csUiState cs
+    vp = viewport RnViewport Vertical tree
+
+clientHandleEvent ::
+     ClientState -> BrickEvent ResourceName Event -> ClientM (Next ClientState)
+clientHandleEvent cs (VtyEvent ev)
+  | isEditorActive (csUiState cs) = onKeyWithEditor cs ev
+  | otherwise                     = onKeyWithoutEditor cs ev
+clientHandleEvent cs (AppEvent ev) = case ev of
+  EventNode node        -> onUiState cs $ replaceRootNode node
+  EventConnectionClosed -> halt cs
+clientHandleEvent cs _ = continue cs
+
+clientAttrMap :: AttrMap
+clientAttrMap = attrMap Vty.defAttr
+  [ ("expand", Vty.defAttr `Vty.withStyle` Vty.bold `Vty.withForeColor` Vty.yellow)
+  , ("focus", Vty.defAttr `Vty.withBackColor` Vty.blue)
+  , ("flags", Vty.defAttr `Vty.withForeColor` Vty.brightBlack)
+  , (treeLineAttr, Vty.defAttr `Vty.withForeColor` Vty.brightBlack)
+  , (editAttr, Vty.defAttr `Vty.withBackColor` Vty.brightBlack)
+  ]
+
+clientApp :: App ClientState Event ResourceName
+clientApp = App
+  { appDraw = clientDraw
+  , appChooseCursor = showFirstCursor
+  , appHandleEvent = clientHandleEvent
+  , appStartEvent = pure
+  , appAttrMap = const clientAttrMap
+  }
+
+runClient :: WS.Connection -> BChan Event -> Node -> IO ()
+runClient conn chan node = do
+  putStrLn "Starting UI"
+  let clientState = newClientState conn node
+      vtyBuilder = Vty.mkVty Vty.defaultConfig
+  initialVty <- vtyBuilder
+  void $ customMain initialVty vtyBuilder (Just chan) clientApp clientState

forest-tui/src/Forest/Client/NodeUtil.hs

@@ -0,0 +1,56 @@
+module Forest.Client.NodeUtil
+  ( Unfolded
+  , foldVisibleNodes
+  , applyFolds
+  , flatten
+  , findPrevNode
+  , findNextNode
+  ) where
+
+import           Data.Maybe
+import qualified Data.Set          as Set
+
+import           Forest.Node
+import qualified Forest.OrderedMap as OMap
+import           Forest.Util
+
+type Unfolded = Set.Set Path
+
+foldVisibleNodes' :: Path -> (Path -> Node -> Maybe [a] -> a) -> Unfolded -> Node -> a
+foldVisibleNodes' path f unfolded node
+  | childrenVisible = f path node $ Just mappedChildren
+  | otherwise       = f path node Nothing
+  where
+    childrenVisible = mempty `Set.member` unfolded
+    mappedChildren = map (uncurry goDeeper) $ OMap.toList $ nodeChildren node
+    goDeeper nid = foldVisibleNodes' (path <> Path [nid]) f (narrowSet nid unfolded)
+
+-- | The word "fold" in the name of this function is meant as in 'foldr'. This
+-- function folds a tree of nodes while respecting which nodes should be visible
+-- according to the 'Unfolded' set.
+foldVisibleNodes :: (Path -> Node -> Maybe [a] -> a) -> Unfolded -> Node -> a
+foldVisibleNodes = foldVisibleNodes' mempty
+
+-- | Keep only those nodes that are visible according to the 'Unfolded' set.
+applyFolds :: Unfolded -> Node -> Node
+applyFolds unfolded node
+  | mempty `Set.member` unfolded = node {nodeChildren = children}
+  | otherwise = node {nodeChildren = OMap.empty}
+  where
+    children =
+      OMap.mapWithKey (\nid -> applyFolds $ narrowSet nid unfolded) $
+      nodeChildren node
+
+-- | Return the 'Path's to a node and its subnodes in the order they would be
+-- displayed in.
+flatten :: Node -> [Path]
+flatten node =
+  let flattenedChildren =
+        mapChildren (\nid n -> map (Path [nid] <>) $ flatten n) node
+   in Path [] : concat flattenedChildren
+
+findPrevNode :: Node -> Path -> Path
+findPrevNode node path = fromMaybe path $ findPrev (==path) $ flatten node
+
+findNextNode :: Node -> Path -> Path
+findNextNode node path = fromMaybe path $ findNext (==path) $ flatten node

forest-tui/src/Forest/Client/Options.hs

@@ -0,0 +1,67 @@
+module Forest.Client.Options
+  ( ClientOptions(..)
+  , clientOptionsParserInfo
+  ) where
+
+import           Data.List
+import           Options.Applicative
+import           Options.Applicative.Help.Pretty
+
+data ClientOptions = ClientOptions
+  { clientHostName :: String
+  , clientPort     :: Int
+  , clientPath     :: String
+  , clientSsl      :: Bool
+  }
+
+parser :: Parser ClientOptions
+parser = ClientOptions
+  <$> strArgument
+      (  help "The name of the host to connect to"
+      <> metavar "HOST"
+      )
+  <*> option auto
+      (  short 'p'
+      <> long "port"
+      <> help "The port to connect to"
+      <> value 11133 -- Chosen by fair dice roll
+      <> showDefault
+      <> metavar "PORT"
+      )
+  <*> strOption
+      (  short 'P'
+      <> long "path"
+      <> help "The path to connect to on the given domain"
+      <> value ""
+      <> showDefault
+      <> metavar "PATH"
+      )
+  <*> flag True False -- Ssl enabled by default
+      (  short 'n'
+      <> long "no-ssl"
+      <> help "This flag disables ssl on outgoing websocket connections"
+      )
+
+keyBindings :: String
+keyBindings = intercalate "\n"
+  [ "Key bindings:"
+  , "  exit                     q, esc"
+  , "  move cursor              up/down, j/k"
+  , "  toggle fold              tab"
+  , "  edit node                e"
+  , "  delete node              d"
+  , "  new child (reply)        r"
+  , "  new sibling              R"
+  , "  perform action           a, enter, space"
+  , ""
+  , "Editor key bindings:"
+  , "  confirm edit             enter"
+  , "  abort edit               esc"
+  , "  insert newline           ctrl+n"
+  ]
+
+clientOptionsParserInfo :: ParserInfo ClientOptions
+clientOptionsParserInfo = info (helper <*> parser)
+  (  fullDesc
+  <> footerDoc (Just $ string keyBindings)
+  )

forest-tui/src/Forest/Client/UiState.hs

@@ -0,0 +1,296 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Forest.Client.UiState
+  ( UiState
+  , newUiState
+  , getFocusedPath
+  , getFocusedNode
+  -- * Modifying the UI state
+  , replaceRootNode
+  , moveFocusUp
+  , moveFocusDown
+  , moveFocusToFirstChild
+  , moveFocusToLastChild
+  , moveFocusToFirstSibling
+  , moveFocusToLastSibling
+  , foldAtFocus
+  , unfoldAtFocus
+  , toggleFoldAtFocus
+  -- ** The node editor
+  -- *** Creating
+  , editCurrentNode
+  , replyToCurrentNode
+  , replyAfterCurrentNode
+  -- *** Updating
+  , isEditorActive
+  , updateEditor
+  -- *** Finishing the edit
+  , EditResult(..)
+  , finishEditing
+  , abortEditing
+  -- * Rendering the UI state
+  , renderUiState
+  ) where
+
+import           Brick
+import           Data.List
+import           Data.Maybe
+import qualified Data.Set                         as Set
+import qualified Data.Text                        as T
+import qualified Graphics.Vty                     as Vty
+import           Safe
+
+import           Forest.Client.NodeUtil
+import           Forest.Client.Widgets.NodeEditor
+import           Forest.Client.Widgets.WidgetTree
+import           Forest.Node
+import qualified Forest.OrderedMap                as OMap
+
+data EditorInfo n = EditorInfo
+  { eiEditor :: !(NodeEditor n)
+  , eiPath   :: !Path
+  , eiReply  :: !Bool
+  } deriving (Show)
+
+data UiState n = UiState
+  { uiRootNode   :: !Node
+  , uiFocused    :: !Path
+  , uiUnfolded   :: !Unfolded
+  , uiEditor     :: !(Maybe (EditorInfo n))
+  , uiEditorName :: !n
+  } deriving (Show)
+
+newUiState :: n -> Node -> UiState n
+newUiState editorName node = UiState
+  { uiRootNode   = node
+  , uiFocused    = mempty
+  , uiUnfolded   = mempty
+  , uiEditor     = Nothing
+  , uiEditorName = editorName
+  }
+
+getFocusedPath :: UiState n -> Path
+getFocusedPath = uiFocused
+
+getFocusedNode :: UiState n -> Node
+getFocusedNode s = fromMaybe rootNode $ applyPath (uiFocused s) rootNode
+  where
+    rootNode = uiRootNode s
+
+{- Modifying -}
+
+-- | Only keep those unfolded nodes that actually exist.
+validateUnfolded :: UiState n -> UiState n
+validateUnfolded s =
+  s {uiUnfolded = Set.filter (referencedNodeExists $ uiRootNode s) (uiUnfolded s)}
+
+-- | Try to find the closest parent to a 'Path' that exists in the 'Node'.
+findValidParent :: Node -> Path -> Path
+findValidParent _ (Path []) = Path []
+findValidParent node (Path (x:xs)) = case applyId x node of
+  Nothing    -> Path []
+  Just child -> Path [x] <> findValidParent child (Path xs)
+
+-- | Modify the focused path so it always points to an existing node.
+validateFocused :: UiState n -> UiState n
+validateFocused s =
+  let foldedRootNode = applyFolds (uiUnfolded s) (uiRootNode s)
+  in  s {uiFocused = findValidParent foldedRootNode $ uiFocused s}
+
+-- | Close the editor if it doesn't point to a valid path.
+validateEditor :: UiState n -> UiState n
+validateEditor s = case uiEditor s of
+  Nothing -> s
+  Just e -> keepEditor $ fromMaybe False $ do
+    node <- applyPath (eiPath e) (uiRootNode s)
+    let flags = nodeFlags node
+    pure $ if eiReply e then flagReply flags else flagEdit flags
+  where
+    keepEditor True  = s
+    keepEditor False = s {uiEditor = Nothing}
+
+-- | Modify the UI state so it is consistent again.
+validate :: UiState n -> UiState n
+validate = validateEditor . validateFocused . validateUnfolded
+
+replaceRootNode :: Node -> UiState n -> UiState n
+replaceRootNode node s = validate s { uiRootNode = node
+  , uiFocused = findNextValidNode (uiRootNode s) node (uiFocused s)
+  }
+
+-- | Find a node that is close to the previously focused node, taking into
+-- account its previous position in the tree.
+findNextValidNode :: Node -> Node -> Path -> Path
+findNextValidNode _ _ (Path []) = Path []
+findNextValidNode from to (Path (x:xs)) = fromMaybe (Path []) $ do
+  fromNode <- applyId x from
+  case applyId x to of
+    Just toNode -> pure $ Path [x] <> findNextValidNode fromNode toNode (Path xs)
+    Nothing -> do
+      fromIdx <- elemIndex x $ OMap.keys $ nodeChildren from
+      let toKeys = OMap.keys $ nodeChildren to
+      x' <- getValueClosestToIndex fromIdx toKeys
+      pure $ Path [x']
+  where
+    -- Slightly unsafe code, but it should be fine
+    getValueClosestToIndex idx list
+      | length list > idx = Just $ list !! idx
+      | null list         = Nothing
+      | otherwise         = Just $ last list
+
+moveFocus :: (Node -> Path -> Path) -> UiState n -> UiState n
+moveFocus f s =
+  let foldedRootNode = applyFolds (uiUnfolded s) (uiRootNode s)
+  in  validateFocused s {uiFocused = f foldedRootNode $ uiFocused s}
+
+moveFocusUp :: UiState n -> UiState n
+moveFocusUp = moveFocus findPrevNode
+
+moveFocusDown :: UiState n -> UiState n
+moveFocusDown = moveFocus findNextNode
+
+moveFocusToParent :: UiState n -> UiState n
+moveFocusToParent = moveFocus $ \_ focused -> fromMaybe focused $ parent focused
+
+moveFocusToChild :: ([NodeId] -> Maybe NodeId) -> UiState n -> UiState n
+moveFocusToChild f = moveFocus $ \node focused -> fromMaybe focused $ do
+  siblings <- nodeChildren <$> applyPath focused node
+  firstSiblingName <- f $ OMap.keys siblings
+  pure $ focused <> Path [firstSiblingName]
+
+moveFocusToFirstChild :: UiState n -> UiState n
+moveFocusToFirstChild = moveFocusToChild headMay
+
+moveFocusToLastChild :: UiState n -> UiState n
+moveFocusToLastChild = moveFocusToChild lastMay
+
+moveFocusToSibling :: ([NodeId] -> Maybe NodeId) -> UiState n -> UiState n
+moveFocusToSibling f s
+  | uiFocused s == mempty = s
+  | otherwise = moveFocusToChild f $ moveFocusToParent s
+
+moveFocusToFirstSibling :: UiState n -> UiState n
+moveFocusToFirstSibling = moveFocusToSibling headMay
+
+moveFocusToLastSibling :: UiState n -> UiState n
+moveFocusToLastSibling = moveFocusToSibling lastMay
+
+foldAtFocus :: UiState n -> UiState n
+foldAtFocus s = validateUnfolded $ s {uiUnfolded = Set.delete (uiFocused s) (uiUnfolded s)}
+
+unfoldAtFocus :: UiState n -> UiState n
+unfoldAtFocus s = validateUnfolded $ s {uiUnfolded = Set.insert (uiFocused s) (uiUnfolded s)}
+
+toggleFoldAtFocus :: UiState n -> UiState n
+toggleFoldAtFocus s = if uiFocused s `Set.member` uiUnfolded s
+  then foldAtFocus s
+  else unfoldAtFocus s
+
+editNode :: Bool -> Path -> UiState n -> UiState n
+editNode reply path s =
+  let text = if reply then "" else nodeText $ getFocusedNode s
+      editorInfo = EditorInfo
+        { eiEditor = beginEdit (uiEditorName s) text
+        , eiPath   = path
+        , eiReply  = reply
+        }
+  in  validateEditor $ s {uiEditor = Just editorInfo}
+
+-- | Begin editing the currently focused node. Discards any current editor
+-- status.
+editCurrentNode :: UiState n -> UiState n
+editCurrentNode s = editNode False (uiFocused s) s
+
+-- | Reply to the currently focused node. Discards any current editor status.
+replyToCurrentNode :: UiState n -> UiState n
+replyToCurrentNode s = editNode True (uiFocused s) $ moveFocusToLastChild s
+
+-- | Reply in parallel to the currently focused node, unless it is the root node
+-- (in which case no action is taken).
+replyAfterCurrentNode :: UiState n -> UiState n
+replyAfterCurrentNode s = case parent $ uiFocused s of
+  Nothing   -> s
+  Just path -> editNode True path $ moveFocusToLastSibling s
+
+isEditorActive :: UiState n -> Bool
+isEditorActive = isJust . uiEditor
+
+-- | Return an action to update the editor if the editor is currently active.
+-- Returns 'Nothing' otherwise.
+updateEditor :: Vty.Event -> UiState n -> EventM n (UiState n)
+updateEditor ev s = case uiEditor s of
+  Nothing -> pure s
+  Just e -> do
+    newEditor <- handleNodeEditorEvent ev $ eiEditor e
+    pure s {uiEditor = Just e {eiEditor = newEditor}}
+
+data EditResult = EditResult
+  { erText  :: T.Text
+  , erPath  :: Path
+  , erReply :: Bool
+  } deriving (Show)
+
+finishEditing :: UiState n -> (UiState n, Maybe EditResult)
+finishEditing s = case uiEditor s of
+  Nothing -> (s, Nothing)
+  Just e ->
+    let editResult = EditResult
+          { erText = getCurrentText $ eiEditor e
+          , erPath = eiPath e
+          , erReply = eiReply e
+          }
+    in  (abortEditing s, Just editResult)
+
+abortEditing :: UiState n -> UiState n
+abortEditing s = s {uiEditor = Nothing}
+
+{- Rendering -}
+
+decorateExpand :: Bool -> Widget n -> Widget n
+decorateExpand True widget  = withDefAttr "expand" widget
+decorateExpand False widget = withDefAttr "noexpand" widget
+
+decorateFocus :: Bool -> Widget n -> Widget n
+decorateFocus True widget  = visible $ withDefAttr "focus" widget
+decorateFocus False widget = withDefAttr "nofocus" widget
+
+decorateFlags :: NodeFlags -> Widget n -> Widget n
+decorateFlags node widget =
+  let e = if flagEdit node then "e" else "-"
+      d = if flagDelete node then "d" else "-"
+      r = if flagReply node then "r" else "-"
+      a = if flagAct node then "a" else "-"
+      flags = "(" <> e <> d <> r <> a <> ")"
+  in  widget <+> txt " " <+> withDefAttr "flags" (txt flags)
+
+renderNode :: Bool -> Node -> Widget n
+renderNode focused node =
+  decorateFlags (nodeFlags node) $
+  decorateFocus focused $
+  decorateExpand (not $ OMap.null $ nodeChildren node) $
+  padRight Max $ txtWrap text
+  where
+    text
+      | T.null $ nodeText node = " "
+      | otherwise              = nodeText node
+
+nodeToTree :: (Ord n, Show n) => UiState n -> Path -> Node -> Maybe [WidgetTree n] -> WidgetTree n
+nodeToTree s path node maybeChildren = case uiEditor s of
+  Nothing ->
+    let isFocused = path == uiFocused s
+    in  WidgetTree (renderNode isFocused node) children
+  Just e ->
+    let renderedEditor = renderNodeEditor $ eiEditor e
+        renderedEditorTree = WidgetTree renderedEditor []
+    in  if path /= eiPath e
+        then WidgetTree (renderNode False node) children
+        else if eiReply e
+             then WidgetTree (renderNode False node) $ children ++ [renderedEditorTree]
+             else WidgetTree renderedEditor children
+  where
+    children = fromMaybe [] maybeChildren
+
+renderUiState :: (Ord n, Show n) => IndentOptions -> UiState n -> Widget n
+renderUiState opts s =
+  renderWidgetTree opts $
+  foldVisibleNodes (nodeToTree s) (uiUnfolded s) (uiRootNode s)

forest-tui/src/Forest/Client/Websocket.hs

@@ -0,0 +1,73 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Forest.Client.Websocket
+  ( Event(..)
+  , runWithEventChan
+  ) where
+
+import           Brick.BChan
+import           Control.Exception
+import qualified Network.WebSockets    as WS
+import qualified Wuss                  as WSS
+
+import           Forest.Api
+import           Forest.Client.Options
+import           Forest.Node
+import           Forest.Util
+
+data Event
+  = EventNode Node
+  | EventConnectionClosed
+
+performInitialContact :: WS.Connection -> IO Node
+performInitialContact conn = do
+  -- First, the client must send a hello packet containing the protocol
+  -- extensions it requests.
+  sendPacket conn $ ClientHello []
+  -- Then, the server must reply with a hello packet containing the extensions
+  -- that will be active for this connection, and an initial node.
+  serverReply <- receivePacket conn
+  case serverReply of
+    (ServerHello [] node) -> pure node
+    -- Since the client never requests any protocol extensions, the server must
+    -- also reply with an empty list of extensions.
+    (ServerHello _ _) -> closeWithErrorMessage conn "Invalid protocol extensions"
+    _ -> closeWithErrorMessage conn "Invalid packet: Expected hello"
+
+receiveUpdates :: BChan Event -> Node -> WS.Connection -> IO ()
+receiveUpdates eventChan node conn = do
+  packet <- receivePacket conn
+  case packet of
+    ServerUpdate path subnode -> do
+      let node' = replaceAt subnode path node
+      writeBChan eventChan $ EventNode node'
+      receiveUpdates eventChan node' conn -- Aaand close the loop :D
+    _ -> closeWithErrorMessage conn "Invalid packet: Expected update"
+
+runCorrectClient :: ClientOptions -> WS.ClientApp a -> IO a
+runCorrectClient opts app
+  | ssl = WSS.runSecureClient name (fromInteger $ toInteger port) path app
+  | otherwise = WS.runClient name port path app
+  where
+    -- I found this nicer to read than (ab-)using record syntax in the arguments
+    name = clientHostName opts
+    port = clientPort opts
+    path = clientPath opts
+    ssl = clientSsl opts
+
+sendCloseEvent :: BChan Event -> SomeException -> IO ()
+sendCloseEvent eventChan e = do
+  putStrLn $ "Encountered exception: " ++ show e
+  writeBChan eventChan EventConnectionClosed
+
+runWithEventChan :: ClientOptions -> (WS.Connection -> BChan Event -> Node -> IO ()) -> IO ()
+runWithEventChan opts f = do
+  putStrLn "Connecting to server"
+  runCorrectClient opts $ \conn -> do
+    putStrLn "Performing initialization ritual"
+    node <- performInitialContact conn
+    chan <- newBChan 100
+    putStrLn "Starting WS thread"
+    let wsThread = handle (sendCloseEvent chan) $ receiveUpdates chan node conn
+    withThread wsThread $ f conn chan node
+  putStrLn "Connection closed and UI stopped"

forest-tui/src/Forest/Client/Widgets/NodeEditor.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Forest.Client.Widgets.NodeEditor
+  ( NodeEditor
+  , getCurrentText
+  , beginEdit
+  , handleNodeEditorEvent
+  , renderNodeEditor
+  ) where
+
+import           Brick
+import           Brick.Widgets.Edit
+import qualified Data.Text          as T
+import           Data.Text.Zipper
+import qualified Graphics.Vty       as Vty
+
+newtype NodeEditor n = NodeEditor (Editor T.Text n)
+  deriving (Show)
+
+getCurrentLines :: NodeEditor n -> [T.Text]
+getCurrentLines (NodeEditor e) = getEditContents e
+
+getCurrentText :: NodeEditor n -> T.Text
+getCurrentText = T.intercalate "\n" . getCurrentLines
+
+beginEdit :: n -> T.Text -> NodeEditor n
+beginEdit name = NodeEditor . applyEdit gotoEOL . editorText name Nothing
+
+edit :: (TextZipper T.Text -> TextZipper T.Text) -> NodeEditor n -> EventM n (NodeEditor n)
+edit z (NodeEditor e) = pure $ NodeEditor $ applyEdit z e
+
+handleNodeEditorEvent :: Vty.Event -> NodeEditor n -> EventM n (NodeEditor n)
+handleNodeEditorEvent (Vty.EvKey Vty.KHome _) ne = edit gotoBOL ne
+handleNodeEditorEvent (Vty.EvKey Vty.KEnd _) ne = edit gotoEOL ne
+handleNodeEditorEvent event (NodeEditor e) = NodeEditor <$> handleEditorEvent event e
+
+renderLines :: [T.Text] -> Widget n
+renderLines = vBox . map (\t -> txt $ if T.null t then " " else t)
+
+renderNodeEditor :: (Ord n, Show n) => NodeEditor n -> Widget n
+renderNodeEditor ne@(NodeEditor e) =
+  makeVisible $ vLimit height $ renderEditor renderLines True e
+  where
+    height = length $ getCurrentLines ne
+    (row, col) = cursorPosition $ editContents e
+    makeVisible = visibleRegion (Location (col, row)) (1, 1)

forest-tui/src/Forest/Client/Widgets/WidgetTree.hs

@@ -0,0 +1,115 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Forest.Client.Widgets.WidgetTree
+  ( WidgetTree(..)
+  , renderWidgetTreeWith
+  , renderWidgetTree
+  , treeLineAttr
+  , IndentOptions(..)
+  , boxDrawingBranching
+  , boxDrawingLine
+  , asciiBranching
+  , asciiLine
+  ) where
+
+import           Brick
+import qualified Data.Text                  as T
+import qualified Graphics.Vty               as Vty
+
+data WidgetTree n = WidgetTree (Widget n) [WidgetTree n]
+
+indentWith :: AttrName -> T.Text -> T.Text -> Widget n -> Widget n
+-- The "left" variables are for rendering the indentation text, the "right"
+-- variables are for the rendered wrapped widget.
+indentWith indentAttrName firstLine otherLines wrapped =
+  Widget (hSize wrapped) (vSize wrapped) $ do
+    let leftWidth = max (T.length firstLine) (T.length otherLines)
+    context <- getContext
+    rightResult <- render $ hLimit (availWidth context - leftWidth) wrapped
+    let rightImage = image rightResult
+        -- Construct the Vty image containing the indentation text
+        height = Vty.imageHeight rightImage
+        leftLines = firstLine : replicate (height - 1) otherLines
+        leftAttribute = attrMapLookup indentAttrName $ ctxAttrMap context
+        leftImage = Vty.vertCat $ map (Vty.text' leftAttribute) leftLines
+        -- Add the indentation text to the left of the result image
+        combinedImage = leftImage Vty.<|> image rightResult
+        offset = Location (leftWidth, 0)
+        result = (addResultOffset offset rightResult) {image=combinedImage}
+    pure result
+
+indent :: AttrName -> IndentOptions -> [Widget n] -> Widget n
+indent indentAttrName opts widgets = vBox $ reverse $ case reverse widgets of
+  [] -> []
+  (w:ws) ->
+    indentWith indentAttrName (indentLastNodeFirstLine opts) (indentLastNodeRest opts) w :
+    map (indentWith indentAttrName (indentNodeFirstLine opts) (indentNodeRest opts)) ws
+
+renderWidgetTreeWith :: AttrName -> IndentOptions -> WidgetTree n -> Widget n
+renderWidgetTreeWith indentAttrName opts (WidgetTree node children) =
+  node <=> indent indentAttrName opts (map (renderWidgetTreeWith indentAttrName opts) children)
+
+renderWidgetTree :: IndentOptions -> WidgetTree n -> Widget n
+renderWidgetTree = renderWidgetTreeWith treeLineAttr
+
+-- | The attribute that 'renderWidgetTree' uses.
+treeLineAttr :: AttrName
+treeLineAttr = "treeLine"
+
+-- | These options control how a tree is rendered.
+--
+-- In the following example, the indent options are set to @'IndentOptions' "a" "b" "c" "d"@:
+--
+-- > a This is the first node.
+-- > b c It has a child.
+-- > a This is a...
+-- > b multiline...
+-- > b node.
+-- > c This is the last node.
+-- > d c It has one child.
+-- > d c And another one.
+--
+-- Warning: The options /must/ be single line strings and /must not/ contain
+-- newlines of any sort.
+data IndentOptions = IndentOptions
+  { indentNodeFirstLine     :: T.Text
+  -- ^ This is prepended to the first line of a node.
+  , indentNodeRest          :: T.Text
+  -- ^ This is prepended to all other lines of a node, including its subnodes.
+  , indentLastNodeFirstLine :: T.Text
+  -- ^ This is prepended to the first line of the last node.
+  , indentLastNodeRest      :: T.Text
+  -- ^ This is prepended to all other lines of the last node, including its subnodes.
+  } deriving (Show, Eq)
+
+boxDrawingBranching :: IndentOptions
+boxDrawingBranching = IndentOptions
+  { indentNodeFirstLine     = "├╴"
+  , indentNodeRest          = "│ "
+  , indentLastNodeFirstLine = "└╴"
+  , indentLastNodeRest      = "  "
+  }
+
+boxDrawingLine :: IndentOptions
+boxDrawingLine = IndentOptions
+  { indentNodeFirstLine     = "│ "
+  , indentNodeRest          = "│ "
+  , indentLastNodeFirstLine = "│ "
+  , indentLastNodeRest      = "│ "
+  }
+
+asciiBranching :: IndentOptions
+asciiBranching = IndentOptions
+  { indentNodeFirstLine     = "+-"
+  , indentNodeRest          = "| "
+  , indentLastNodeFirstLine = "+-"
+  , indentLastNodeRest      = "  "
+  }
+
+asciiLine :: IndentOptions
+asciiLine = IndentOptions
+  { indentNodeFirstLine     = "| "
+  , indentNodeRest          = "| "
+  , indentLastNodeFirstLine = "| "
+  , indentLastNodeRest      = "| "
+  }