[client] Rewrite client structure

client/Main.hs

@@ -1,230 +1,12 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 module Main where
 
-import           Brick
-import           Control.Monad.IO.Class
-import           Brick.BChan
-import           Control.Exception
-import           Control.Monad
-import qualified Data.Set                   as Set
-import qualified Data.Text                  as T
-import qualified Graphics.Vty               as Vty
-import qualified Network.WebSockets         as WS
 import           Options.Applicative
-import qualified Wuss                       as WSS
 
-import           Forest.Api
+import           Forest.Client
-import           Forest.Client.NodeEditor
 import           Forest.Client.Options
-import           Forest.Client.ResourceName
+import           Forest.Client.Websocket
-import           Forest.Client.Tree
-import           Forest.Client.WidgetTree
-import           Forest.Node
-import           Forest.Util
-
-{- First, the UI types -}
-
-data Event = EventNode Node
-  | EventConnectionClosed
-
-data ClientState = ClientState
-  { csTree      :: Tree
-  , csEditor    :: Maybe NodeEditor
-  , csConn      :: WS.Connection
-  , csEventChan :: BChan Event
-  }
-
-newClientState :: BChan Event -> Node -> WS.Connection -> ClientState
-newClientState eventChan node conn = ClientState
-  { csTree      = newTree node mempty Set.empty
-  , csEditor    = Nothing
-  , csConn      = conn
-  , csEventChan = eventChan
-  }
-
-type ClientM a = EventM ResourceName a
-
-{- Actions in normal mode -}
-
-foldAction :: ClientState -> ClientM (Next ClientState)
-foldAction cs = continue cs{csTree = toggleFold $ csTree cs}
-
-upAction :: ClientState -> ClientM (Next ClientState)
-upAction cs = continue cs{csTree = moveUp $ csTree cs}
-
-downAction :: ClientState -> ClientM (Next ClientState)
-downAction cs = continue cs{csTree = moveDown $ csTree cs}
-
-withCurrent
-  :: (ClientState -> Node -> Path -> ClientM (Next ClientState))
-  -> ClientState
-  -> ClientM (Next ClientState)
-withCurrent f cs = f cs (getCurrent tree) (getCurrentPath tree)
-  where
-    tree = csTree cs
-
-editAction :: ClientState -> ClientM (Next ClientState)
-editAction = withCurrent $ \cs node _ -> do
-  let editor = editNode $ nodeText node
-  continue $ if flagEdit (nodeFlags node) then cs{csEditor = Just editor} else cs
-
-deleteAction :: ClientState -> ClientM (Next ClientState)
-deleteAction = withCurrent $ \cs node path -> do
-  when (flagDelete $ nodeFlags node) $
-    liftIO $ sendPacket (csConn cs) $ ClientDelete path
-  continue cs
-
-replyAction :: ClientState -> ClientM (Next ClientState)
-replyAction = withCurrent $ \cs node _ ->
-  continue $ if flagReply (nodeFlags node) then cs{csEditor = Just replyToNode} else cs
-
-actAction :: ClientState -> ClientM (Next ClientState)
-actAction = withCurrent $ \cs node path -> do
-  when (flagAct $ nodeFlags node) $
-    liftIO $ sendPacket (csConn cs) $ ClientAct path
-  continue cs
-
-onKeyWithoutEditor :: ClientState -> Vty.Event -> EventM ResourceName (Next ClientState)
-onKeyWithoutEditor cs (Vty.EvKey k _)
-  | k `elem` quitKeys   = halt cs
-  | k `elem` foldKeys   = foldAction cs
-  | k `elem` upKeys     = upAction cs
-  | k `elem` downKeys   = downAction cs
-  | k `elem` editKeys   = editAction cs
-  | k `elem` deleteKeys = deleteAction cs
-  | k `elem` replyKeys  = replyAction cs
-  | k `elem` actKeys    = actAction 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']
-    actKeys    = [Vty.KChar 'a', Vty.KChar ' ', Vty.KEnter]
-onKeyWithoutEditor cs _ = continue cs
-
-{- Actions in edit mode -}
-
-updateEditor :: NodeEditor -> ClientState -> Vty.Event -> ClientM (Next ClientState)
-updateEditor ed cs ev = do
-  newEd <- handleNodeEditorEvent ev ed
-  continue cs{csEditor = Just newEd}
-
-finishEditing :: NodeEditor -> ClientState -> ClientM (Next ClientState)
-finishEditing ed = withCurrent $ \cs _ path -> do
-  let text = T.intercalate "\n" $ getCurrentText ed
-  liftIO $ sendPacket (csConn cs) $
-    if asReply ed then ClientReply path text else ClientEdit path text
-  continue cs{csEditor = Nothing}
-
-onKeyWithEditor :: NodeEditor -> ClientState -> Vty.Event -> ClientM (Next ClientState)
--- Finish editing normally
-onKeyWithEditor ed cs (Vty.EvKey Vty.KEnter _) = finishEditing ed cs
--- Abort editing with Escape
-onKeyWithEditor _ cs (Vty.EvKey Vty.KEsc _) = continue cs{csEditor = Nothing}
--- Insert a newline on C-n
-onKeyWithEditor ed cs (Vty.EvKey (Vty.KChar 'n') m)
-  | Vty.MCtrl `elem` m = updateEditor ed cs $ Vty.EvKey Vty.KEnter []
--- Forward all other events as usual
-onKeyWithEditor ed cs ev = updateEditor ed cs ev
-
-{- And the rest of the Brick application -}
-
-clientDraw :: ClientState -> [Widget ResourceName]
-clientDraw cs = [padTopBottom 1 $ padLeftRight 2 vp]
-  where
-    tree = renderTree boxDrawingBranching (csEditor cs) (csTree cs)
-    vp = viewport RnViewport Vertical tree
-
-clientHandleEvent
-  :: ClientState
-  -> BrickEvent ResourceName Event
-  -> ClientM (Next ClientState)
-clientHandleEvent cs (VtyEvent ev) = case csEditor cs of
-  Nothing -> onKeyWithoutEditor cs ev
-  Just ed -> onKeyWithEditor ed cs ev
-clientHandleEvent cs (AppEvent ev) = case ev of
-  EventNode node -> continue cs{csTree = replaceNode node $ csTree cs}
-  EventConnectionClosed -> halt cs
-clientHandleEvent cs _ = continue cs
-
-clientAttrMap :: AttrMap
-clientAttrMap = attrMap Vty.defAttr
-  [ ("expand", Vty.currentAttr `Vty.withStyle` Vty.bold `Vty.withForeColor` Vty.yellow)
-  , ("focus", Vty.currentAttr `Vty.withBackColor` Vty.blue)
-  , ("flags", Vty.currentAttr `Vty.withForeColor` Vty.brightBlack)
-  ]
-
-clientApp :: App ClientState Event ResourceName
-clientApp = App
-  { appDraw = clientDraw
-  , appChooseCursor = showFirstCursor
-  , appHandleEvent = clientHandleEvent
-  , appStartEvent = pure
-  , appAttrMap = const clientAttrMap
-  }
-
-{- And now for the websocket connection handling -}
-
-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
-
-{- Gluing everything together -}
-
-sendCloseEvent :: BChan Event -> SomeException -> IO ()
-sendCloseEvent eventChan e = do
-  putStrLn $ "Encountered exception: " ++ show e
-  writeBChan eventChan EventConnectionClosed
 
 main :: IO ()
 main = do
   opts <- execParser clientOptionsParserInfo
-  putStrLn "Connecting to server"
+  runWithEventChan opts runClient
-  runCorrectClient opts $ \conn -> do
-    putStrLn "Performing initialization ritual"
-    node <- performInitialContact conn
-    chan <- newBChan 100
-    let appState = newClientState chan node conn
-    putStrLn "Starting WS thread"
-    withThread (handle (sendCloseEvent chan) $ receiveUpdates chan node conn) $ do
-      putStrLn "Starting UI"
-      let vtyBuilder = Vty.mkVty Vty.defaultConfig
-      initialVty <- vtyBuilder
-      void $ customMain initialVty vtyBuilder (Just chan) clientApp appState
-  putStrLn "Connection closed"

src/Forest/Client.hs

@@ -0,0 +1,145 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Forest.Client
+  ( ClientState
+  , newClientState
+  , runClient
+  ) where
+
+import           Brick
+import           Brick.BChan
+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.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 foldAtFocus
+  | k `elem` upKeys     = onUiState cs moveFocusUp
+  | k `elem` downKeys   = onUiState cs moveFocusDown
+  | k `elem` editKeys   = onUiState cs editCurrentNode
+  | k `elem` deleteKeys = do
+      liftIO $ sendPacket (csConn cs) $ ClientDelete (getFocusedPath $ csUiState cs)
+      continue cs
+  | k `elem` replyKeys  = onUiState cs replyToCurrentNode
+  | k `elem` replyKeys' = onUiState cs replyAfterCurrentNode
+  | k `elem` actKeys    = do
+      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.currentAttr `Vty.withStyle` Vty.bold `Vty.withForeColor` Vty.yellow)
+  , ("focus", Vty.currentAttr `Vty.withBackColor` Vty.blue)
+  , ("flags", Vty.currentAttr `Vty.withForeColor` 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

src/Forest/Client/Node.hs

@@ -1,78 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Forest.Client.Node
-  ( DrawState(..)
-  , nodeToTree
-  ) where
-
-import           Brick
-import qualified Data.Set                   as Set
-
-import           Forest.Client.NodeEditor
-import           Forest.Client.ResourceName
-import           Forest.Client.WidgetTree
-import           Forest.Node
-import qualified Forest.OrderedMap          as OMap
-
-data DrawState = DrawState
-  { dsEditor   :: Maybe NodeEditor
-  , dsFocused  :: Maybe Path
-  , dsUnfolded :: Set.Set Path
-  }
-
-isFocused :: DrawState -> Bool
-isFocused ds = dsFocused ds == Just mempty
-
-isFolded :: DrawState -> Bool
-isFolded ds = not $ mempty `Set.member` dsUnfolded ds
-
-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)
-
-narrowDrawState :: NodeId -> DrawState -> DrawState
-narrowDrawState nodeId ds = ds
-  { dsUnfolded = narrowSet nodeId $ dsUnfolded ds
-  , dsFocused = narrow nodeId =<< dsFocused ds
-  }
-
-nodeToWidget :: Node -> Widget ResourceName
-nodeToWidget  node = txtWrap $ nodeText node
-
-subnodeToTree :: DrawState -> NodeId -> Node -> WidgetTree ResourceName
-subnodeToTree ds nodeId node =
-  let newDs = narrowDrawState nodeId ds
-  in  nodeToTree newDs node
-
-subnodesToTrees :: DrawState -> Node -> [WidgetTree ResourceName]
-subnodesToTrees ds = map (uncurry $ subnodeToTree ds) . OMap.toList . nodeChildren
-
-nodeToTree :: DrawState -> Node -> WidgetTree ResourceName
-nodeToTree ds node = case dsEditor ds of
-  Nothing -> WidgetTree nodeWidget subnodeWidgets
-  Just ed
-    | not focused -> WidgetTree nodeWidget subnodeWidgets
-    | asReply ed -> WidgetTree nodeWidget (subnodeWidgets ++ [WidgetTree (renderNodeEditor ed) []])
-    | otherwise  -> WidgetTree (expand $ renderNodeEditor ed) subnodeWidgets
-  where
-    focused = isFocused ds
-    folded = isFolded ds
-    expand = decorateExpand $ hasChildren node
-    nodeWidget =
-      decorateFlags (nodeFlags node) $
-      decorateFocus focused $
-      expand $ nodeToWidget node
-    subnodeWidgets = if folded then [] else subnodesToTrees ds node

src/Forest/Client/NodeEditor.hs

@@ -3,63 +3,45 @@
 module Forest.Client.NodeEditor
   ( NodeEditor
   , getCurrentText
-  , asReply
+  , beginEdit
-  , editNode
-  , replyToNode
   , handleNodeEditorEvent
   , renderNodeEditor
   ) where
 
 import           Brick
 import           Brick.Widgets.Edit
-import qualified Data.Text                  as T
+import qualified Data.Text          as T
 import           Data.Text.Zipper
-import qualified Graphics.Vty               as Vty
+import qualified Graphics.Vty       as Vty
 import           Lens.Micro
 
-import           Forest.Client.ResourceName
+newtype NodeEditor n = NodeEditor (Editor T.Text n)
+  deriving (Show)
 
-data NodeEditor = NodeEditor
+getCurrentLines :: NodeEditor n -> [T.Text]
-  { neEditor :: Editor T.Text ResourceName
+getCurrentLines (NodeEditor e) = getEditContents e
-  , neReply  :: Bool
-  } deriving (Show)
 
-getCurrentText :: NodeEditor -> [T.Text]
+getCurrentText :: NodeEditor n -> T.Text
-getCurrentText = getEditContents . neEditor
+getCurrentText = T.intercalate "\n" . getCurrentLines
 
-asReply :: NodeEditor -> Bool
+beginEdit :: n -> T.Text -> NodeEditor n
-asReply = neReply
+beginEdit name = NodeEditor . applyEdit gotoEOL . editorText name Nothing
 
-editNode :: T.Text -> NodeEditor
+edit :: (TextZipper T.Text -> TextZipper T.Text) -> NodeEditor n -> EventM n (NodeEditor n)
-editNode text = NodeEditor
+edit z (NodeEditor e) = pure $ NodeEditor $ applyEdit z e
-  { neEditor = applyEdit gotoEOL $ editorText RnEditor Nothing text
-  , neReply = False
-  }
 
-replyToNode :: NodeEditor
+handleNodeEditorEvent :: Vty.Event -> NodeEditor n -> EventM n (NodeEditor n)
-replyToNode = NodeEditor
-  { neEditor = editorText RnEditor Nothing ""
-  , neReply = True
-  }
-
-edit :: (TextZipper T.Text -> TextZipper T.Text) -> NodeEditor -> EventM ResourceName NodeEditor
-edit z ne = pure $ ne{neEditor = applyEdit z $ neEditor ne}
-
-handleNodeEditorEvent :: Vty.Event -> NodeEditor -> EventM ResourceName NodeEditor
 handleNodeEditorEvent (Vty.EvKey Vty.KHome _) ne = edit gotoBOL ne
 handleNodeEditorEvent (Vty.EvKey Vty.KEnd _) ne = edit gotoEOL ne
-handleNodeEditorEvent event ne = do
+handleNodeEditorEvent event (NodeEditor e) = NodeEditor <$> handleEditorEvent event e
-  newEditor <- handleEditorEvent event $ neEditor ne
-  pure ne{neEditor = newEditor}
 
-renderNodeEditor :: NodeEditor -> Widget ResourceName
+renderLines :: [T.Text] -> Widget n
-renderNodeEditor ne = makeVisible $ vLimit height $ renderEditor renderFunc True ed
+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
-    ed = neEditor ne
+    height = length $ getCurrentLines ne
-
+    (row, col) = cursorPosition $ e ^. editContentsL
-    height = length $ getCurrentText ne
-    renderFunc :: [T.Text] -> Widget ResourceName
-    renderFunc = vBox . map (\t -> if T.null t then txt " " else txt t)
-
-    (row, col) = cursorPosition $ ed ^. editContentsL
     makeVisible = visibleRegion (Location (col, row)) (1, 1)

src/Forest/Client/NodeUtil.hs

@@ -0,0 +1,50 @@
+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 = foldVisibleNodes (\_ node _ -> 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

src/Forest/Client/ResourceName.hs

@@ -1,6 +0,0 @@
-module Forest.Client.ResourceName
-  ( ResourceName(..)
-  ) where
-
-data ResourceName = RnViewport | RnEditor
-  deriving (Show, Eq, Ord)

src/Forest/Client/Tree.hs

@@ -1,142 +0,0 @@
-module Forest.Client.Tree
-  ( Tree
-  , newTree
-  , replaceNode
-  , renderTree
-  -- * Focused element
-  , getCurrent
-  , getCurrentPath
-  , moveUp
-  , moveDown
-  -- * Folding
-  , isCurrentFolded
-  , foldCurrent
-  , unfoldCurrent
-  , toggleFold
-  ) where
-
-import           Brick
-import           Data.Maybe
-import qualified Data.Set                   as Set
-
-import           Forest.Client.Node
-import           Forest.Client.NodeEditor
-import           Forest.Client.ResourceName
-import           Forest.Client.WidgetTree
-import           Forest.Node
-import qualified Forest.OrderedMap          as OMap
-import           Forest.Util
-
-data Tree = Tree
-  { treeNode     :: Node
-  -- Invariant: The node pointed to by the focused path must always exist
-  -- Invariant: The node pointed to by the focused path must not be folded away
-  , treeFocused  :: Path
-  -- Invariant: The nodes pointed to by the unfolded paths must always exist
-  , treeUnfolded :: Set.Set Path
-  } deriving (Show)
-
--- | Find the focus path closest to the input path that still corresponds to a
--- node in the input tree.
-findNearestFocus :: Node -> Path -> Path
-findNearestFocus _ (Path []) = Path []
-findNearestFocus node (Path (x:xs)) = case applyId x node of
-  Nothing    -> Path []
-  Just child ->
-    let (Path childPath) = findNearestFocus child $ Path xs
-    in  Path (x:childPath)
-
--- | Create a new tree, ensuring that all required invariants hold.
-newTree :: Node -> Path -> Set.Set Path -> Tree
-newTree node focused unfolded = Tree
-  { treeNode     = node
-  , treeFocused  = safeFocused
-  , treeUnfolded = safeUnfolded
-  }
-  where
-    isValidFold :: Node -> Path -> Bool
-    isValidFold n p = case applyPath p n of
-      Nothing        -> False
-      Just childNode -> hasChildren childNode
-
-    foldedNode = applyFolds unfolded node
-    safeUnfolded = Set.filter (isValidFold foldedNode) unfolded
-    safeFocused = findNearestFocus (applyFolds safeUnfolded node) focused
-
--- | Switch out a tree's node, keeping as much of the focus and folding
--- information as the type's invariants allow.
-replaceNode :: Node -> Tree -> Tree
-replaceNode node tree = newTree node (treeFocused tree) (treeUnfolded tree)
-
--- | Render a 'Tree' into a widget.
-renderTree :: IndentOptions -> Maybe NodeEditor -> Tree -> Widget ResourceName
-renderTree opts maybeEditor tree =
-  renderWidgetTree opts $ nodeToTree drawState $ treeNode tree
-  where
-    drawState = DrawState
-      { dsEditor = maybeEditor
-      , dsFocused = Just $ treeFocused tree
-      , dsUnfolded = treeUnfolded tree
-      }
-
-{- Focused element -}
-
--- | Get the currently focused node.
-getCurrent :: Tree -> Node
--- We rely on the invariant that the focused node always exists
-getCurrent tree = fromJust $ applyPath (treeFocused tree) (treeNode tree)
-
--- | Get the path of the currently focused node.
-getCurrentPath :: Tree -> Path
-getCurrentPath = treeFocused
-
-flatten :: Node -> [Path]
-flatten node =
-  let flattenedChildren =
-        mapChildren (\nid n -> map (Path [nid] <>) $ flatten n) node
-   in Path [] : concat flattenedChildren
-
-moveWith :: ((Path -> Bool) -> [Path] -> Maybe Path) -> Tree -> Tree
-moveWith finder Tree{treeNode=n, treeFocused=f, treeUnfolded=u} =
-  let flattened = flatten $ applyFolds u n
-      target = fromMaybe f $ finder (==f) flattened
-  in  newTree n target u
-
--- | Move the focus upward by one node, if possible. Otherwise, do nothing.
-moveUp :: Tree -> Tree
-moveUp = moveWith findPrev
-
--- | Move the focus downward by one node, if possible. Otherwise, do nothing.
-moveDown :: Tree -> Tree
-moveDown = moveWith findNext
-
-{- Folding -}
-
--- | Check if the currently focused node is folded.
-isCurrentFolded :: Tree -> Bool
-isCurrentFolded tree = not $ treeFocused tree `Set.member` treeUnfolded tree
-
--- | Fold the currently focused node. Does nothing if it is already folded.
-foldCurrent :: Tree -> Tree
-foldCurrent Tree{treeNode=n, treeFocused=f, treeUnfolded=u} =
-  newTree n f $ Set.delete f u
-
--- | Unfold the currently focused node. Does nothing if it is already unfolded.
-unfoldCurrent :: Tree -> Tree
-unfoldCurrent Tree{treeNode=n, treeFocused=f, treeUnfolded=u} =
-  newTree n f $ Set.insert f u
-
--- | Toggle whether the currently focused node is folded.
-toggleFold :: Tree -> Tree
-toggleFold tree
-  | isCurrentFolded tree = unfoldCurrent tree
-  | otherwise            = foldCurrent tree
-
--- | Remove all nodes that would not be visible due to the folding.
-applyFolds :: Set.Set Path -> Node -> Node
-applyFolds unfolded node
-  | mempty `Set.member` unfolded = node {nodeChildren = foldedChildren}
-  | otherwise                    = node {nodeChildren = OMap.empty}
-  where
-    foldedChildren = OMap.mapWithKey applyFoldsToChild $ nodeChildren node
-    applyFoldsToChild nid = applyFolds $ narrowSet nid unfolded

src/Forest/Client/UiState.hs

@@ -0,0 +1,238 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Forest.Client.UiState
+  ( UiState
+  , newUiState
+  , getFocusedPath
+  , getFocusedNode
+  -- * Modifying the UI state
+  , replaceRootNode
+  , moveFocusUp
+  , moveFocusDown
+  , foldAtFocus
+  -- ** The node editor
+  -- *** Creating
+  , editCurrentNode
+  , replyToCurrentNode
+  , replyAfterCurrentNode
+  -- *** Updating
+  , isEditorActive
+  , updateEditor
+  -- *** Finishing the edit
+  , EditResult(..)
+  , finishEditing
+  , abortEditing
+  -- * Rendering the UI state
+  , renderUiState
+  ) where
+
+import qualified Graphics.Vty as Vty
+import           Brick
+import           Control.Monad
+import           Data.Maybe
+import qualified Data.Set                 as Set
+import qualified Data.Text                as T
+
+import           Forest.Client.NodeEditor
+import           Forest.Client.NodeUtil
+import           Forest.Client.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 -> 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}
+
+moveFocusUp :: UiState n -> UiState n
+moveFocusUp s =
+  let foldedRootNode = applyFolds (uiUnfolded s) (uiRootNode s)
+  in  s {uiFocused = findPrevNode foldedRootNode $ uiFocused s}
+
+moveFocusDown :: UiState n -> UiState n
+moveFocusDown s =
+  let foldedRootNode = applyFolds (uiUnfolded s) (uiRootNode s)
+  in  s {uiFocused = findNextNode foldedRootNode $ uiFocused s}
+
+foldAtFocus :: UiState n -> UiState n
+foldAtFocus s =
+  let focused = uiFocused s
+      unfolded = uiUnfolded s
+      newUnfolded = if focused `Set.member` unfolded
+        then Set.delete focused unfolded
+        else Set.insert focused unfolded
+  in validateUnfolded s {uiUnfolded = newUnfolded}
+
+editNode :: Bool -> Path -> UiState n -> UiState n
+editNode reply path s =
+  let text = maybe "" nodeText $ applyPath path $ uiRootNode 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) 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 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) $
+  txtWrap $ nodeText node
+
+beingEdited :: UiState n -> Path -> Maybe (EditorInfo n)
+beingEdited s path = do
+  e <- uiEditor s
+  if eiReply e
+    then do
+      p <- parent path
+      guard $ p == eiPath e
+    else
+      guard $ path == eiPath e
+  pure e
+
+nodeToTree :: (Ord n, Show n) => UiState n -> Path -> Node -> Maybe [WidgetTree n] -> WidgetTree n
+nodeToTree s path node = withChildren $ case beingEdited s path of
+  Just e  -> renderNodeEditor $ eiEditor e
+  Nothing -> renderNode isFocused node
+  where
+    withChildren :: Widget n -> Maybe [WidgetTree n] -> WidgetTree n
+    withChildren nodeWidget = WidgetTree nodeWidget . fromMaybe []
+    isFocused = isNothing (uiEditor s) && (path == uiFocused s)
+
+renderUiState :: (Ord n, Show n) => IndentOptions -> UiState n -> Widget n
+renderUiState opts s =
+  renderWidgetTree opts $
+  foldVisibleNodes (nodeToTree s) (uiUnfolded s) (uiRootNode s)

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"

src/Forest/Node.hs

@@ -20,7 +20,9 @@ module Forest.Node
   , appendAt
   , diffNodes
   , Path(..)
-  , split
+  , referencedNodeExists
+  , splitHeadTail
+  , splitInitLast
   , parent
   , narrow
   , narrowSet
@@ -157,7 +159,7 @@ replaceAt node = adjustAt $ const node
 
 -- | Delete a subnode at a specified path. Does nothing if the path is 'mempty'.
 deleteAt :: Path -> Node -> Node
-deleteAt path node = case split path of
+deleteAt path node = case splitInitLast path of
   Nothing -> node
   Just (parentPath, nodeId) -> adjustAt
     (\n -> n{nodeChildren = OMap.delete nodeId $ nodeChildren n})
@@ -193,12 +195,19 @@ newtype Path = Path
   { pathElements :: [NodeId]
   } deriving (Show, Eq, Ord, Semigroup, Monoid, ToJSON, FromJSON)
 
-split :: Path -> Maybe (Path, NodeId)
+referencedNodeExists :: Node -> Path -> Bool
-split (Path []) = Nothing
+referencedNodeExists node path = isJust $ applyPath path node
-split (Path xs) = Just (Path (init xs), last xs)
+
+splitHeadTail :: Path -> Maybe (NodeId, Path)
+splitHeadTail (Path [])     = Nothing
+splitHeadTail (Path (x:xs)) = Just (x, Path xs)
+
+splitInitLast :: Path -> Maybe (Path, NodeId)
+splitInitLast (Path []) = Nothing
+splitInitLast (Path xs) = Just (Path (init xs), last xs)
 
 parent :: Path -> Maybe Path
-parent path = fst <$> split path
+parent path = fst <$> splitInitLast path
 
 -- | Try to remove a 'NodeId' from the beginning of a 'Path'.
 narrow :: NodeId -> Path -> Maybe Path