[all] Reorganize haskell code into multiple packages

2020-03-14 01:02:57 +00:00 · 2020-03-14 01:02:57 +00:00 · 4b8d0ee4a4
commit 4b8d0ee4a4
parent 0edc241149
37 changed files with 368 additions and 140 deletions
--- a/forest-tui/src/Forest/Client.hs
+++ b/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