[client] Remove client
This commit is contained in:
parent
9fa804f87f
commit
922488a836
9 changed files with 0 additions and 809 deletions
|
|
@ -1,12 +0,0 @@
|
||||||
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
|
|
||||||
17
package.yaml
17
package.yaml
|
|
@ -16,17 +16,10 @@ dependencies:
|
||||||
- base >= 4.7 && < 5
|
- base >= 4.7 && < 5
|
||||||
- aeson
|
- aeson
|
||||||
- async
|
- async
|
||||||
- brick
|
|
||||||
- containers
|
- containers
|
||||||
- microlens
|
|
||||||
- optparse-applicative
|
|
||||||
- safe
|
|
||||||
- text
|
- text
|
||||||
- text-zipper
|
|
||||||
- transformers
|
- transformers
|
||||||
- vty
|
|
||||||
- websockets
|
- websockets
|
||||||
- wuss
|
|
||||||
|
|
||||||
library:
|
library:
|
||||||
source-dirs: src
|
source-dirs: src
|
||||||
|
|
@ -41,13 +34,3 @@ executables:
|
||||||
- -with-rtsopts=-N
|
- -with-rtsopts=-N
|
||||||
dependencies:
|
dependencies:
|
||||||
- forest
|
- forest
|
||||||
|
|
||||||
forest-client:
|
|
||||||
main: Main.hs
|
|
||||||
source-dirs: client
|
|
||||||
ghc-options:
|
|
||||||
- -threaded
|
|
||||||
- -rtsopts
|
|
||||||
- -with-rtsopts=-N
|
|
||||||
dependencies:
|
|
||||||
- forest
|
|
||||||
|
|
|
||||||
|
|
@ -1,148 +0,0 @@
|
||||||
{-# 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 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)
|
|
||||||
]
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
@ -1,47 +0,0 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
module Forest.Client.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
|
|
||||||
import Lens.Micro
|
|
||||||
|
|
||||||
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 $ e ^. editContentsL
|
|
||||||
makeVisible = visibleRegion (Location (col, row)) (1, 1)
|
|
||||||
|
|
@ -1,56 +0,0 @@
|
||||||
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
|
|
||||||
|
|
@ -1,67 +0,0 @@
|
||||||
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)
|
|
||||||
)
|
|
||||||
|
|
@ -1,269 +0,0 @@
|
||||||
{-# 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.Maybe
|
|
||||||
import qualified Data.Set as Set
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import qualified Graphics.Vty as Vty
|
|
||||||
import Safe
|
|
||||||
|
|
||||||
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 -> 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}
|
|
||||||
|
|
||||||
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) $
|
|
||||||
txtWrap $ 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)
|
|
||||||
|
|
@ -1,73 +0,0 @@
|
||||||
{-# 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"
|
|
||||||
|
|
@ -1,120 +0,0 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
module Forest.Client.WidgetTree
|
|
||||||
( WidgetTree(..)
|
|
||||||
, renderWidgetTree
|
|
||||||
, treeLineAttr
|
|
||||||
, IndentOptions(..)
|
|
||||||
, boxDrawingBranching
|
|
||||||
, boxDrawingLine
|
|
||||||
, asciiBranching
|
|
||||||
, asciiLine
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Brick
|
|
||||||
import Brick.BorderMap
|
|
||||||
import Control.Monad.Trans.Reader
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import qualified Graphics.Vty as Vty
|
|
||||||
import Lens.Micro
|
|
||||||
|
|
||||||
data WidgetTree n = WidgetTree (Widget n) [WidgetTree n]
|
|
||||||
|
|
||||||
addLoc :: Location -> Location -> Location
|
|
||||||
addLoc l1 l2 =
|
|
||||||
let (x1, y1) = loc l1
|
|
||||||
(x2, y2) = loc l2
|
|
||||||
in Location (x1 + x2, y1 + y2)
|
|
||||||
|
|
||||||
offsetResult :: Location -> Result n -> Result n
|
|
||||||
offsetResult offset result = result
|
|
||||||
{ cursors = map offsetCursor $ cursors result
|
|
||||||
, visibilityRequests = map offsetVr $ visibilityRequests result
|
|
||||||
, extents = map offsetExtent $ extents result
|
|
||||||
, borders = translate offset $ borders result
|
|
||||||
}
|
|
||||||
where
|
|
||||||
offsetCursor c = c{cursorLocation = addLoc offset $ cursorLocation c}
|
|
||||||
offsetVr vr = vr{vrPosition = addLoc offset $ vrPosition vr}
|
|
||||||
offsetExtent e = e
|
|
||||||
{ extentUpperLeft = addLoc offset $ extentUpperLeft e
|
|
||||||
, extentOffset = addLoc offset $ extentOffset e
|
|
||||||
}
|
|
||||||
|
|
||||||
indentWith :: T.Text -> T.Text -> Widget n -> Widget n
|
|
||||||
indentWith firstLine otherLines wrapped = Widget
|
|
||||||
{ hSize = hSize wrapped
|
|
||||||
, vSize = vSize wrapped
|
|
||||||
, render = renderWidget
|
|
||||||
}
|
|
||||||
where
|
|
||||||
maxWidth = max (T.length firstLine) (T.length otherLines)
|
|
||||||
renderWidget = do
|
|
||||||
context <- ask
|
|
||||||
result <- render $ hLimit (availWidth context - maxWidth) wrapped
|
|
||||||
let attribute = attrMapLookup treeLineAttr $ context ^. ctxAttrMapL
|
|
||||||
resultHeight = Vty.imageHeight $ image result
|
|
||||||
textLines = firstLine : replicate (resultHeight - 1) otherLines
|
|
||||||
leftImage = Vty.vertCat $ map (Vty.text' attribute) textLines
|
|
||||||
newImage = leftImage Vty.<|> image result
|
|
||||||
newResult = offsetResult (Location (maxWidth, 0)) $ result{image=newImage}
|
|
||||||
pure newResult
|
|
||||||
|
|
||||||
indent :: IndentOptions -> [Widget n] -> Widget n
|
|
||||||
indent opts widgets = vBox $ reverse $ case reverse widgets of
|
|
||||||
[] -> []
|
|
||||||
(w:ws) ->
|
|
||||||
indentWith (lastBranch opts) (afterLastBranch opts) w :
|
|
||||||
map (indentWith (inlineBranch opts) (noBranch opts)) ws
|
|
||||||
|
|
||||||
renderWidgetTree :: IndentOptions -> WidgetTree n -> Widget n
|
|
||||||
renderWidgetTree opts (WidgetTree node children) =
|
|
||||||
node <=> indent opts (map (renderWidgetTree opts) children)
|
|
||||||
|
|
||||||
treeLineAttr :: AttrName
|
|
||||||
treeLineAttr = "treeLine"
|
|
||||||
|
|
||||||
-- | These options control how a tree is rendered. For more information on how
|
|
||||||
-- the various options are used, try rendering a tree with 'boxDrawingBranhing'
|
|
||||||
-- and inspect the results.
|
|
||||||
--
|
|
||||||
-- Warning: The options *must* be single line strings and *must not* contain
|
|
||||||
-- newlines of any sort.
|
|
||||||
data IndentOptions = IndentOptions
|
|
||||||
{ noBranch :: T.Text
|
|
||||||
, inlineBranch :: T.Text
|
|
||||||
, lastBranch :: T.Text
|
|
||||||
, afterLastBranch :: T.Text
|
|
||||||
} deriving (Show, Eq)
|
|
||||||
|
|
||||||
boxDrawingBranching :: IndentOptions
|
|
||||||
boxDrawingBranching = IndentOptions
|
|
||||||
{ noBranch = "│ "
|
|
||||||
, inlineBranch = "├╴"
|
|
||||||
, lastBranch = "└╴"
|
|
||||||
, afterLastBranch = " "
|
|
||||||
}
|
|
||||||
|
|
||||||
boxDrawingLine :: IndentOptions
|
|
||||||
boxDrawingLine = IndentOptions
|
|
||||||
{ noBranch = "│ "
|
|
||||||
, inlineBranch = "│ "
|
|
||||||
, lastBranch = "│ "
|
|
||||||
, afterLastBranch = "│ "
|
|
||||||
}
|
|
||||||
|
|
||||||
asciiBranching :: IndentOptions
|
|
||||||
asciiBranching = IndentOptions
|
|
||||||
{ noBranch = "| "
|
|
||||||
, inlineBranch = "+-"
|
|
||||||
, lastBranch = "+-"
|
|
||||||
, afterLastBranch = " "
|
|
||||||
}
|
|
||||||
|
|
||||||
asciiLine :: IndentOptions
|
|
||||||
asciiLine = IndentOptions
|
|
||||||
{ noBranch = "| "
|
|
||||||
, inlineBranch = "| "
|
|
||||||
, lastBranch = "| "
|
|
||||||
, afterLastBranch = "| "
|
|
||||||
}
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue