150 lines
5.1 KiB
Haskell
150 lines
5.1 KiB
Haskell
{-# 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
|