Compare commits
1 commit
master
...
server-onl
| Author | SHA1 | Date | |
|---|---|---|---|
| 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
|
||||
- aeson
|
||||
- async
|
||||
- brick
|
||||
- containers
|
||||
- microlens
|
||||
- optparse-applicative
|
||||
- safe
|
||||
- text
|
||||
- text-zipper
|
||||
- transformers
|
||||
- vty
|
||||
- websockets
|
||||
- wuss
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
|
|
@ -41,13 +34,3 @@ executables:
|
|||
- -with-rtsopts=-N
|
||||
dependencies:
|
||||
- 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