From 922488a8366f0bc416fa45982b5cdf3315cd6610 Mon Sep 17 00:00:00 2001 From: Joscha Date: Tue, 18 Feb 2020 10:23:54 +0000 Subject: [PATCH 01/27] [client] Remove client --- client/Main.hs | 12 -- package.yaml | 17 -- src/Forest/Client.hs | 148 ------------------ src/Forest/Client/NodeEditor.hs | 47 ------ src/Forest/Client/NodeUtil.hs | 56 ------- src/Forest/Client/Options.hs | 67 -------- src/Forest/Client/UiState.hs | 269 -------------------------------- src/Forest/Client/Websocket.hs | 73 --------- src/Forest/Client/WidgetTree.hs | 120 -------------- 9 files changed, 809 deletions(-) delete mode 100644 client/Main.hs delete mode 100644 src/Forest/Client.hs delete mode 100644 src/Forest/Client/NodeEditor.hs delete mode 100644 src/Forest/Client/NodeUtil.hs delete mode 100644 src/Forest/Client/Options.hs delete mode 100644 src/Forest/Client/UiState.hs delete mode 100644 src/Forest/Client/Websocket.hs delete mode 100644 src/Forest/Client/WidgetTree.hs diff --git a/client/Main.hs b/client/Main.hs deleted file mode 100644 index 4a11e56..0000000 --- a/client/Main.hs +++ /dev/null @@ -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 diff --git a/package.yaml b/package.yaml index 0d6dcdc..375ed1d 100644 --- a/package.yaml +++ b/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 diff --git a/src/Forest/Client.hs b/src/Forest/Client.hs deleted file mode 100644 index 9ed37fe..0000000 --- a/src/Forest/Client.hs +++ /dev/null @@ -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 diff --git a/src/Forest/Client/NodeEditor.hs b/src/Forest/Client/NodeEditor.hs deleted file mode 100644 index aae8142..0000000 --- a/src/Forest/Client/NodeEditor.hs +++ /dev/null @@ -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) diff --git a/src/Forest/Client/NodeUtil.hs b/src/Forest/Client/NodeUtil.hs deleted file mode 100644 index 1f0c031..0000000 --- a/src/Forest/Client/NodeUtil.hs +++ /dev/null @@ -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 diff --git a/src/Forest/Client/Options.hs b/src/Forest/Client/Options.hs deleted file mode 100644 index ead27bf..0000000 --- a/src/Forest/Client/Options.hs +++ /dev/null @@ -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) - ) diff --git a/src/Forest/Client/UiState.hs b/src/Forest/Client/UiState.hs deleted file mode 100644 index 915172b..0000000 --- a/src/Forest/Client/UiState.hs +++ /dev/null @@ -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) diff --git a/src/Forest/Client/Websocket.hs b/src/Forest/Client/Websocket.hs deleted file mode 100644 index 2b9d703..0000000 --- a/src/Forest/Client/Websocket.hs +++ /dev/null @@ -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" diff --git a/src/Forest/Client/WidgetTree.hs b/src/Forest/Client/WidgetTree.hs deleted file mode 100644 index 7b4cad3..0000000 --- a/src/Forest/Client/WidgetTree.hs +++ /dev/null @@ -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 = "| " - } From a2c2c4487bf65587e6728c15bc83d73d68b06e4e Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 26 Feb 2020 08:34:19 +0000 Subject: [PATCH 02/27] [client] Improve cursor behaviour when elements are deleted --- src/Forest/Client/UiState.hs | 25 ++++++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/src/Forest/Client/UiState.hs b/src/Forest/Client/UiState.hs index 915172b..7991a17 100644 --- a/src/Forest/Client/UiState.hs +++ b/src/Forest/Client/UiState.hs @@ -33,6 +33,7 @@ module Forest.Client.UiState ) where import Brick +import Data.List import Data.Maybe import qualified Data.Set as Set import qualified Data.Text as T @@ -113,7 +114,29 @@ validate :: UiState n -> UiState n validate = validateEditor . validateFocused . validateUnfolded replaceRootNode :: Node -> UiState n -> UiState n -replaceRootNode node s = validate s {uiRootNode = node} +replaceRootNode node s = validate s { uiRootNode = node + , uiFocused = findNextValidNode (uiRootNode s) node (uiFocused s) + } + +-- | Find a node that is close to the previously focused node, taking into +-- account its previous position in the tree. +findNextValidNode :: Node -> Node -> Path -> Path +findNextValidNode _ _ (Path []) = Path [] +findNextValidNode from to (Path (x:xs)) = fromMaybe (Path []) $ do + fromNode <- applyId x from + case applyId x to of + Just toNode -> pure $ Path [x] <> findNextValidNode fromNode toNode (Path xs) + Nothing -> do + fromIdx <- elemIndex x $ OMap.keys $ nodeChildren from + let toKeys = OMap.keys $ nodeChildren to + x' <- getValueClosestToIndex fromIdx toKeys + pure $ Path [x'] + where + -- Slightly unsafe code, but it should be fine + getValueClosestToIndex idx list + | length list > idx = Just $ list !! idx + | null list = Nothing + | otherwise = Just $ last list moveFocus :: (Node -> Path -> Path) -> UiState n -> UiState n moveFocus f s = From 22974d96a7bf18ddcc6894ed29d1672f01d4b07a Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 26 Feb 2020 08:47:08 +0000 Subject: [PATCH 03/27] [server] Move server-related files into their own subdirectory --- server/Main.hs | 10 +++++----- src/Forest/Server.hs | 4 ++-- src/Forest/{ => Server}/Broadcast.hs | 2 +- src/Forest/{ => Server}/TreeModule.hs | 2 +- src/Forest/{ => Server}/TreeModule/Animate.hs | 4 ++-- src/Forest/{ => Server}/TreeModule/Const.hs | 4 ++-- src/Forest/{ => Server}/TreeModule/Fork.hs | 4 ++-- src/Forest/{ => Server}/TreeModule/SharedEditing.hs | 6 +++--- 8 files changed, 18 insertions(+), 18 deletions(-) rename src/Forest/{ => Server}/Broadcast.hs (98%) rename src/Forest/{ => Server}/TreeModule.hs (94%) rename src/Forest/{ => Server}/TreeModule/Animate.hs (89%) rename src/Forest/{ => Server}/TreeModule/Const.hs (98%) rename src/Forest/{ => Server}/TreeModule/Fork.hs (97%) rename src/Forest/{ => Server}/TreeModule/SharedEditing.hs (92%) diff --git a/server/Main.hs b/server/Main.hs index 9dc690d..6a5eee8 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -3,14 +3,14 @@ module Main where import Control.Concurrent.MVar -import qualified Network.WebSockets as WS +import qualified Network.WebSockets as WS -import Forest.Broadcast import Forest.Node import Forest.Server -import Forest.TreeModule.Const -import Forest.TreeModule.Fork -import Forest.TreeModule.SharedEditing +import Forest.Server.Broadcast +import Forest.Server.TreeModule.Const +import Forest.Server.TreeModule.Fork +import Forest.Server.TreeModule.SharedEditing pingDelay :: Int pingDelay = 10 diff --git a/src/Forest/Server.hs b/src/Forest/Server.hs index e8e3716..cda6b93 100644 --- a/src/Forest/Server.hs +++ b/src/Forest/Server.hs @@ -8,11 +8,11 @@ module Forest.Server import Control.Concurrent.Chan import Control.Exception -import qualified Network.WebSockets as WS +import qualified Network.WebSockets as WS import Forest.Api import Forest.Node -import Forest.TreeModule +import Forest.Server.TreeModule import Forest.Util {- Thread that sends updates to the client -} diff --git a/src/Forest/Broadcast.hs b/src/Forest/Server/Broadcast.hs similarity index 98% rename from src/Forest/Broadcast.hs rename to src/Forest/Server/Broadcast.hs index 2c319c6..e7fb4b0 100644 --- a/src/Forest/Broadcast.hs +++ b/src/Forest/Server/Broadcast.hs @@ -6,7 +6,7 @@ -- All functions included in this module should be threadsafe. Be sure to read -- the warning on the 'broadcast' function. -module Forest.Broadcast +module Forest.Server.Broadcast ( Broadcaster , Listener , newBroadcaster diff --git a/src/Forest/TreeModule.hs b/src/Forest/Server/TreeModule.hs similarity index 94% rename from src/Forest/TreeModule.hs rename to src/Forest/Server/TreeModule.hs index bcd7036..b289179 100644 --- a/src/Forest/TreeModule.hs +++ b/src/Forest/Server/TreeModule.hs @@ -1,6 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} -module Forest.TreeModule +module Forest.Server.TreeModule ( TreeModule(..) , ModuleConstructor ) where diff --git a/src/Forest/TreeModule/Animate.hs b/src/Forest/Server/TreeModule/Animate.hs similarity index 89% rename from src/Forest/TreeModule/Animate.hs rename to src/Forest/Server/TreeModule/Animate.hs index 7a5b32c..9aef0f8 100644 --- a/src/Forest/TreeModule/Animate.hs +++ b/src/Forest/Server/TreeModule/Animate.hs @@ -1,7 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -module Forest.TreeModule.Animate +module Forest.Server.TreeModule.Animate ( AnimateModule , animateModule ) where @@ -9,7 +9,7 @@ module Forest.TreeModule.Animate import Control.Concurrent import Forest.Node -import Forest.TreeModule +import Forest.Server.TreeModule import Forest.Util data AnimateModule r = AnimateModule diff --git a/src/Forest/TreeModule/Const.hs b/src/Forest/Server/TreeModule/Const.hs similarity index 98% rename from src/Forest/TreeModule/Const.hs rename to src/Forest/Server/TreeModule/Const.hs index 25ac72b..3d8124f 100644 --- a/src/Forest/TreeModule/Const.hs +++ b/src/Forest/Server/TreeModule/Const.hs @@ -1,14 +1,14 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -module Forest.TreeModule.Const +module Forest.Server.TreeModule.Const ( ConstModule , constModule , projectDescriptionNode ) where import Forest.Node -import Forest.TreeModule +import Forest.Server.TreeModule data ConstModule r = ConstModule diff --git a/src/Forest/TreeModule/Fork.hs b/src/Forest/Server/TreeModule/Fork.hs similarity index 97% rename from src/Forest/TreeModule/Fork.hs rename to src/Forest/Server/TreeModule/Fork.hs index d1b4d67..7be309e 100644 --- a/src/Forest/TreeModule/Fork.hs +++ b/src/Forest/Server/TreeModule/Fork.hs @@ -3,7 +3,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} -module Forest.TreeModule.Fork +module Forest.Server.TreeModule.Fork ( ForkModule , ProngConstructor(..) , forkModule @@ -16,7 +16,7 @@ import qualified Data.Text as T import Forest.Node import qualified Forest.OrderedMap as OMap -import Forest.TreeModule +import Forest.Server.TreeModule data Prong = forall r a . TreeModule a r => Prong (a r) diff --git a/src/Forest/TreeModule/SharedEditing.hs b/src/Forest/Server/TreeModule/SharedEditing.hs similarity index 92% rename from src/Forest/TreeModule/SharedEditing.hs rename to src/Forest/Server/TreeModule/SharedEditing.hs index b67d431..59e4bc2 100644 --- a/src/Forest/TreeModule/SharedEditing.hs +++ b/src/Forest/Server/TreeModule/SharedEditing.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -module Forest.TreeModule.SharedEditing +module Forest.Server.TreeModule.SharedEditing ( SharedEditingModule , sharedEditingModule ) where @@ -9,9 +9,9 @@ module Forest.TreeModule.SharedEditing import Control.Concurrent.MVar import Control.Monad -import Forest.Broadcast import Forest.Node -import Forest.TreeModule +import Forest.Server.Broadcast +import Forest.Server.TreeModule import Forest.Util data SharedEditingModule r = SharedEditingModule From ab8c7643296b191f8f83f30a1974ae7376370c01 Mon Sep 17 00:00:00 2001 From: Joscha Date: Thu, 27 Feb 2020 15:06:03 +0000 Subject: [PATCH 04/27] [client] Align node permissions to the right The previous layout depended on txtWrap being greedy, but not taking up all available horizontal space. That behaviour is incorrect according to the definition of greedy widgets, which have to take up all available horizontal space. In brick 0.52, this behaviour has been partially fixed. The padRight function added in this commit emulates the correct txtWrap behaviour even for cases where txtWrap has not been fixed yet. If txtWrap is fixed entirely, the padRight can be removed again. --- src/Forest/Client/UiState.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Forest/Client/UiState.hs b/src/Forest/Client/UiState.hs index 7991a17..29f2b23 100644 --- a/src/Forest/Client/UiState.hs +++ b/src/Forest/Client/UiState.hs @@ -268,7 +268,7 @@ renderNode focused node = decorateFlags (nodeFlags node) $ decorateFocus focused $ decorateExpand (not $ OMap.null $ nodeChildren node) $ - txtWrap $ nodeText node + padRight Max $ 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 From 50e78cfed3e0e475c6387f984f71eaafbcbfaada Mon Sep 17 00:00:00 2001 From: Joscha Date: Fri, 28 Feb 2020 18:30:05 +0000 Subject: [PATCH 05/27] [client] Use the correct function for the job Somehow, I missed this function and reimplemented it myself. Sometimes it helps to read the documentation... --- src/Forest/Client/WidgetTree.hs | 64 +++++++++++---------------------- 1 file changed, 21 insertions(+), 43 deletions(-) diff --git a/src/Forest/Client/WidgetTree.hs b/src/Forest/Client/WidgetTree.hs index 7b4cad3..13eb20d 100644 --- a/src/Forest/Client/WidgetTree.hs +++ b/src/Forest/Client/WidgetTree.hs @@ -12,60 +12,38 @@ module Forest.Client.WidgetTree ) 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 +indentWith :: AttrName -> T.Text -> T.Text -> Widget n -> Widget n +-- The "left" variables are for rendering the indentation text, the "right" +-- variables are for the rendered wrapped widget. +indentWith indentAttrName firstLine otherLines wrapped = + Widget (hSize wrapped) (vSize wrapped) $ do + let leftWidth = max (T.length firstLine) (T.length otherLines) + context <- getContext + rightResult <- render $ hLimit (availWidth context - leftWidth) wrapped + let rightImage = image rightResult + -- Construct the Vty image containing the indentation text + height = Vty.imageHeight rightImage + leftLines = firstLine : replicate (height - 1) otherLines + leftAttribute = attrMapLookup indentAttrName $ context ^. ctxAttrMapL + leftImage = Vty.vertCat $ map (Vty.text' leftAttribute) leftLines + -- Add the indentation text to the left of the result image + combinedImage = leftImage Vty.<|> image rightResult + offset = Location (leftWidth, 0) + result = addResultOffset offset rightResult & imageL .~ combinedImage + pure result 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 + indentWith treeLineAttr (lastBranch opts) (afterLastBranch opts) w : + map (indentWith treeLineAttr (inlineBranch opts) (noBranch opts)) ws renderWidgetTree :: IndentOptions -> WidgetTree n -> Widget n renderWidgetTree opts (WidgetTree node children) = From 0d01e4792dc790d3a91df4cb1bf69ba18b9b762e Mon Sep 17 00:00:00 2001 From: Joscha Date: Fri, 28 Feb 2020 19:01:37 +0000 Subject: [PATCH 06/27] [client] Remove microlens dependency --- package.yaml | 1 - src/Forest/Client/NodeEditor.hs | 3 +-- src/Forest/Client/WidgetTree.hs | 5 ++--- 3 files changed, 3 insertions(+), 6 deletions(-) diff --git a/package.yaml b/package.yaml index 0d6dcdc..4d171c7 100644 --- a/package.yaml +++ b/package.yaml @@ -18,7 +18,6 @@ dependencies: - async - brick - containers -- microlens - optparse-applicative - safe - text diff --git a/src/Forest/Client/NodeEditor.hs b/src/Forest/Client/NodeEditor.hs index aae8142..261ac4c 100644 --- a/src/Forest/Client/NodeEditor.hs +++ b/src/Forest/Client/NodeEditor.hs @@ -13,7 +13,6 @@ 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) @@ -43,5 +42,5 @@ renderNodeEditor ne@(NodeEditor e) = makeVisible $ vLimit height $ renderEditor renderLines True e where height = length $ getCurrentLines ne - (row, col) = cursorPosition $ e ^. editContentsL + (row, col) = cursorPosition $ editContents e makeVisible = visibleRegion (Location (col, row)) (1, 1) diff --git a/src/Forest/Client/WidgetTree.hs b/src/Forest/Client/WidgetTree.hs index 13eb20d..aaeb102 100644 --- a/src/Forest/Client/WidgetTree.hs +++ b/src/Forest/Client/WidgetTree.hs @@ -14,7 +14,6 @@ module Forest.Client.WidgetTree import Brick import qualified Data.Text as T import qualified Graphics.Vty as Vty -import Lens.Micro data WidgetTree n = WidgetTree (Widget n) [WidgetTree n] @@ -30,12 +29,12 @@ indentWith indentAttrName firstLine otherLines wrapped = -- Construct the Vty image containing the indentation text height = Vty.imageHeight rightImage leftLines = firstLine : replicate (height - 1) otherLines - leftAttribute = attrMapLookup indentAttrName $ context ^. ctxAttrMapL + leftAttribute = attrMapLookup indentAttrName $ ctxAttrMap context leftImage = Vty.vertCat $ map (Vty.text' leftAttribute) leftLines -- Add the indentation text to the left of the result image combinedImage = leftImage Vty.<|> image rightResult offset = Location (leftWidth, 0) - result = addResultOffset offset rightResult & imageL .~ combinedImage + result = (addResultOffset offset rightResult) {image=combinedImage} pure result indent :: IndentOptions -> [Widget n] -> Widget n From 041f117df8114df853f86d2f9095f7fb9b218c53 Mon Sep 17 00:00:00 2001 From: Joscha Date: Fri, 28 Feb 2020 19:21:37 +0000 Subject: [PATCH 07/27] [client] Allow choosing the attribute name for the indentation text --- src/Forest/Client/WidgetTree.hs | 78 ++++++++++++++++++++------------- 1 file changed, 48 insertions(+), 30 deletions(-) diff --git a/src/Forest/Client/WidgetTree.hs b/src/Forest/Client/WidgetTree.hs index aaeb102..ded6f23 100644 --- a/src/Forest/Client/WidgetTree.hs +++ b/src/Forest/Client/WidgetTree.hs @@ -2,6 +2,7 @@ module Forest.Client.WidgetTree ( WidgetTree(..) + , renderWidgetTreeWith , renderWidgetTree , treeLineAttr , IndentOptions(..) @@ -37,61 +38,78 @@ indentWith indentAttrName firstLine otherLines wrapped = result = (addResultOffset offset rightResult) {image=combinedImage} pure result -indent :: IndentOptions -> [Widget n] -> Widget n -indent opts widgets = vBox $ reverse $ case reverse widgets of +indent :: AttrName -> IndentOptions -> [Widget n] -> Widget n +indent indentAttrName opts widgets = vBox $ reverse $ case reverse widgets of [] -> [] (w:ws) -> - indentWith treeLineAttr (lastBranch opts) (afterLastBranch opts) w : - map (indentWith treeLineAttr (inlineBranch opts) (noBranch opts)) ws + indentWith indentAttrName (indentLastNodeFirstLine opts) (indentLastNodeRest opts) w : + map (indentWith indentAttrName (indentNodeFirstLine opts) (indentNodeRest opts)) ws + +renderWidgetTreeWith :: AttrName -> IndentOptions -> WidgetTree n -> Widget n +renderWidgetTreeWith indentAttrName opts (WidgetTree node children) = + node <=> indent indentAttrName opts (map (renderWidgetTreeWith indentAttrName opts) children) renderWidgetTree :: IndentOptions -> WidgetTree n -> Widget n -renderWidgetTree opts (WidgetTree node children) = - node <=> indent opts (map (renderWidgetTree opts) children) +renderWidgetTree = renderWidgetTreeWith treeLineAttr +-- | The attribute that 'renderWidgetTree' uses. 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. +-- | These options control how a tree is rendered. -- --- Warning: The options *must* be single line strings and *must not* contain +-- In the following example, the indent options are set to @'IndentOptions' "a" "b" "c" "d"@: +-- +-- > a This is the first node. +-- > b c It has a child. +-- > a This is a... +-- > b multiline... +-- > b node. +-- > c This is the last node. +-- > d c It has one child. +-- > d c And another one. +-- +-- 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 + { indentNodeFirstLine :: T.Text + -- ^ This is prepended to the first line of a node. + , indentNodeRest :: T.Text + -- ^ This is prepended to all other lines of a node, including its subnodes. + , indentLastNodeFirstLine :: T.Text + -- ^ This is prepended to the first line of the last node. + , indentLastNodeRest :: T.Text + -- ^ This is prepended to all other lines of the last node, including its subnodes. } deriving (Show, Eq) boxDrawingBranching :: IndentOptions boxDrawingBranching = IndentOptions - { noBranch = "│ " - , inlineBranch = "├╴" - , lastBranch = "└╴" - , afterLastBranch = " " + { indentNodeFirstLine = "├╴" + , indentNodeRest = "│ " + , indentLastNodeFirstLine = "└╴" + , indentLastNodeRest = " " } boxDrawingLine :: IndentOptions boxDrawingLine = IndentOptions - { noBranch = "│ " - , inlineBranch = "│ " - , lastBranch = "│ " - , afterLastBranch = "│ " + { indentNodeFirstLine = "│ " + , indentNodeRest = "│ " + , indentLastNodeFirstLine = "│ " + , indentLastNodeRest = "│ " } asciiBranching :: IndentOptions asciiBranching = IndentOptions - { noBranch = "| " - , inlineBranch = "+-" - , lastBranch = "+-" - , afterLastBranch = " " + { indentNodeFirstLine = "+-" + , indentNodeRest = "| " + , indentLastNodeFirstLine = "+-" + , indentLastNodeRest = " " } asciiLine :: IndentOptions asciiLine = IndentOptions - { noBranch = "| " - , inlineBranch = "| " - , lastBranch = "| " - , afterLastBranch = "| " + { indentNodeFirstLine = "| " + , indentNodeRest = "| " + , indentLastNodeFirstLine = "| " + , indentLastNodeRest = "| " } From d58f1e4fef48c7170f82a24c6eb5e5fcc1ee4f8d Mon Sep 17 00:00:00 2001 From: Joscha Date: Fri, 28 Feb 2020 19:35:42 +0000 Subject: [PATCH 08/27] [client] Fix rendering of nodes containing empty strings --- src/Forest/Client/UiState.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Forest/Client/UiState.hs b/src/Forest/Client/UiState.hs index 29f2b23..000f846 100644 --- a/src/Forest/Client/UiState.hs +++ b/src/Forest/Client/UiState.hs @@ -268,7 +268,11 @@ renderNode focused node = decorateFlags (nodeFlags node) $ decorateFocus focused $ decorateExpand (not $ OMap.null $ nodeChildren node) $ - padRight Max $ txtWrap $ nodeText node + padRight Max $ txtWrap text + where + text + | T.null $ nodeText node = " " + | otherwise = 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 From 0edc24114905ed0b1d07279f477704c3cc0e4e21 Mon Sep 17 00:00:00 2001 From: Joscha Date: Sat, 14 Mar 2020 00:04:37 +0000 Subject: [PATCH 09/27] [client] Adjust editor to look like web client text boxes --- src/Forest/Client.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Forest/Client.hs b/src/Forest/Client.hs index 9ed37fe..871bc66 100644 --- a/src/Forest/Client.hs +++ b/src/Forest/Client.hs @@ -8,6 +8,7 @@ module Forest.Client import Brick import Brick.BChan +import Brick.Widgets.Edit import Control.Monad import Control.Monad.IO.Class import qualified Graphics.Vty as Vty @@ -118,7 +119,7 @@ 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 + EventNode node -> onUiState cs $ replaceRootNode node EventConnectionClosed -> halt cs clientHandleEvent cs _ = continue cs @@ -128,6 +129,7 @@ clientAttrMap = attrMap Vty.defAttr , ("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 From 4b8d0ee4a44fefb452a6f102cb55bedb7f19b91c Mon Sep 17 00:00:00 2001 From: Joscha Date: Sat, 14 Mar 2020 01:02:57 +0000 Subject: [PATCH 10/27] [all] Reorganize haskell code into multiple packages --- .gitignore | 1 - CHANGELOG.md | 2 +- Setup.hs | 2 - forest-cabin/README.md | 1 + {server => forest-cabin/app}/Main.hs | 0 forest-cabin/forest-cabin.cabal | 52 +++++++++++++ forest-cabin/package.yaml | 32 ++++++++ forest-common/README.md | 1 + forest-common/forest-common.cabal | 44 +++++++++++ forest-common/package.yaml | 23 ++++++ {src => forest-common/src}/Forest/Api.hs | 0 {src => forest-common/src}/Forest/Node.hs | 0 .../src}/Forest/OrderedMap.hs | 0 {src => forest-common/src}/Forest/Util.hs | 21 ++++-- forest-server/README.md | 1 + forest-server/forest-server.cabal | 47 ++++++++++++ forest-server/package.yaml | 23 ++++++ {src => forest-server/src}/Forest/Server.hs | 2 +- .../src}/Forest/Server/Broadcast.hs | 0 .../src}/Forest/Server/TreeModule.hs | 0 .../src}/Forest/Server/TreeModule/Animate.hs | 0 .../src}/Forest/Server/TreeModule/Const.hs | 0 .../src}/Forest/Server/TreeModule/Fork.hs | 0 .../Forest/Server/TreeModule/SharedEditing.hs | 0 forest-tui/README.md | 1 + {client => forest-tui/app}/Main.hs | 0 forest-tui/forest-tui.cabal | 74 +++++++++++++++++++ forest-tui/package.yaml | 39 ++++++++++ {src => forest-tui/src}/Forest/Client.hs | 6 +- .../src}/Forest/Client/NodeUtil.hs | 0 .../src}/Forest/Client/Options.hs | 0 .../src}/Forest/Client/UiState.hs | 12 +-- .../src}/Forest/Client/Websocket.hs | 0 .../src/Forest/Client/Widgets}/NodeEditor.hs | 2 +- .../src/Forest/Client/Widgets}/WidgetTree.hs | 2 +- package.yaml | 52 ------------- stack.yaml | 68 +---------------- 37 files changed, 368 insertions(+), 140 deletions(-) delete mode 100644 Setup.hs create mode 100644 forest-cabin/README.md rename {server => forest-cabin/app}/Main.hs (100%) create mode 100644 forest-cabin/forest-cabin.cabal create mode 100644 forest-cabin/package.yaml create mode 100644 forest-common/README.md create mode 100644 forest-common/forest-common.cabal create mode 100644 forest-common/package.yaml rename {src => forest-common/src}/Forest/Api.hs (100%) rename {src => forest-common/src}/Forest/Node.hs (100%) rename {src => forest-common/src}/Forest/OrderedMap.hs (100%) rename {src => forest-common/src}/Forest/Util.hs (88%) create mode 100644 forest-server/README.md create mode 100644 forest-server/forest-server.cabal create mode 100644 forest-server/package.yaml rename {src => forest-server/src}/Forest/Server.hs (98%) rename {src => forest-server/src}/Forest/Server/Broadcast.hs (100%) rename {src => forest-server/src}/Forest/Server/TreeModule.hs (100%) rename {src => forest-server/src}/Forest/Server/TreeModule/Animate.hs (100%) rename {src => forest-server/src}/Forest/Server/TreeModule/Const.hs (100%) rename {src => forest-server/src}/Forest/Server/TreeModule/Fork.hs (100%) rename {src => forest-server/src}/Forest/Server/TreeModule/SharedEditing.hs (100%) create mode 100644 forest-tui/README.md rename {client => forest-tui/app}/Main.hs (100%) create mode 100644 forest-tui/forest-tui.cabal create mode 100644 forest-tui/package.yaml rename {src => forest-tui/src}/Forest/Client.hs (96%) rename {src => forest-tui/src}/Forest/Client/NodeUtil.hs (100%) rename {src => forest-tui/src}/Forest/Client/Options.hs (100%) rename {src => forest-tui/src}/Forest/Client/UiState.hs (96%) rename {src => forest-tui/src}/Forest/Client/Websocket.hs (100%) rename {src/Forest/Client => forest-tui/src/Forest/Client/Widgets}/NodeEditor.hs (97%) rename {src/Forest/Client => forest-tui/src/Forest/Client/Widgets}/WidgetTree.hs (99%) delete mode 100644 package.yaml diff --git a/.gitignore b/.gitignore index a5c3e0f..76467e6 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,2 @@ .stack-work/ -forest.cabal *~ diff --git a/CHANGELOG.md b/CHANGELOG.md index 8afd99e..2447cb3 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,4 @@ # Changelog for forest ## upcoming -* create project +- create project diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 index 9a994af..0000000 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/forest-cabin/README.md b/forest-cabin/README.md new file mode 100644 index 0000000..403023d --- /dev/null +++ b/forest-cabin/README.md @@ -0,0 +1 @@ +# forest-cabin diff --git a/server/Main.hs b/forest-cabin/app/Main.hs similarity index 100% rename from server/Main.hs rename to forest-cabin/app/Main.hs diff --git a/forest-cabin/forest-cabin.cabal b/forest-cabin/forest-cabin.cabal new file mode 100644 index 0000000..3c0b54a --- /dev/null +++ b/forest-cabin/forest-cabin.cabal @@ -0,0 +1,52 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: c619b22393d818639b183c69031b267a4ed16faeaf609a75ef1cadb9288195e1 + +name: forest-cabin +version: 0.1.0.0 +synopsis: A forest server hosted at forest.plugh.de +description: Please see the README at +homepage: https://github.com/Garmelon/forest#readme +bug-reports: https://github.com/Garmelon/forest/issues +author: Garmelon +maintainer: Garmelon +copyright: 2020 Garmelon +license: MIT +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/Garmelon/forest + +library + other-modules: + Paths_forest_cabin + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , forest-common + , forest-server + , websockets + default-language: Haskell2010 + +executable forest-cabin + main-is: Main.hs + other-modules: + Paths_forest_cabin + hs-source-dirs: + app + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , forest-cabin + , forest-common + , forest-server + , websockets + default-language: Haskell2010 diff --git a/forest-cabin/package.yaml b/forest-cabin/package.yaml new file mode 100644 index 0000000..4bfa1c6 --- /dev/null +++ b/forest-cabin/package.yaml @@ -0,0 +1,32 @@ +name: forest-cabin +version: 0.1.0.0 +license: MIT +author: Garmelon +copyright: 2020 Garmelon + +synopsis: A forest server hosted at forest.plugh.de +description: Please see the README at +github: Garmelon/forest + +extra-source-files: + - README.md + +dependencies: + - base >= 4.7 && < 5 + - forest-common + - forest-server + - websockets + +library: + source-dirs: src + +executables: + forest-cabin: + source-dirs: app + main: Main.hs + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - forest-cabin diff --git a/forest-common/README.md b/forest-common/README.md new file mode 100644 index 0000000..1f158f6 --- /dev/null +++ b/forest-common/README.md @@ -0,0 +1 @@ +# forest-common diff --git a/forest-common/forest-common.cabal b/forest-common/forest-common.cabal new file mode 100644 index 0000000..b888552 --- /dev/null +++ b/forest-common/forest-common.cabal @@ -0,0 +1,44 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: e59723e563cf364a74b1032409ed7a9d3ecbec3a6baa34554771cb5c1a5689d9 + +name: forest-common +version: 0.1.0.0 +synopsis: A tree-based multi-user interaction thing +description: Please see the README at +homepage: https://github.com/Garmelon/forest#readme +bug-reports: https://github.com/Garmelon/forest/issues +author: Garmelon +maintainer: Garmelon +copyright: 2020 Garmelon +license: MIT +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/Garmelon/forest + +library + exposed-modules: + Forest.Api + Forest.Node + Forest.OrderedMap + Forest.Util + other-modules: + Paths_forest_common + hs-source-dirs: + src + build-depends: + aeson + , async + , base >=4.7 && <5 + , containers + , text + , websockets + default-language: Haskell2010 diff --git a/forest-common/package.yaml b/forest-common/package.yaml new file mode 100644 index 0000000..cc74cc9 --- /dev/null +++ b/forest-common/package.yaml @@ -0,0 +1,23 @@ +name: forest-common +version: 0.1.0.0 +license: MIT +author: Garmelon +copyright: 2020 Garmelon + +synopsis: A tree-based multi-user interaction thing +description: Please see the README at +github: Garmelon/forest + +extra-source-files: + - README.md + +dependencies: + - base >= 4.7 && < 5 + - aeson + - async + - containers + - text + - websockets + +library: + source-dirs: src diff --git a/src/Forest/Api.hs b/forest-common/src/Forest/Api.hs similarity index 100% rename from src/Forest/Api.hs rename to forest-common/src/Forest/Api.hs diff --git a/src/Forest/Node.hs b/forest-common/src/Forest/Node.hs similarity index 100% rename from src/Forest/Node.hs rename to forest-common/src/Forest/Node.hs diff --git a/src/Forest/OrderedMap.hs b/forest-common/src/Forest/OrderedMap.hs similarity index 100% rename from src/Forest/OrderedMap.hs rename to forest-common/src/Forest/OrderedMap.hs diff --git a/src/Forest/Util.hs b/forest-common/src/Forest/Util.hs similarity index 88% rename from src/Forest/Util.hs rename to forest-common/src/Forest/Util.hs index b92ca77..68cad73 100644 --- a/src/Forest/Util.hs +++ b/forest-common/src/Forest/Util.hs @@ -1,11 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} module Forest.Util - ( findPrev + ( + -- * List operations + findPrev , findNext + -- * Monadic looping constructs , whileM - , runUntilJustM + , whileNothingM + -- * Multithreading helpers , withThread + -- * Websocket helper functions , sendPacket , closeWithErrorMessage , receivePacket @@ -24,9 +29,6 @@ findPrev f as = fst <$> find (f . snd) (zip as $ tail as) findNext :: (a -> Bool) -> [a] -> Maybe a findNext f as = snd <$> find (f . fst) (zip as $ tail as) -withThread :: IO () -> IO () -> IO () -withThread thread main = withAsync thread $ const main - -- | Run a monadic action until it returns @False@ for the first time. whileM :: Monad m => m Bool -> m () whileM f = do @@ -36,13 +38,16 @@ whileM f = do else pure () -- | Run a monadic action until it returns @Just a@ for the first time. -runUntilJustM :: Monad m => m (Maybe a) -> m a -runUntilJustM f = do +whileNothingM :: Monad m => m (Maybe a) -> m a +whileNothingM f = do result <- f case result of - Nothing -> runUntilJustM f + Nothing -> whileNothingM f Just a -> pure a +withThread :: IO () -> IO () -> IO () +withThread thread main = withAsync thread $ const main + sendPacket :: ToJSON a => WS.Connection -> a -> IO () sendPacket conn packet = WS.sendTextData conn $ encode packet diff --git a/forest-server/README.md b/forest-server/README.md new file mode 100644 index 0000000..b13ad16 --- /dev/null +++ b/forest-server/README.md @@ -0,0 +1 @@ +# forest-server diff --git a/forest-server/forest-server.cabal b/forest-server/forest-server.cabal new file mode 100644 index 0000000..1e6e2f8 --- /dev/null +++ b/forest-server/forest-server.cabal @@ -0,0 +1,47 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: c0d366de2ff27f13dd69d751b47017143df332454ad700dd8fb5089d9837f1a8 + +name: forest-server +version: 0.1.0.0 +synopsis: A framework for forest servers +description: Please see the README at +homepage: https://github.com/Garmelon/forest#readme +bug-reports: https://github.com/Garmelon/forest/issues +author: Garmelon +maintainer: Garmelon +copyright: 2020 Garmelon +license: MIT +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/Garmelon/forest + +library + exposed-modules: + Forest.Server + Forest.Server.Broadcast + Forest.Server.TreeModule + Forest.Server.TreeModule.Animate + Forest.Server.TreeModule.Const + Forest.Server.TreeModule.Fork + Forest.Server.TreeModule.SharedEditing + other-modules: + Paths_forest_server + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , containers + , forest-common + , text + , transformers + , websockets + default-language: Haskell2010 diff --git a/forest-server/package.yaml b/forest-server/package.yaml new file mode 100644 index 0000000..ad01b10 --- /dev/null +++ b/forest-server/package.yaml @@ -0,0 +1,23 @@ +name: forest-server +version: 0.1.0.0 +license: MIT +author: Garmelon +copyright: 2020 Garmelon + +synopsis: A framework for forest servers +description: Please see the README at +github: Garmelon/forest + +extra-source-files: + - README.md + +dependencies: + - base >= 4.7 && < 5 + - containers + - forest-common + - text + - transformers + - websockets + +library: + source-dirs: src diff --git a/src/Forest/Server.hs b/forest-server/src/Forest/Server.hs similarity index 98% rename from src/Forest/Server.hs rename to forest-server/src/Forest/Server.hs index cda6b93..7a665a6 100644 --- a/src/Forest/Server.hs +++ b/forest-server/src/Forest/Server.hs @@ -32,7 +32,7 @@ sendUpdatesThread conn nodeChan nodeA = do {- Main server application that receives and processes client packets -} receivePackets :: TreeModule a () => WS.Connection -> a () -> IO () -receivePackets conn treeModule = runUntilJustM $ do +receivePackets conn treeModule = whileNothingM $ do packet <- receivePacket conn case packet of ClientEdit path text -> do diff --git a/src/Forest/Server/Broadcast.hs b/forest-server/src/Forest/Server/Broadcast.hs similarity index 100% rename from src/Forest/Server/Broadcast.hs rename to forest-server/src/Forest/Server/Broadcast.hs diff --git a/src/Forest/Server/TreeModule.hs b/forest-server/src/Forest/Server/TreeModule.hs similarity index 100% rename from src/Forest/Server/TreeModule.hs rename to forest-server/src/Forest/Server/TreeModule.hs diff --git a/src/Forest/Server/TreeModule/Animate.hs b/forest-server/src/Forest/Server/TreeModule/Animate.hs similarity index 100% rename from src/Forest/Server/TreeModule/Animate.hs rename to forest-server/src/Forest/Server/TreeModule/Animate.hs diff --git a/src/Forest/Server/TreeModule/Const.hs b/forest-server/src/Forest/Server/TreeModule/Const.hs similarity index 100% rename from src/Forest/Server/TreeModule/Const.hs rename to forest-server/src/Forest/Server/TreeModule/Const.hs diff --git a/src/Forest/Server/TreeModule/Fork.hs b/forest-server/src/Forest/Server/TreeModule/Fork.hs similarity index 100% rename from src/Forest/Server/TreeModule/Fork.hs rename to forest-server/src/Forest/Server/TreeModule/Fork.hs diff --git a/src/Forest/Server/TreeModule/SharedEditing.hs b/forest-server/src/Forest/Server/TreeModule/SharedEditing.hs similarity index 100% rename from src/Forest/Server/TreeModule/SharedEditing.hs rename to forest-server/src/Forest/Server/TreeModule/SharedEditing.hs diff --git a/forest-tui/README.md b/forest-tui/README.md new file mode 100644 index 0000000..244c893 --- /dev/null +++ b/forest-tui/README.md @@ -0,0 +1 @@ +# forest-tui diff --git a/client/Main.hs b/forest-tui/app/Main.hs similarity index 100% rename from client/Main.hs rename to forest-tui/app/Main.hs diff --git a/forest-tui/forest-tui.cabal b/forest-tui/forest-tui.cabal new file mode 100644 index 0000000..5cae330 --- /dev/null +++ b/forest-tui/forest-tui.cabal @@ -0,0 +1,74 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 9ca3a1fe555e2dceb3459b6ae920b1ed93aac76398d4909a7030d7992b79ce40 + +name: forest-tui +version: 0.1.0.0 +synopsis: A terminal-based client for forest +description: Please see the README at +homepage: https://github.com/Garmelon/forest#readme +bug-reports: https://github.com/Garmelon/forest/issues +author: Garmelon +maintainer: Garmelon +copyright: 2020 Garmelon +license: MIT +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/Garmelon/forest + +library + exposed-modules: + Forest.Client + Forest.Client.NodeUtil + Forest.Client.Options + Forest.Client.UiState + Forest.Client.Websocket + Forest.Client.Widgets.NodeEditor + Forest.Client.Widgets.WidgetTree + other-modules: + Paths_forest_tui + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , brick + , containers + , forest-common + , optparse-applicative + , safe + , text + , text-zipper + , vty + , websockets + , wuss + default-language: Haskell2010 + +executable forest + main-is: Main.hs + other-modules: + Paths_forest_tui + hs-source-dirs: + app + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , brick + , containers + , forest-common + , forest-tui + , optparse-applicative + , safe + , text + , text-zipper + , vty + , websockets + , wuss + default-language: Haskell2010 diff --git a/forest-tui/package.yaml b/forest-tui/package.yaml new file mode 100644 index 0000000..12f71d9 --- /dev/null +++ b/forest-tui/package.yaml @@ -0,0 +1,39 @@ +name: forest-tui +version: 0.1.0.0 +license: MIT +author: Garmelon +copyright: 2020 Garmelon + +synopsis: A terminal-based client for forest +description: Please see the README at +github: Garmelon/forest + +extra-source-files: + - README.md + +dependencies: + - base >= 4.7 && < 5 + - brick + - containers + - forest-common + - optparse-applicative + - safe + - text + - text-zipper + - vty + - websockets + - wuss + +library: + source-dirs: src + +executables: + forest: + source-dirs: app + main: Main.hs + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - forest-tui diff --git a/src/Forest/Client.hs b/forest-tui/src/Forest/Client.hs similarity index 96% rename from src/Forest/Client.hs rename to forest-tui/src/Forest/Client.hs index 871bc66..c621828 100644 --- a/src/Forest/Client.hs +++ b/forest-tui/src/Forest/Client.hs @@ -11,13 +11,13 @@ 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 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.Client.Widgets.WidgetTree import Forest.Node import Forest.Util diff --git a/src/Forest/Client/NodeUtil.hs b/forest-tui/src/Forest/Client/NodeUtil.hs similarity index 100% rename from src/Forest/Client/NodeUtil.hs rename to forest-tui/src/Forest/Client/NodeUtil.hs diff --git a/src/Forest/Client/Options.hs b/forest-tui/src/Forest/Client/Options.hs similarity index 100% rename from src/Forest/Client/Options.hs rename to forest-tui/src/Forest/Client/Options.hs diff --git a/src/Forest/Client/UiState.hs b/forest-tui/src/Forest/Client/UiState.hs similarity index 96% rename from src/Forest/Client/UiState.hs rename to forest-tui/src/Forest/Client/UiState.hs index 000f846..d6dff76 100644 --- a/src/Forest/Client/UiState.hs +++ b/forest-tui/src/Forest/Client/UiState.hs @@ -35,16 +35,16 @@ module Forest.Client.UiState import Brick import Data.List import Data.Maybe -import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Graphics.Vty as Vty +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.Client.Widgets.NodeEditor +import Forest.Client.Widgets.WidgetTree import Forest.Node -import qualified Forest.OrderedMap as OMap +import qualified Forest.OrderedMap as OMap data EditorInfo n = EditorInfo { eiEditor :: !(NodeEditor n) diff --git a/src/Forest/Client/Websocket.hs b/forest-tui/src/Forest/Client/Websocket.hs similarity index 100% rename from src/Forest/Client/Websocket.hs rename to forest-tui/src/Forest/Client/Websocket.hs diff --git a/src/Forest/Client/NodeEditor.hs b/forest-tui/src/Forest/Client/Widgets/NodeEditor.hs similarity index 97% rename from src/Forest/Client/NodeEditor.hs rename to forest-tui/src/Forest/Client/Widgets/NodeEditor.hs index 261ac4c..51e8e86 100644 --- a/src/Forest/Client/NodeEditor.hs +++ b/forest-tui/src/Forest/Client/Widgets/NodeEditor.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Forest.Client.NodeEditor +module Forest.Client.Widgets.NodeEditor ( NodeEditor , getCurrentText , beginEdit diff --git a/src/Forest/Client/WidgetTree.hs b/forest-tui/src/Forest/Client/Widgets/WidgetTree.hs similarity index 99% rename from src/Forest/Client/WidgetTree.hs rename to forest-tui/src/Forest/Client/Widgets/WidgetTree.hs index ded6f23..17cd0ce 100644 --- a/src/Forest/Client/WidgetTree.hs +++ b/forest-tui/src/Forest/Client/Widgets/WidgetTree.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Forest.Client.WidgetTree +module Forest.Client.Widgets.WidgetTree ( WidgetTree(..) , renderWidgetTreeWith , renderWidgetTree diff --git a/package.yaml b/package.yaml deleted file mode 100644 index 4d171c7..0000000 --- a/package.yaml +++ /dev/null @@ -1,52 +0,0 @@ -name: forest -version: 0.1.0.0 -license: MIT -author: "Garmelon " -copyright: "2020 Garmelon" - -synopsis: A tree-based multi-user interaction thing -description: Please see the README on GitHub at -github: "Garmelon/forest" - -extra-source-files: -- README.md -- CHANGELOG.md - -dependencies: -- base >= 4.7 && < 5 -- aeson -- async -- brick -- containers -- optparse-applicative -- safe -- text -- text-zipper -- transformers -- vty -- websockets -- wuss - -library: - source-dirs: src - -executables: - forest-server: - main: Main.hs - source-dirs: server - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - forest - - forest-client: - main: Main.hs - source-dirs: client - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - forest diff --git a/stack.yaml b/stack.yaml index 465f104..4690758 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,66 +1,6 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# -# The location of a snapshot can be provided as a file or url. Stack assumes -# a snapshot provided as a file might change, whereas a url resource does not. -# -# resolver: ./custom-snapshot.yaml -# resolver: https://example.com/snapshots/2018-01-01.yaml resolver: lts-15.1 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# subdirs: -# - auto-update -# - wai packages: -- . -# Dependency packages to be pulled from upstream that are not in the resolver. -# These entries can reference officially published versions as well as -# forks / in-progress versions pinned to a git hash. For example: -# -# extra-deps: -# - acme-missiles-0.3 -# - git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# -# extra-deps: [] - -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=2.1" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor + - forest-cabin + - forest-common + - forest-server + - forest-tui From f8fd5b3c3e0b70f9b6153d55840d5fe5fc45b668 Mon Sep 17 00:00:00 2001 From: Joscha Date: Sat, 14 Mar 2020 01:05:33 +0000 Subject: [PATCH 11/27] [web] Move web client to this repo --- forest-web/about.html | 67 ++++++ forest-web/init.html | 39 ++++ forest-web/main.css | 76 +++++++ forest-web/node.css | 71 ++++++ forest-web/node.js | 469 ++++++++++++++++++++++++++++++++++++++++ forest-web/settings.css | 16 ++ forest-web/settings.js | 35 +++ 7 files changed, 773 insertions(+) create mode 100644 forest-web/about.html create mode 100644 forest-web/init.html create mode 100644 forest-web/main.css create mode 100644 forest-web/node.css create mode 100644 forest-web/node.js create mode 100644 forest-web/settings.css create mode 100644 forest-web/settings.js diff --git a/forest-web/about.html b/forest-web/about.html new file mode 100644 index 0000000..704d4f0 --- /dev/null +++ b/forest-web/about.html @@ -0,0 +1,67 @@ + + + + + Forest - About + + + +
+ +

Forest

+

Description

+

+ Forest is a project based around interacting with trees of + plain-text nodes. It has an API that is intentionally kept + simple. Writing your own clients or bots is explicitly + encouraged! +

+

+ At the moment, there are a server and a terminal-based client + written in haskell, and the web-based client you're using right + now, made with (vanilla) javascript. The web-based client is + heavily based on the terminal-based client, both in look and + behaviour. The color scheme is just my terminal's current color + scheme. +

+ +

Code and docs

+
    +
  1. Server and terminal-based client
    2. +
  2. Web-based client (coming soon)
    3. +
  3. API documentation
    4. +
+ +

Usage

+

Controls

+ 
+tab           - fold/unfold current node
+arrow keys/jk - move cursor
+
+

Permissions

+

+ A node's permissions are displayed at the right side of the + screen, like this: + (edra). + If a permission is set, its character is displayed. Otherwise, a + dash is displayed in its place. Only when a permission is set + can its action be performed. +

+ 
+e (edit)   - edit a node's text
+d (delete) - delete a node
+r (reply)  - reply to a node
+a (act)    - perform a node-specific action
+
+

Colors

+

+ The cursor position is marked by a + blue background. + If a node is colored + yellow, + it has child nodes. +

+ +
+ + diff --git a/forest-web/init.html b/forest-web/init.html new file mode 100644 index 0000000..1cde6ea --- /dev/null +++ b/forest-web/init.html @@ -0,0 +1,39 @@ + + + + + Forest + + + + + + + + +
+
+
+ Please enable javascript. + (----) +
+
+
+
+ +
+ +
+
+ + +
+
+
+ +
+ About +
+ + + diff --git a/forest-web/main.css b/forest-web/main.css new file mode 100644 index 0000000..dd992a8 --- /dev/null +++ b/forest-web/main.css @@ -0,0 +1,76 @@ +html { + /* My terminal's color scheme */ + --background: #000000; + --foreground: #babdb6; + --black: #2e3436; + --bright-black: #555753; + --red: #cc0000; + --bright-red: #ef2929; + --green: #4e9a06; + --bright-green: #8ae234; + --yellow: #c4a000; + --bright-yellow: #fce94f; + --blue: #3465a4; + --bright-blue: #729fcf; + --magenta: #75507b; + --bright-magenta: #ad7fa8; + --cyan: #06989a; + --bright-cyan: #34e2e2; + --white: #d3d7cf; + --bright-white: #eeeeec; + + font-family: monospace; + font-size: 16px; + color: var(--foreground); + background-color: var(--background); +} +body { + max-width: 1024px; + margin: 0 auto; + padding: 2em; +} +h1, h2, h3, h4, h5, h6 { + color: var(--white); + margin-top: 1.5em; +} +h1 { + margin-top: 0; + font-size: 2em; +} +h2 { + text-decoration: underline; +} +a { + color: var(--bright-blue); +} +a:visited { + color: var(--bright-magenta); +} +/* Input elements */ +input[type="checkbox"] { + display: none; +} +input[type="checkbox"] + label::before { + content: "[_] "; + font-weight: bold; +} +input[type="checkbox"]:checked + label::before { + content: "[X] "; +} +button, textarea { + font-family: inherit; + font-size: inherit; + color: inherit; + background-color: inherit; + margin: 0; + padding: 0; + border: none; + outline: none; +} +button { + font-weight: bold; +} +textarea { + color: var(--foreground); + background-color: var(--bright-black); +} diff --git a/forest-web/node.css b/forest-web/node.css new file mode 100644 index 0000000..e02c175 --- /dev/null +++ b/forest-web/node.css @@ -0,0 +1,71 @@ +.node-line { + display: flex; +} +.node-text { + flex-grow: 1; +} +.node-permissions { + color: var(--bright-black); + margin-left: 1ch; +} +.node textarea { + width: 100%; + resize: none; +} + +/* Special display states a node can be in */ +.has-children > .node-line > .node-text { + font-weight: bold; + color: var(--yellow); +} +.has-cursor > .node-line > .node-text { + background-color: var(--blue); +} +.has-editor > .node-line { + display: none; +} +.is-folded > .node-children { + display: none; +} + +/* Fancy tree lines */ +.node, .node::before { + border-color: var(--bright-black); + border-width: 2px; +} +.node-children > .node { + position: relative; /* .node is containing block for its .node::before */ + margin-left: calc(0.5ch - 1px); + padding-left: calc(1.5ch - 1px); + border-left-style: solid; +} +.node-children > .node:last-child { + padding-left: calc(1.5ch + 1px); + border-left-style: none; +} +.node-children > .node::before { + content: ""; + position: absolute; + left: 0; + top: 0; + width: calc(1ch - 1px); + height: calc(0.6em - 1px); + border-bottom-style: solid; +} +.node-children > .node:last-child::before { + border-left-style: solid; + transition: all 0.4s; +} + +/* Curvy lines */ +.curvy .node:last-child::before { + border-bottom-left-radius: 6px; +} + +/* About link in bottom right corner */ +#about { + position: fixed; + bottom: 0; + right: 0; + margin: 1ch; +} diff --git a/forest-web/node.js b/forest-web/node.js new file mode 100644 index 0000000..33e722c --- /dev/null +++ b/forest-web/node.js @@ -0,0 +1,469 @@ +"use strict"; + +/* + * Utility functions + */ + +// Create a new DOM element. +// 'classes' can either be a string or a list of strings. +// A child can either be a string or a DOM element. +function newElement(type, classes, ...children) { + let e = document.createElement(type); + + if (classes !== undefined) { + if (typeof classes == "string") { + e.classList.add(classes); + } else if (classes instanceof Array) { + e.classList.add(...classes); + } + } + + children.forEach(child => { + if (typeof child == "string") { + e.appendChild(document.createTextNode(child)); + } else { + e.appendChild(child); + } + }); + + return e; +} + +/* + * Classes + */ + +// Enum representing useful positions relative to a node. +const RelPos = Object.freeze({ + FIRST_CHILD: 1, + NEXT_SIBLING: 2, +}); + +class Path { + constructor(...nodeIds) { + this.elements = nodeIds; + } + + get length() { + return this.elements.length; + } + + get last() { + return this.elements[this.length - 1]; + } + + get parent() { + if (this.length === 0) return undefined; + return new Path(...this.elements.slice(0, this.length - 1)); + } + + append(nodeId) { + return new Path(...this.elements.concat([nodeId])); + } + + concat(otherPath) { + return new Path(...this.elements.concat(otherPath.elements)); + } +} + +class NodeElements { + constructor() { + this.text = newElement("span", "node-text"); + this.permissions = newElement("span", "node-permissions"); + this.children = newElement("div", "node-children"); + + let line = newElement("div", "node-line", this.text, this.permissions); + this.main = newElement("div", ["node", "is-folded"], line, this.children); + } + + removeAllChildren() { + while (this.children.firstChild) { + this.children.removeChild(this.children.lastChild); + } + } +} + +class Node { + constructor(nodeJson) { + this.elements = undefined; + + this.text = nodeJson.text; + + // Permissions + this.edit = nodeJson.edit; + this.delete = nodeJson.delete; + this.reply = nodeJson.reply; + this.act = nodeJson.act; + + this.children = new Map(); + this.order = nodeJson.order; + this.order.forEach(childId => { + let childJson = nodeJson.children[childId]; + let childNode = new Node(childJson); + this.children.set(childId, childNode); + }); + } + + getPermissionText() { + return [ + "(", + this.edit ? "e" : "-", + this.delete ? "d" : "-", + this.reply ? "r" : "-", + this.act ? "a" : "-", + ")" + ].join(""); + } + + hasChildren() { + return this.order.length > 0; + } + + isFolded() { + if (this.elements === undefined) return undefined; + return this.elements.main.classList.contains("is-folded"); + } + + setFolded(folded) { + if (this.elements === undefined) return; + this.elements.main.classList.toggle("is-folded", folded); + } + + toggleFolded() { + this.setFolded(!this.isFolded()); + } + + // Obtain and update this node's DOM elements. After this call, this.el + // represents the current node's contents. + // + // This function may optionally be called with an old node. If that node or + // its children already has existing DOM elements, they are repurposed. + // Otherwise, new DOM elements are created. + obtainElements(oldNode) { + if (this.elements === undefined) { + // Obtain DOM elements because we don't yet have any + if (oldNode === undefined || oldNode.elements === undefined) { + this.elements = new NodeElements(); + } else { + this.elements = oldNode.elements; + } + } + + this.elements.text.textContent = this.text; + this.elements.permissions.textContent = this.getPermissionText(); + this.elements.main.classList.toggle("has-children", this.hasChildren()); + + let oldChildren = (oldNode === undefined) ? + new Map() : oldNode.children; + + this.elements.removeAllChildren(); + this.order.forEach(childId => { + let oldChild = oldChildren.get(childId); // May be undefined + let child = this.children.get(childId); + child.obtainElements(oldChild); + this.elements.children.appendChild(child.elements.main); + }); + } +} + +class NodeTree { + constructor(rootNodeContainer, rootNode) { + this.rootNodeContainer = rootNodeContainer; + this.rootNode = rootNode; + + // Prepare root node container + rootNode.obtainElements(); + while (rootNodeContainer.firstChild) { + rootNodeContainer.removeChild(rootNodeContainer.lastChild); + } + rootNodeContainer.appendChild(rootNode.elements.main); + } + + at(path) { + let node = this.rootNode; + for (let childId of path.elements) { + node = node.children.get(childId); + if (node === undefined) break; + } + return node; + } + + updateAt(path, newNode) { + if (path.length === 0) { + newNode.obtainElements(this.rootNode); + this.rootNode = newNode; + } else { + let parentNode = this.at(path.parent); + let oldNode = parentNode.children.get(path.last); + if (oldNode === undefined) return; + newNode.obtainElements(oldNode); + parentNode.children.set(path.last, newNode); + } + } + + getChildWith(path, f) { + let node = this.at(path); + if (node === undefined) return undefined; + let index = f(node.order.length); + if (index === undefined) return undefined; + let childId = node.order[index]; + if (childId === undefined) return undefined; + return path.append(childId); + } + + getFirstChild(path) { + return this.getChildWith(path, l => 0); + } + + getLastChild(path) { + return this.getChildWith(path, l => l - 1); + } + + getSiblingWith(path, f) { + if (path.parent === undefined) return undefined; + let parentNode = this.at(path.parent); + if (parentNode === undefined) return undefined; + + let index = parentNode.order.indexOf(path.last); + if (index === undefined) return undefined; + let newIndex = f(index); + if (newIndex === undefined) return undefined; + let siblingId = parentNode.order[newIndex]; + if (siblingId === undefined) return undefined; + + return path.parent.append(siblingId); + } + + getPrevSibling(path) { + return this.getSiblingWith(path, i => i - 1); + } + + getNextSibling(path) { + return this.getSiblingWith(path, i => i + 1); + } + + getNodeAbove(path) { + let prevPath = this.getPrevSibling(path); + if (prevPath === undefined) return path.parent; + + // Get last child of previous path + while (true) { + let prevNode = this.at(prevPath); + if (prevNode.isFolded()) return prevPath; + + let childPath = this.getLastChild(prevPath); + if (childPath === undefined) return prevPath; + + prevPath = childPath; + } + } + + getNodeBelow(path) { + let node = this.at(path); + if (!node.isFolded()) { + let childPath = this.getFirstChild(path); + if (childPath !== undefined) return childPath; + } + + while (path !== undefined) { + let nextPath = this.getNextSibling(path); + if (nextPath !== undefined) return nextPath; + path = path.parent; + } + + return undefined; + } +} + +class Cursor { + constructor(nodeTree) { + this.nodeTree = nodeTree; + + this.path = new Path(); + this.relPos = null; // Either null or a RelPos value + + this.restore(); + } + + getSelectedNode() { + return this.nodeTree.at(this.path); + } + + _applyRelPos() { + if (this.relPos === null) return; + + let newPath; + if (this.relPos === RelPos.FIRST_CHILD) { + newPath = this.nodeTree.getFirstChild(this.path); + } else if (this.relPos === RelPos.NEXT_SIBLING) { + newPath = this.nodeTree.getNextSibling(this.path); + } + + if (newPath !== undefined) { + this.path = newPath; + this.relPos = null; + } + } + + _moveToNearestValidNode() { + // TODO Maybe select a sibling instead of going to nearest visible parent + let path = new Path(); + for (let element of this.path.elements) { + let newPath = path.append(element); + let newNode = this.nodeTree.at(newPath); + if (newNode === undefined) break; + if (newNode.isFolded()) break; + path = newPath; + } + this.path = path; + } + + _set(visible) { + this.getSelectedNode().elements.main.classList.toggle("has-cursor", visible); + } + + restore() { + this._applyRelPos(); + this._moveToNearestValidNode(); + this._set(true); + } + + moveTo(path) { + if (path === undefined) return; + this._set(false); + this.path = path; + this._set(true); + } + + moveUp() { + this.moveTo(this.nodeTree.getNodeAbove(this.path)); + } + + moveDown() { + this.moveTo(this.nodeTree.getNodeBelow(this.path)); + } +} + +class Editor { + constructor(nodeTree) { + this.nodeTree = nodeTree; + + this.textarea = newElement("textarea"); + this.textarea.addEventListener("input", event => this._updateTextAreaHeight()); + + this.path = undefined; + this.asChild = false; + } + + _updateTextAreaHeight() { + this.textarea.style.height = 0; + this.textarea.style.height = this.textarea.scrollHeight + "px"; + } + + _getAttachedNode() { + if (this.path === undefined) return undefined; + return this.nodeTree.at(this.path); + } + + _detach(node, asChild) { + if (!asChild) { + node.elements.main.classList.remove("has-editor"); + } + + this.textarea.parentNode.removeChild(this.textarea); + } + + _attachTo(node, asChild) { + if (asChild) { + node.elements.children.appendChild(this.textarea); + } else { + node.elements.main.classList.add("has-editor"); + node.elements.main.insertBefore(this.textarea, node.elements.children); + } + this._updateTextAreaHeight(); + } + + restore() { + if (this.textarea.parentNode !== null) return; // Already attached + let node = this._getAttachedNode(); + if (node === undefined) return; // Nowhere to attach + this._attachTo(node, this.asChild); + } + + attachTo(path, asChild) { + this.detach(); + this.path = path; + this.asChild = asChild; + this.restore(); + + this.textarea.focus(); + let length = this.textarea.value.length; + this.textarea.setSelectionRange(length, length); + } + + detach() { + let node = this._getAttachedNode(); + if (node === undefined) return; + this._detach(node, this.asChild); + this.path = undefined; + } + + set content(text) { + this.textarea.value = text; + } + + get content() { + return this.textarea.value; + } +} + +/* + * The main application + */ + +const rootNodeContainer = document.getElementById("root-node-container"); +const loadingNode = new Node({text: "Connecting...", children: {}, order: []}); +const nodeTree = new NodeTree(rootNodeContainer, loadingNode); +const cursor = new Cursor(nodeTree); +const editor = new Editor(nodeTree); + +// TODO Replace this testing node with the real websocket code +const testNode = new Node({text: "Forest", children: [ + {text: "Test", children: [ + {text: "Bla", children: [], order: []}, + ], order: [0]}, + {text: "Sandbox", edit: true, delete: true, reply: true, act: true, children: [], order: []}, + {text: "About", children: [ + {text: "This project is an experiment in tree-based interaction.", children: [], order: []}, + {text: "Motivation", children: [], order: []}, + {text: "Inspirations", children: [], order: []}, + ], order: [0, 1, 2]} +], order: [0, 1, 2]}); +nodeTree.updateAt(new Path(), testNode); + +document.addEventListener("keydown", event => { + console.log(event); + if (event.code === "Escape") { + editor.detach(); + } else if (document.activeElement === editor.textarea) { + if (event.code === "Enter" && !event.shiftKey) { + editor.detach(); + } + } else if (document.activeElement.tagName === "TEXTAREA") { + return; // Do nothing special + } else if (event.code === "Tab") { + cursor.getSelectedNode().toggleFolded(); + event.preventDefault(); + } else if (event.code === "KeyK" || event.code === "ArrowUp") { + cursor.moveUp(); + event.preventDefault(); + } else if (event.code === "KeyJ" || event.code === "ArrowDown") { + cursor.moveDown(); + event.preventDefault(); + } else if (event.code === "KeyE") { + let node = cursor.getSelectedNode(); + editor.content = node.text; + editor.attachTo(cursor.path, false); + event.preventDefault(); + } +}); diff --git a/forest-web/settings.css b/forest-web/settings.css new file mode 100644 index 0000000..817bcab --- /dev/null +++ b/forest-web/settings.css @@ -0,0 +1,16 @@ +#settings { + position: fixed; + bottom: 0; + transition: all 0.2s ease-out; + transform: translateY(100%); +} +#settings a { + color: var(--white); +} +#settings > button, #settings > form { + padding: 1ch; + background-color: var(--magenta); +} +#settings > button { + font-weight: bold; +} diff --git a/forest-web/settings.js b/forest-web/settings.js new file mode 100644 index 0000000..2bcc331 --- /dev/null +++ b/forest-web/settings.js @@ -0,0 +1,35 @@ +"use strict"; + +const settingsDiv = document.getElementById("settings"); +const settingsButton = settingsDiv.querySelector("button"); +const settingsForm = settingsDiv.querySelector("form"); +let settingsMenuState; +settingsButton.addEventListener("click", event => setSettingsMenuState(!settingsMenuState)); +window.addEventListener("load", event => setSettingsMenuState(false)); + +function setSettingsMenuState(open) { + settingsMenuState = open; + if (open) { + settingsDiv.style.transform = "none"; + } else { + let height = settingsButton.offsetHeight; + settingsDiv.style.transform = `translateY(calc(100% - ${height}px))`; + } +} + +const curvyLinesCheckbox = document.getElementById("curvy-lines-checkbox"); +curvyLinesCheckbox.addEventListener("change", event => setCurvyLines(event.target.checked)); +window.addEventListener("load", event => { + let curvy = window.localStorage.getItem("curvy"); + curvyLinesCheckbox.checked = curvy; + setCurvyLines(curvy); +}); + +function setCurvyLines(curvy) { + document.body.classList.toggle("curvy", curvy); + if (curvy) { + window.localStorage.setItem("curvy", "yes"); + } else { + window.localStorage.removeItem("curvy"); + } +} From 56373a074890f14abf48f111ab72723e57ef57aa Mon Sep 17 00:00:00 2001 From: Joscha Date: Sat, 14 Mar 2020 01:08:18 +0000 Subject: [PATCH 12/27] [stack] Update resolver to lts-15.3 --- stack.yaml | 2 +- stack.yaml.lock | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/stack.yaml b/stack.yaml index 4690758..2c294b0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-15.1 +resolver: lts-15.3 packages: - forest-cabin - forest-common diff --git a/stack.yaml.lock b/stack.yaml.lock index 7e51098..eeb93a9 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,7 +6,7 @@ packages: [] snapshots: - completed: - size: 489011 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/1.yaml - sha256: d4ecc42b7125d68e4c3c036a08046ad0cd02ae0d9efbe3af2223a00ff8cc16f3 - original: lts-15.1 + size: 491373 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/3.yaml + sha256: 29e9ff61b8bf4b4fcff55cde3ac106ebb971f0d21331dccac9eee63374fa6ca8 + original: lts-15.3 From 04b8bd74450fe65ae69e7af89a4a08019b5ffb6a Mon Sep 17 00:00:00 2001 From: Joscha Date: Sat, 14 Mar 2020 01:47:41 +0000 Subject: [PATCH 13/27] [all] Include summary of subprojects in readme --- README.md | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index bcabaf8..6dbb792 100644 --- a/README.md +++ b/README.md @@ -1,5 +1,19 @@ # forest -Forest is an experiment in tree-based interaction. +Forest is an experiment in tree-based interaction: One or more clients connect +to a server and interact with it (and each other) via an interface consisting of +text-based nodes forming a tree. + +The project is split into multiple subprojects, most of which are Haskell +packages. For more information on individual subprojects, see their README or +the summary below. [API documentation](docs/API.md) + +## Subprojects + +- [forest-cabin](forest-cabin/): Server (Haskell) +- [forest-common](forest-common/): Common types and functions (Haskell) +- [forest-server](forest-server/): Server framework (Haskell) +- [forest-tui](forest-tui/): Terminal-based client (Haskell) +- [forest-web](forest-web/): Web-based client (static site) From cdfe515df6e4a825838ceddb7b6274760aef4d11 Mon Sep 17 00:00:00 2001 From: Joscha Date: Sun, 15 Mar 2020 00:59:18 +0000 Subject: [PATCH 14/27] [server] Add new structure for server applications --- forest-cabin/app/Main.hs | 26 ++--- forest-server/forest-server.cabal | 2 + forest-server/package.yaml | 1 + forest-server/src/Forest/Server/TreeApp.hs | 115 +++++++++++++++++++++ 4 files changed, 128 insertions(+), 16 deletions(-) create mode 100644 forest-server/src/Forest/Server/TreeApp.hs diff --git a/forest-cabin/app/Main.hs b/forest-cabin/app/Main.hs index 6a5eee8..6ced424 100644 --- a/forest-cabin/app/Main.hs +++ b/forest-cabin/app/Main.hs @@ -2,15 +2,10 @@ module Main where -import Control.Concurrent.MVar -import qualified Network.WebSockets as WS +import qualified Network.WebSockets as WS import Forest.Node -import Forest.Server -import Forest.Server.Broadcast -import Forest.Server.TreeModule.Const -import Forest.Server.TreeModule.Fork -import Forest.Server.TreeModule.SharedEditing +import Forest.Server.TreeApp pingDelay :: Int pingDelay = 10 @@ -23,15 +18,14 @@ options = WS.defaultServerOptions { WS.serverRequirePong = Just pongDelay } +app :: TreeApp Node () +app = TreeApp + { appGraft = id + , appHandleEvent = \s _ -> pure $ continue s + , appConstructor = simpleConstructor $ txtNode "" "Hello world" + } + main :: IO () main = do - putStrLn "Preparing shared edit module" - sharedEditNodeVar <- newMVar $ txtNode "r" "" - sharedEditBroadcaster <- newBroadcaster - putStrLn "Starting server" - WS.runServerWithOptions options $ serverApp pingDelay $ forkModule "Forest" - [ ProngConstructor "Test" $ constModule $ newNode "" "" [txtNode "" "Bla"] - , ProngConstructor "Sandbox" $ sharedEditingModule sharedEditNodeVar sharedEditBroadcaster - , ProngConstructor "About" $ constModule projectDescriptionNode - ] + WS.runServerWithOptions options $ runTreeApp pingDelay Nothing app diff --git a/forest-server/forest-server.cabal b/forest-server/forest-server.cabal index 1e6e2f8..4170bbb 100644 --- a/forest-server/forest-server.cabal +++ b/forest-server/forest-server.cabal @@ -28,6 +28,7 @@ library exposed-modules: Forest.Server Forest.Server.Broadcast + Forest.Server.TreeApp Forest.Server.TreeModule Forest.Server.TreeModule.Animate Forest.Server.TreeModule.Const @@ -41,6 +42,7 @@ library base >=4.7 && <5 , containers , forest-common + , stm , text , transformers , websockets diff --git a/forest-server/package.yaml b/forest-server/package.yaml index ad01b10..cb5c5f6 100644 --- a/forest-server/package.yaml +++ b/forest-server/package.yaml @@ -15,6 +15,7 @@ dependencies: - base >= 4.7 && < 5 - containers - forest-common + - stm - text - transformers - websockets diff --git a/forest-server/src/Forest/Server/TreeApp.hs b/forest-server/src/Forest/Server/TreeApp.hs new file mode 100644 index 0000000..88aafe8 --- /dev/null +++ b/forest-server/src/Forest/Server/TreeApp.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} + +-- | This module specifies a structure for forest server applications. It is +-- based on the way Brick models applications. + +module Forest.Server.TreeApp + ( Next + , continue + , halt + , Event(..) + , TreeApp(..) + , simpleConstructor + , runTreeApp + ) where + +import Control.Concurrent.STM +import Control.Monad +import Data.Function +import qualified Data.Text as T +import qualified Network.WebSockets as WS + +import Forest.Api +import Forest.Node +import Forest.Util + +data Next a = Continue a | Halt + +continue :: a -> Next a +continue = Continue + +halt :: Next a +halt = Halt + +data Event e + = Edit Path T.Text + | Delete Path + | Reply Path T.Text + | Act Path + | Custom e + +data TreeApp s e = TreeApp + { appGraft :: s -> Node + , appHandleEvent :: s -> Event e -> IO (Next s) + , appConstructor :: forall a. (s -> IO a) -> IO a + } + +simpleConstructor :: s -> (s -> IO a) -> IO a +simpleConstructor = (&) + +{- The websocket app receiving and sending the packets -} + +packetToEvent :: ClientPacket -> Maybe (Event e) +packetToEvent (ClientEdit path text) = Just $ Edit path text +packetToEvent (ClientDelete path) = Just $ Delete path +packetToEvent (ClientReply path text) = Just $ Reply path text +packetToEvent (ClientAct path) = Just $ Act path +packetToEvent (ClientHello _) = Nothing + +receiveThread :: WS.Connection -> TChan (Event e) -> IO () +receiveThread conn chan = forever $ do + packet <- receivePacket conn + case packetToEvent packet of + -- We can wrap a 'forever' around all of this because closeWithErrorMessage + -- throws a runtime exception once the connection is closed. + Nothing -> closeWithErrorMessage conn "Invalid packet: Hello" + Just event -> atomically $ writeTChan chan event + +data RunState s e = RunState + { rsEventChan :: TChan (Event e) + , rsCustomEventChan :: Maybe (TChan e) + , rsState :: s + , rsNode :: Node + } + +readEvent :: RunState s e -> STM (Event e) +readEvent rs = case rsCustomEventChan rs of + Nothing -> readTChan ec + Just cec -> readTChan ec `orElse` (Custom <$> readTChan cec) + where + ec = rsEventChan rs + +sendNodeUpdate :: WS.Connection -> Node -> Node -> IO () +sendNodeUpdate conn nodeOld nodeNew = case diffNodes nodeOld nodeNew of + Nothing -> putStrLn "Sending no update because the node didn't change" + Just (path, updatedNode) -> do + putStrLn $ "Sending partial update at " ++ show path ++ ": " ++ show updatedNode + sendPacket conn $ ServerUpdate path updatedNode + +runUntilHalt :: WS.Connection -> TreeApp s e -> RunState s e -> IO () +runUntilHalt conn app rs = do + event <- atomically $ readEvent rs + next <- appHandleEvent app (rsState rs) event + case next of + Halt -> pure () + Continue state' -> do + let node' = appGraft app state' + sendNodeUpdate conn (rsNode rs) node' + runUntilHalt conn app rs{rsState = state', rsNode = node'} + +runTreeApp :: Int -> Maybe (TChan e) -> TreeApp s e -> WS.ServerApp +runTreeApp pingDelay customChan app pendingConn = do + conn <- WS.acceptRequest pendingConn + chan <- atomically newTChan + WS.withPingThread conn pingDelay (pure ()) $ + appConstructor app $ \initialState -> do + firstPacket <- receivePacket conn + case firstPacket of + ClientHello _ -> do + let initialNode = appGraft app initialState + rs = RunState chan customChan initialState initialNode + sendPacket conn $ ServerHello [] initialNode + withThread (receiveThread conn chan) $ runUntilHalt conn app rs + _ -> closeWithErrorMessage conn "Invalid packet: Expected hello" From f6a281fee1bb31512ecc75faa04e5d77afd6b3cc Mon Sep 17 00:00:00 2001 From: Joscha Date: Sun, 15 Mar 2020 14:29:58 +0000 Subject: [PATCH 15/27] [server] Add schema for tree-like node structures --- forest-common/src/Forest/OrderedMap.hs | 6 +++ forest-server/forest-server.cabal | 1 + forest-server/src/Forest/Server/Schema.hs | 46 +++++++++++++++++++++++ 3 files changed, 53 insertions(+) create mode 100644 forest-server/src/Forest/Server/Schema.hs diff --git a/forest-common/src/Forest/OrderedMap.hs b/forest-common/src/Forest/OrderedMap.hs index a29f3af..9d5c1d3 100644 --- a/forest-common/src/Forest/OrderedMap.hs +++ b/forest-common/src/Forest/OrderedMap.hs @@ -70,6 +70,12 @@ data OrderedMap k a = OrderedMap instance (Ord k, Show k, Show a) => Show (OrderedMap k a) where show m = "fromList " ++ show (toList m) +instance Functor (OrderedMap k) where + fmap = Forest.OrderedMap.map + +instance (Ord k) => Foldable (OrderedMap k) where + foldMap f = foldMap f . elems + -- Invariants of this data type: -- -- 1. The 'omOrder' list contains each key from 'omMap' exactly once. diff --git a/forest-server/forest-server.cabal b/forest-server/forest-server.cabal index 4170bbb..03be485 100644 --- a/forest-server/forest-server.cabal +++ b/forest-server/forest-server.cabal @@ -28,6 +28,7 @@ library exposed-modules: Forest.Server Forest.Server.Broadcast + Forest.Server.Schema Forest.Server.TreeApp Forest.Server.TreeModule Forest.Server.TreeModule.Animate diff --git a/forest-server/src/Forest/Server/Schema.hs b/forest-server/src/Forest/Server/Schema.hs new file mode 100644 index 0000000..3b7d1cf --- /dev/null +++ b/forest-server/src/Forest/Server/Schema.hs @@ -0,0 +1,46 @@ +module Forest.Server.Schema + ( Schema + , fork + , fork' + , leaf + , collect + , collectWith + , dispatch + ) where + +import qualified Data.Text as T + +import Forest.Node +import qualified Forest.OrderedMap as OMap + +data Schema a + = Fork T.Text (OMap.OrderedMap NodeId (Schema a)) + | Leaf a + +instance Functor Schema where + fmap f (Leaf a) = Leaf $ f a + fmap f (Fork text children) = Fork text $ fmap (fmap f) children + +fork :: T.Text -> [(NodeId, Schema a)] -> Schema a +fork text = Fork text . OMap.fromList + +fork' :: T.Text -> [Schema a] -> Schema a +fork' text = fork text . zip keys + where + keys :: [NodeId] + keys = map (T.pack . show) [0::Int ..] + +leaf :: a -> Schema a +leaf = Leaf + +collect :: Schema Node -> Node +collect (Leaf node) = node +collect (Fork text children) = Node text mempty $ OMap.map collect children + +collectWith :: (a -> Node) -> Schema a -> Node +collectWith f = collect . fmap f + +dispatch :: Path -> Schema a -> Maybe (Path, a) +dispatch path (Leaf a) = Just (path, a) +dispatch (Path (x:xs)) (Fork _ omap) = dispatch (Path xs) =<< (omap OMap.!? x) +dispatch (Path []) (Fork _ _ ) = Nothing -- More specfic than required From a2d392bc4d95a62aadd2595116f676d3cdbb9321 Mon Sep 17 00:00:00 2001 From: Joscha Date: Sun, 15 Mar 2020 14:55:39 +0000 Subject: [PATCH 16/27] [server] Remove old tree modules --- forest-server/forest-server.cabal | 7 -- forest-server/src/Forest/Server.hs | 71 ----------- forest-server/src/Forest/Server/Broadcast.hs | 52 -------- forest-server/src/Forest/Server/TreeModule.hs | 25 ---- .../src/Forest/Server/TreeModule/Animate.hs | 27 ---- .../src/Forest/Server/TreeModule/Const.hs | 118 ------------------ .../src/Forest/Server/TreeModule/Fork.hs | 102 --------------- .../Forest/Server/TreeModule/SharedEditing.hs | 56 --------- 8 files changed, 458 deletions(-) delete mode 100644 forest-server/src/Forest/Server.hs delete mode 100644 forest-server/src/Forest/Server/Broadcast.hs delete mode 100644 forest-server/src/Forest/Server/TreeModule.hs delete mode 100644 forest-server/src/Forest/Server/TreeModule/Animate.hs delete mode 100644 forest-server/src/Forest/Server/TreeModule/Const.hs delete mode 100644 forest-server/src/Forest/Server/TreeModule/Fork.hs delete mode 100644 forest-server/src/Forest/Server/TreeModule/SharedEditing.hs diff --git a/forest-server/forest-server.cabal b/forest-server/forest-server.cabal index 03be485..64e5f60 100644 --- a/forest-server/forest-server.cabal +++ b/forest-server/forest-server.cabal @@ -26,15 +26,8 @@ source-repository head library exposed-modules: - Forest.Server - Forest.Server.Broadcast Forest.Server.Schema Forest.Server.TreeApp - Forest.Server.TreeModule - Forest.Server.TreeModule.Animate - Forest.Server.TreeModule.Const - Forest.Server.TreeModule.Fork - Forest.Server.TreeModule.SharedEditing other-modules: Paths_forest_server hs-source-dirs: diff --git a/forest-server/src/Forest/Server.hs b/forest-server/src/Forest/Server.hs deleted file mode 100644 index 7a665a6..0000000 --- a/forest-server/src/Forest/Server.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -module Forest.Server - ( withThread - , serverApp - ) where - -import Control.Concurrent.Chan -import Control.Exception -import qualified Network.WebSockets as WS - -import Forest.Api -import Forest.Node -import Forest.Server.TreeModule -import Forest.Util - -{- Thread that sends updates to the client -} - -sendUpdatesThread :: WS.Connection -> Chan Node -> Node -> IO () -sendUpdatesThread conn nodeChan nodeA = do - nodeB <- readChan nodeChan - case diffNodes nodeA nodeB of - Nothing -> do - putStrLn "Sending no update because the node didn't change" - sendUpdatesThread conn nodeChan nodeA - Just (path, nextNode) -> do - putStrLn $ "Sending partial update for path " ++ show path ++ ": " ++ show nextNode - sendPacket conn $ ServerUpdate path nextNode - sendUpdatesThread conn nodeChan nodeB - -{- Main server application that receives and processes client packets -} - -receivePackets :: TreeModule a () => WS.Connection -> a () -> IO () -receivePackets conn treeModule = whileNothingM $ do - packet <- receivePacket conn - case packet of - ClientEdit path text -> do - putStrLn $ "Editing " ++ show path ++ " to " ++ show text - edit treeModule path text - ClientDelete path -> do - putStrLn $ "Deleting " ++ show path - delete treeModule path - ClientReply path text -> do - putStrLn $ "Replying to " ++ show path ++ " with " ++ show text - reply treeModule path text - ClientAct path -> do - putStrLn $ "Acting upon " ++ show path - act treeModule path - ClientHello _ -> closeWithErrorMessage conn "Invalid packet: Hello can only be sent once" - -printException :: SomeException -> IO () -printException e = putStrLn $ "Encountered exception: " ++ show e - -serverApp :: TreeModule a () => Int -> ModuleConstructor (a ()) -> WS.ServerApp -serverApp pingDelay constructor pendingConnection = do - conn <- WS.acceptRequest pendingConnection - chan <- newChan - WS.withPingThread conn pingDelay (pure ()) $ handle printException $ do - firstPacket <- receivePacket conn - case firstPacket of - ClientHello _ -> do - putStrLn $ "Sending hello reply with " ++ show initialNode - sendPacket conn $ ServerHello [] initialNode - withThread (sendUpdatesThread conn chan initialNode) $ - constructor (writeChan chan) $ \tm -> do - receivePackets conn tm - putStrLn "Module finished, closing connection" - _ -> closeWithErrorMessage conn "Invalid packet: Expected a hello packet" - where - initialNode = txtNode "" "Loading..." diff --git a/forest-server/src/Forest/Server/Broadcast.hs b/forest-server/src/Forest/Server/Broadcast.hs deleted file mode 100644 index e7fb4b0..0000000 --- a/forest-server/src/Forest/Server/Broadcast.hs +++ /dev/null @@ -1,52 +0,0 @@ --- | A 'Broadcaster' allows threads to 'broadcast' values to 'Listeners' --- attached to that broadcaster. A value that is sent through a broadcaster will --- arrive exactly once at each attached listener and can then be collected by --- calling 'listen'. --- --- All functions included in this module should be threadsafe. Be sure to read --- the warning on the 'broadcast' function. - -module Forest.Server.Broadcast - ( Broadcaster - , Listener - , newBroadcaster - , attachListener - , broadcast - , listen - ) where - -import Control.Concurrent.Chan - --- | A 'Broadcaster' can broadcast values to all attached 'Listener's -newtype Broadcaster a = Broadcaster (Chan a) - --- | A 'Listener' receives values from the 'Broadcaster' it is attached to -newtype Listener a = Listener (Chan a) - --- | Create a new 'Broadcaster' -newBroadcaster :: IO (Broadcaster a) -newBroadcaster = Broadcaster <$> newChan - --- | Create a new 'Listener' that is attached to a 'Broadcaster' -attachListener :: Broadcaster a -> IO (Listener a) -attachListener (Broadcaster chan) = Listener <$> dupChan chan - --- | Send a value through the 'Broadcaster'. That value will arrive exactly once --- at all 'Listener's attached to this broadcaster via 'attachListener'. --- --- Warning: During this function call, no exception should occur or elements may --- build up in the broadcaster, leading to a memory/space leak. -broadcast :: Broadcaster a -> a -> IO () --- Because the same function that puts something into the broadcaster channel --- also immediately reads something from that channel, there is no build-up of --- values in the broadcaster channel, as one element is removed for each element --- written. Since the broadcaster channel is separate from the listener --- channels, no event is swallowed accidentally. --- --- If some exception happens after the write operation succeeds but before the --- read operation finishes, elements can build up in the broadcast channel. -broadcast (Broadcaster chan) value = writeChan chan value <* readChan chan - --- | Read the next value from the 'Listener'. Blocks when the listener is empty. -listen :: Listener a -> IO a -listen (Listener chan) = readChan chan diff --git a/forest-server/src/Forest/Server/TreeModule.hs b/forest-server/src/Forest/Server/TreeModule.hs deleted file mode 100644 index b289179..0000000 --- a/forest-server/src/Forest/Server/TreeModule.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} - -module Forest.Server.TreeModule - ( TreeModule(..) - , ModuleConstructor - ) where - -import qualified Data.Text as T - -import Forest.Node - -class TreeModule a r where - edit :: a r -> Path -> T.Text -> IO (Maybe r) - edit _ _ _ = pure Nothing - - delete :: a r -> Path -> IO (Maybe r) - delete _ _ = pure Nothing - - reply :: a r -> Path -> T.Text -> IO (Maybe r) - reply _ _ _ = pure Nothing - - act :: a r -> Path -> IO (Maybe r) - act _ _ = pure Nothing - -type ModuleConstructor a = (Node -> IO ()) -> (a -> IO ()) -> IO () diff --git a/forest-server/src/Forest/Server/TreeModule/Animate.hs b/forest-server/src/Forest/Server/TreeModule/Animate.hs deleted file mode 100644 index 9aef0f8..0000000 --- a/forest-server/src/Forest/Server/TreeModule/Animate.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} - -module Forest.Server.TreeModule.Animate - ( AnimateModule - , animateModule - ) where - -import Control.Concurrent - -import Forest.Node -import Forest.Server.TreeModule -import Forest.Util - -data AnimateModule r = AnimateModule - -instance TreeModule AnimateModule () where - -animateModule :: Int -> [Node] -> ModuleConstructor (AnimateModule ()) -animateModule delay frames sendNode continue = - withThread (animateThread frames) $ continue AnimateModule - where - animateThread [] = sendNode $ txtNode "" "Invalid animation: No frames provided" - animateThread (x:xs) = do - sendNode x - threadDelay delay - animateThread $ xs ++ [x] diff --git a/forest-server/src/Forest/Server/TreeModule/Const.hs b/forest-server/src/Forest/Server/TreeModule/Const.hs deleted file mode 100644 index 3d8124f..0000000 --- a/forest-server/src/Forest/Server/TreeModule/Const.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} - -module Forest.Server.TreeModule.Const - ( ConstModule - , constModule - , projectDescriptionNode - ) where - -import Forest.Node -import Forest.Server.TreeModule - -data ConstModule r = ConstModule - -instance TreeModule ConstModule () where - -constModule :: Node -> ModuleConstructor (ConstModule ()) -constModule node sendNode continue = do - sendNode node - continue ConstModule - -projectDescriptionNode :: Node -projectDescriptionNode = - newNode "" "About" - [ txtNode "" "This project is an experiment in tree-based interaction." - , newNode "" "Motivation" - [ txtNode "" "My goals for this project were:" - , newNode "" "Interactons between multiple people" - [ txtNode "" - ( "I wanted to create a project that let multiple people interact with " - <> "each other in different ways. Examples for interactions include:\n" - <> "* Chatting\n" - <> "* Collaborative editing\n" - <> "* Playing (multiplayer) games\n" - ) - , txtNode "" "The project should allow for many different kinds of interactions." - ] - , newNode "" "Portability" - [ txtNode "" - ( "The project should be usable on multiple different platforms. To " - <> "facilitate this, clients should be easy to create. In particular, I " - <> "want at least one terminal-based and one web-based client." - ) - ] - , txtNode "" "Based on these goals, I made the following design decisions:" - , newNode "" "Text-based" - [ txtNode "" - ( "Text is a medium that works on all platforms and easy to work with " - <> "as a developer." - ) - , txtNode "" - ( "But text still allows for a lot of different interactions. Of all " - <> "the kinds of media one can produce with a computer, text is easy " - <> "and quick to create. After all, pretty much every computer has a " - <> "keyboard." - ) - ] - , newNode "" "Tree-based" - [ txtNode "" - ( "While plain text may be easy to work with, it makes interactions " - <> "cumbersome if limited to basic input and output. To make " - <> "interactions nicer, the server could send the client a screen's " - <> "worth of text to display, in effect creating a TUI-like interface. " - <> "The client would then only need to send key presses or mouse clicks " - <> "to the server." - ) - , txtNode "" - ( "In my opinion, that approach moves too many decisions on how to " - <> "interact to the server and imposes unnecessary limits on the client " - <> "design. Instead, I went with a plaintext-in-tree-structure " - <> "approach, which allows for more flexibility in the client design. " - <> "Also, this should make bots easier to write, since they don't have " - <> "to emulate human input." - ) - ] - , newNode "" "Simple API" - [ txtNode "" - ( "Every client must use the same API to interact with the server. " - <> "Because clients should be easy to create on different platforms, " - <> "the API should also be simple." - ) - , txtNode "" - ( "One way in which the API is simple is that the server doesn't send " - <> "direct responses to client commands. Instead, there is only the " - <> "'update' packet, which is sent whenever the client should modify " - <> "its tree structure." - ) - , txtNode "" - ( "In total, there are 5 different client packages and 2 different " - <> "server packages. If at some point the API turns out to be too " - <> "simple, it has a built-in way of negotiating protocol extensions." - ) - ] - , newNode "" "Most logic in server" - [ txtNode "" - ( "All logic besides the immediate input handling and tree folding " - <> "happens in the server. This has multiple advantages:" - ) - , txtNode "" "The API and clients are simpler, clients are easier to write or maintain." - , txtNode "" "Updates in logic don't require updates of the client." - , txtNode "" "The server-side logic becomes easier to write." - ] - , txtNode "" - ( "Those design decisions should allow for various different kinds of " - <> "interactions, for example linear and threaded chat, collaborative " - <> "node editing, reading node-based documents (like this one), playing " - <> "text adventures and more." - ) - , txtNode "" - ( "And of course, which interactions are supported only depends on the " - <> "server and not on the client." - ) - ] - , newNode "" "Inspirations" - [ txtNode "" "The tree-based chat model and UI of euphoria (euphoria.io) and instant (instant.leet.nu)" - , txtNode "" "MUDs (which are text based and most of the logic happens server-side)" - ] - ] diff --git a/forest-server/src/Forest/Server/TreeModule/Fork.hs b/forest-server/src/Forest/Server/TreeModule/Fork.hs deleted file mode 100644 index 7be309e..0000000 --- a/forest-server/src/Forest/Server/TreeModule/Fork.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} - -module Forest.Server.TreeModule.Fork - ( ForkModule - , ProngConstructor(..) - , forkModule - ) where - -import Control.Concurrent.MVar -import Control.Monad.Trans.Cont -import qualified Data.Map as Map -import qualified Data.Text as T - -import Forest.Node -import qualified Forest.OrderedMap as OMap -import Forest.Server.TreeModule - -data Prong = forall r a . TreeModule a r => Prong (a r) - -data ProngConstructor = forall r a . TreeModule a r => - ProngConstructor T.Text (ModuleConstructor (a r)) - -newtype ForkModule r = ForkModule (Map.Map NodeId Prong) - -instance TreeModule ForkModule () where - edit _ (Path []) _ = pure Nothing - edit (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of - Nothing -> pure Nothing - Just (Prong a) -> do - result <- edit a (Path xs) text - pure $ () <$ result - - delete _ (Path []) = pure Nothing - delete (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of - Nothing -> pure Nothing - Just (Prong a) -> do - result <- delete a (Path xs) - pure $ () <$ result - - reply _ (Path []) _ = pure Nothing - reply (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of - Nothing -> pure Nothing - Just (Prong a) -> do - result <- reply a (Path xs) text - pure $ () <$ result - - act _ (Path []) = pure Nothing - act (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of - Nothing -> pure Nothing - Just (Prong a) -> do - result <- act a (Path xs) - pure $ () <$ result - -data ProngInfo = ProngInfo - { piTopName :: T.Text - , piNames :: Map.Map NodeId T.Text - , piNodes :: Map.Map NodeId Node - , piOrder :: [NodeId] - } - -renderProngInfo :: ProngInfo -> Node -renderProngInfo pInfo = - let childMap = Map.intersectionWith - (\name node -> node{nodeText = name}) - (piNames pInfo) - (piNodes pInfo) - children = OMap.fromMapWithOrder childMap $ piOrder pInfo - in Node {nodeText = piTopName pInfo, nodeFlags = mempty, nodeChildren = children} - -sendNodeFromProng :: MVar ProngInfo -> (Node -> IO ()) -> NodeId -> Node -> IO () -sendNodeFromProng piVar sendNode nodeId node = - modifyMVar_ piVar $ \pInfo -> do - let newPInfo = pInfo {piNodes = Map.insert nodeId node $ piNodes pInfo} - sendNode $ renderProngInfo newPInfo - pure newPInfo - -constructProngs - :: MVar ProngInfo - -> (Node -> IO ()) - -> Map.Map NodeId ProngConstructor - -> Cont (IO ()) (Map.Map NodeId Prong) -constructProngs piVar sendNode = - Map.traverseWithKey constructProng - where - constructProng nodeId (ProngConstructor _ constructor) = - Prong <$> cont (constructor $ sendNodeFromProng piVar sendNode nodeId) - -forkModule :: T.Text -> [ProngConstructor] -> ModuleConstructor (ForkModule ()) -forkModule text prongs sendNode continue = do - let namePairs = zip enumerateIds $ map (\(ProngConstructor name _) -> name) prongs - nodesVar <- newMVar ProngInfo - { piTopName = text - , piNames = Map.fromList namePairs - , piNodes = Map.empty - , piOrder = map fst namePairs - } - let numbers = map (T.pack . show) [(0::Integer)..] - prongMap = Map.fromList $ zip numbers prongs - runCont (constructProngs nodesVar sendNode prongMap) (continue . ForkModule) diff --git a/forest-server/src/Forest/Server/TreeModule/SharedEditing.hs b/forest-server/src/Forest/Server/TreeModule/SharedEditing.hs deleted file mode 100644 index 59e4bc2..0000000 --- a/forest-server/src/Forest/Server/TreeModule/SharedEditing.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module Forest.Server.TreeModule.SharedEditing - ( SharedEditingModule - , sharedEditingModule - ) where - -import Control.Concurrent.MVar -import Control.Monad - -import Forest.Node -import Forest.Server.Broadcast -import Forest.Server.TreeModule -import Forest.Util - -data SharedEditingModule r = SharedEditingModule - { seNodeVar :: MVar Node - , seBroadcaster :: Broadcaster Node - } - -instance TreeModule SharedEditingModule r where - edit _ (Path []) _ = pure Nothing - edit se path text = do - node' <- modifyMVar (seNodeVar se) $ \node -> do - let updatedNode = adjustAt (\n -> n{nodeText = text}) path node - pure (updatedNode, updatedNode) - broadcast (seBroadcaster se) node' - pure Nothing - - delete _ (Path []) = pure Nothing - delete se path = do - node' <- modifyMVar (seNodeVar se) $ \node -> do - let updatedNode = deleteAt path node - pure (updatedNode, updatedNode) - broadcast (seBroadcaster se) node' - pure Nothing - - reply se path text = do - node' <- modifyMVar (seNodeVar se) $ \node -> do - let updatedNode = appendAt (txtNode "edr" text) path node - pure (updatedNode, updatedNode) - broadcast (seBroadcaster se) node' - pure Nothing - -sharedEditingModule :: - MVar Node -> Broadcaster Node -> ModuleConstructor (SharedEditingModule ()) -sharedEditingModule nodeVar broadcaster sendNode continue = do - listener <- attachListener broadcaster - withThread (updateOnNewBroadcast listener) $ do - withMVar nodeVar sendNode -- We need to show our initial edit state - continue $ SharedEditingModule nodeVar broadcaster - where - updateOnNewBroadcast listener = forever $ do - node <- listen listener - sendNode node From 83406dff101a3c8662ed137dd539b1e039dab6e1 Mon Sep 17 00:00:00 2001 From: Joscha Date: Sun, 15 Mar 2020 22:23:26 +0000 Subject: [PATCH 17/27] [server] Reimplement collaborative editing --- forest-cabin/app/Main.hs | 73 +++++++++++++++++++--- forest-cabin/forest-cabin.cabal | 2 + forest-cabin/package.yaml | 1 + forest-common/src/Forest/Node.hs | 2 +- forest-common/src/Forest/OrderedMap.hs | 2 +- forest-server/src/Forest/Server/TreeApp.hs | 10 ++- 6 files changed, 75 insertions(+), 15 deletions(-) diff --git a/forest-cabin/app/Main.hs b/forest-cabin/app/Main.hs index 6ced424..1d75ba1 100644 --- a/forest-cabin/app/Main.hs +++ b/forest-cabin/app/Main.hs @@ -2,11 +2,16 @@ module Main where -import qualified Network.WebSockets as WS +import Control.Concurrent.MVar +import Control.Concurrent.STM +import Control.Monad +import qualified Network.WebSockets as WS import Forest.Node import Forest.Server.TreeApp +{- Websocket server stuff -} + pingDelay :: Int pingDelay = 10 @@ -18,14 +23,68 @@ options = WS.defaultServerOptions { WS.serverRequirePong = Just pongDelay } -app :: TreeApp Node () -app = TreeApp - { appGraft = id - , appHandleEvent = \s _ -> pure $ continue s - , appConstructor = simpleConstructor $ txtNode "" "Hello world" +{- The actual app -} + +data AppEvent = SharedNodeEdited + deriving (Show, Eq) + +data AppState = AppState + { asBroadcastChan :: TChan AppEvent + , asReceiveChan :: TChan AppEvent + , asSharedNodeVar :: MVar Node + , asSharedNode :: Node } +graft :: AppState -> Node +graft = asSharedNode + +updateSharedNode :: AppState -> (Node -> Node) -> IO AppState +updateSharedNode s f = do + node <- takeMVar $ asSharedNodeVar s + let node' = f node + putMVar (asSharedNodeVar s) node' + when (node /= node') $ atomically $ do + writeTChan (asBroadcastChan s) SharedNodeEdited + void $ readTChan $ asReceiveChan s + pure s{asSharedNode = node'} + +handleEvent :: AppState -> Event AppEvent -> IO (Next AppState) +handleEvent s (Custom SharedNodeEdited) = do + node <- readMVar $ asSharedNodeVar s + pure $ continue s{asSharedNode = node} +handleEvent s (Edit path text) = do + s' <- updateSharedNode s $ adjustAt (\n -> n{nodeText = text}) path + pure $ continue s' +handleEvent s (Delete path) = do + s' <- updateSharedNode s $ deleteAt path + pure $ continue s' +handleEvent s (Reply path text) = do + s' <- updateSharedNode s $ appendAt (txtNode "edr" text) path + pure $ continue s' +handleEvent s _ = do + pure $ continue s + +constructor + :: TChan AppEvent + -> MVar Node + -> (AppState -> Maybe (TChan AppEvent) -> IO a) + -> IO a +constructor broadcastChan sharedNodeVar cont = do + node <- readMVar sharedNodeVar + receiveChan <- atomically $ dupTChan broadcastChan + let state = AppState broadcastChan receiveChan sharedNodeVar node + cont state $ Just receiveChan + main :: IO () main = do + putStrLn "Preparing shared editing" + sharedNodeVar <- newMVar $ txtNode "r" "Sandbox" + broadcastChan <- atomically newBroadcastTChan + let app = TreeApp + { appGraft = graft + , appHandleEvent = handleEvent + , appConstructor = constructor broadcastChan sharedNodeVar + } + putStrLn "Starting server" - WS.runServerWithOptions options $ runTreeApp pingDelay Nothing app + WS.runServerWithOptions options $ runTreeApp pingDelay app diff --git a/forest-cabin/forest-cabin.cabal b/forest-cabin/forest-cabin.cabal index 3c0b54a..8d6e630 100644 --- a/forest-cabin/forest-cabin.cabal +++ b/forest-cabin/forest-cabin.cabal @@ -33,6 +33,7 @@ library base >=4.7 && <5 , forest-common , forest-server + , stm , websockets default-language: Haskell2010 @@ -48,5 +49,6 @@ executable forest-cabin , forest-cabin , forest-common , forest-server + , stm , websockets default-language: Haskell2010 diff --git a/forest-cabin/package.yaml b/forest-cabin/package.yaml index 4bfa1c6..41b5343 100644 --- a/forest-cabin/package.yaml +++ b/forest-cabin/package.yaml @@ -15,6 +15,7 @@ dependencies: - base >= 4.7 && < 5 - forest-common - forest-server + - stm - websockets library: diff --git a/forest-common/src/Forest/Node.hs b/forest-common/src/Forest/Node.hs index c89b6c3..b78a70a 100644 --- a/forest-common/src/Forest/Node.hs +++ b/forest-common/src/Forest/Node.hs @@ -82,7 +82,7 @@ data Node = Node { nodeText :: !T.Text , nodeFlags :: !NodeFlags , nodeChildren :: !(OMap.OrderedMap NodeId Node) - } deriving (Show) + } deriving (Show, Eq) instance ToJSON Node where toJSON node = object diff --git a/forest-common/src/Forest/OrderedMap.hs b/forest-common/src/Forest/OrderedMap.hs index 9d5c1d3..5d13333 100644 --- a/forest-common/src/Forest/OrderedMap.hs +++ b/forest-common/src/Forest/OrderedMap.hs @@ -65,7 +65,7 @@ import qualified Data.Set as Set data OrderedMap k a = OrderedMap { omMap :: Map.Map k a , omOrder :: [k] - } + } deriving (Eq) instance (Ord k, Show k, Show a) => Show (OrderedMap k a) where show m = "fromList " ++ show (toList m) diff --git a/forest-server/src/Forest/Server/TreeApp.hs b/forest-server/src/Forest/Server/TreeApp.hs index 88aafe8..a33dd01 100644 --- a/forest-server/src/Forest/Server/TreeApp.hs +++ b/forest-server/src/Forest/Server/TreeApp.hs @@ -1,7 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} - -- | This module specifies a structure for forest server applications. It is -- based on the way Brick models applications. @@ -43,7 +41,7 @@ data Event e data TreeApp s e = TreeApp { appGraft :: s -> Node , appHandleEvent :: s -> Event e -> IO (Next s) - , appConstructor :: forall a. (s -> IO a) -> IO a + , appConstructor :: forall a. (s -> Maybe (TChan e) -> IO a) -> IO a } simpleConstructor :: s -> (s -> IO a) -> IO a @@ -99,12 +97,12 @@ runUntilHalt conn app rs = do sendNodeUpdate conn (rsNode rs) node' runUntilHalt conn app rs{rsState = state', rsNode = node'} -runTreeApp :: Int -> Maybe (TChan e) -> TreeApp s e -> WS.ServerApp -runTreeApp pingDelay customChan app pendingConn = do +runTreeApp :: Int -> TreeApp s e -> WS.ServerApp +runTreeApp pingDelay app pendingConn = do conn <- WS.acceptRequest pendingConn chan <- atomically newTChan WS.withPingThread conn pingDelay (pure ()) $ - appConstructor app $ \initialState -> do + appConstructor app $ \initialState customChan -> do firstPacket <- receivePacket conn case firstPacket of ClientHello _ -> do From aa074d181bfda7642bf18a57d768b05382c09843 Mon Sep 17 00:00:00 2001 From: Joscha Date: Sun, 15 Mar 2020 22:29:45 +0000 Subject: [PATCH 18/27] [server] Rename "graft" to "draw" --- forest-cabin/app/Main.hs | 9 ++++----- forest-server/src/Forest/Server/TreeApp.hs | 6 +++--- 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/forest-cabin/app/Main.hs b/forest-cabin/app/Main.hs index 1d75ba1..b8443cd 100644 --- a/forest-cabin/app/Main.hs +++ b/forest-cabin/app/Main.hs @@ -35,8 +35,8 @@ data AppState = AppState , asSharedNode :: Node } -graft :: AppState -> Node -graft = asSharedNode +draw :: AppState -> Node +draw = asSharedNode updateSharedNode :: AppState -> (Node -> Node) -> IO AppState updateSharedNode s f = do @@ -61,8 +61,7 @@ handleEvent s (Delete path) = do handleEvent s (Reply path text) = do s' <- updateSharedNode s $ appendAt (txtNode "edr" text) path pure $ continue s' -handleEvent s _ = do - pure $ continue s +handleEvent s _ = pure $ continue s constructor :: TChan AppEvent @@ -81,7 +80,7 @@ main = do sharedNodeVar <- newMVar $ txtNode "r" "Sandbox" broadcastChan <- atomically newBroadcastTChan let app = TreeApp - { appGraft = graft + { appDraw = draw , appHandleEvent = handleEvent , appConstructor = constructor broadcastChan sharedNodeVar } diff --git a/forest-server/src/Forest/Server/TreeApp.hs b/forest-server/src/Forest/Server/TreeApp.hs index a33dd01..a43e16d 100644 --- a/forest-server/src/Forest/Server/TreeApp.hs +++ b/forest-server/src/Forest/Server/TreeApp.hs @@ -39,7 +39,7 @@ data Event e | Custom e data TreeApp s e = TreeApp - { appGraft :: s -> Node + { appDraw :: s -> Node , appHandleEvent :: s -> Event e -> IO (Next s) , appConstructor :: forall a. (s -> Maybe (TChan e) -> IO a) -> IO a } @@ -93,7 +93,7 @@ runUntilHalt conn app rs = do case next of Halt -> pure () Continue state' -> do - let node' = appGraft app state' + let node' = appDraw app state' sendNodeUpdate conn (rsNode rs) node' runUntilHalt conn app rs{rsState = state', rsNode = node'} @@ -106,7 +106,7 @@ runTreeApp pingDelay app pendingConn = do firstPacket <- receivePacket conn case firstPacket of ClientHello _ -> do - let initialNode = appGraft app initialState + let initialNode = appDraw app initialState rs = RunState chan customChan initialState initialNode sendPacket conn $ ServerHello [] initialNode withThread (receiveThread conn chan) $ runUntilHalt conn app rs From 63a36d8a711ea6160aa2c487885a2eed0b7e8082 Mon Sep 17 00:00:00 2001 From: Joscha Date: Tue, 17 Mar 2020 20:29:18 +0000 Subject: [PATCH 19/27] [server] Extract shared editing logic into a branch --- forest-cabin/app/Main.hs | 72 +++++++---------- forest-cabin/forest-cabin.cabal | 4 + forest-cabin/package.yaml | 2 + forest-server/forest-server.cabal | 2 + forest-server/package.yaml | 1 + .../src/Forest/Server/Branch/SharedEdit.hs | 80 +++++++++++++++++++ forest-server/src/Forest/Server/Schema.hs | 43 +++++++++- 7 files changed, 161 insertions(+), 43 deletions(-) create mode 100644 forest-server/src/Forest/Server/Branch/SharedEdit.hs diff --git a/forest-cabin/app/Main.hs b/forest-cabin/app/Main.hs index b8443cd..50e97b9 100644 --- a/forest-cabin/app/Main.hs +++ b/forest-cabin/app/Main.hs @@ -1,13 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Main where -import Control.Concurrent.MVar import Control.Concurrent.STM -import Control.Monad -import qualified Network.WebSockets as WS +import Lens.Micro +import Lens.Micro.TH +import qualified Network.WebSockets as WS import Forest.Node +import Forest.Server.Branch.SharedEdit +import Forest.Server.Schema import Forest.Server.TreeApp {- Websocket server stuff -} @@ -25,64 +28,51 @@ options = WS.defaultServerOptions {- The actual app -} -data AppEvent = SharedNodeEdited +data AppEvent = UpdateSharedEdit deriving (Show, Eq) -data AppState = AppState - { asBroadcastChan :: TChan AppEvent - , asReceiveChan :: TChan AppEvent - , asSharedNodeVar :: MVar Node - , asSharedNode :: Node +newtype AppState = AppState + { _asSharedEdit :: SharedEditLocal } -draw :: AppState -> Node -draw = asSharedNode +makeLenses ''AppState -updateSharedNode :: AppState -> (Node -> Node) -> IO AppState -updateSharedNode s f = do - node <- takeMVar $ asSharedNodeVar s - let node' = f node - putMVar (asSharedNodeVar s) node' - when (node /= node') $ atomically $ do - writeTChan (asBroadcastChan s) SharedNodeEdited - void $ readTChan $ asReceiveChan s - pure s{asSharedNode = node'} +schema :: AppState -> Schema (Branch AppState AppEvent) +schema s = fork' "Forest" + [ leaf $ schemaLift asSharedEdit sharedEditBranch s + ] + +draw :: AppState -> Node +draw = schemaDraw . schema handleEvent :: AppState -> Event AppEvent -> IO (Next AppState) -handleEvent s (Custom SharedNodeEdited) = do - node <- readMVar $ asSharedNodeVar s - pure $ continue s{asSharedNode = node} -handleEvent s (Edit path text) = do - s' <- updateSharedNode s $ adjustAt (\n -> n{nodeText = text}) path - pure $ continue s' -handleEvent s (Delete path) = do - s' <- updateSharedNode s $ deleteAt path - pure $ continue s' -handleEvent s (Reply path text) = do - s' <- updateSharedNode s $ appendAt (txtNode "edr" text) path - pure $ continue s' -handleEvent s _ = pure $ continue s +handleEvent s (Custom UpdateSharedEdit) = do + sel' <- sharedEditUpdate $ s ^. asSharedEdit + pure $ continue $ s & asSharedEdit .~ sel' +handleEvent s e = case schemaHandleEvent (schema s) e of + Nothing -> pure $ continue s + Just s' -> continue <$> s' constructor :: TChan AppEvent - -> MVar Node + -> SharedEditGlobal -> (AppState -> Maybe (TChan AppEvent) -> IO a) -> IO a -constructor broadcastChan sharedNodeVar cont = do - node <- readMVar sharedNodeVar +constructor broadcastChan seg cont = do + sel <- sharedEditLocal seg receiveChan <- atomically $ dupTChan broadcastChan - let state = AppState broadcastChan receiveChan sharedNodeVar node - cont state $ Just receiveChan + cont (AppState sel) (Just receiveChan) main :: IO () main = do - putStrLn "Preparing shared editing" - sharedNodeVar <- newMVar $ txtNode "r" "Sandbox" + putStrLn "Preparing server" broadcastChan <- atomically newBroadcastTChan + let onEditChange = atomically $ writeTChan broadcastChan UpdateSharedEdit + seg <- sharedEditGlobal onEditChange "Sandbox" let app = TreeApp { appDraw = draw , appHandleEvent = handleEvent - , appConstructor = constructor broadcastChan sharedNodeVar + , appConstructor = constructor broadcastChan seg } putStrLn "Starting server" diff --git a/forest-cabin/forest-cabin.cabal b/forest-cabin/forest-cabin.cabal index 8d6e630..6b40d14 100644 --- a/forest-cabin/forest-cabin.cabal +++ b/forest-cabin/forest-cabin.cabal @@ -33,6 +33,8 @@ library base >=4.7 && <5 , forest-common , forest-server + , microlens + , microlens-th , stm , websockets default-language: Haskell2010 @@ -49,6 +51,8 @@ executable forest-cabin , forest-cabin , forest-common , forest-server + , microlens + , microlens-th , stm , websockets default-language: Haskell2010 diff --git a/forest-cabin/package.yaml b/forest-cabin/package.yaml index 41b5343..143b8dc 100644 --- a/forest-cabin/package.yaml +++ b/forest-cabin/package.yaml @@ -15,6 +15,8 @@ dependencies: - base >= 4.7 && < 5 - forest-common - forest-server + - microlens + - microlens-th - stm - websockets diff --git a/forest-server/forest-server.cabal b/forest-server/forest-server.cabal index 64e5f60..b581d18 100644 --- a/forest-server/forest-server.cabal +++ b/forest-server/forest-server.cabal @@ -26,6 +26,7 @@ source-repository head library exposed-modules: + Forest.Server.Branch.SharedEdit Forest.Server.Schema Forest.Server.TreeApp other-modules: @@ -36,6 +37,7 @@ library base >=4.7 && <5 , containers , forest-common + , microlens , stm , text , transformers diff --git a/forest-server/package.yaml b/forest-server/package.yaml index cb5c5f6..f9395d9 100644 --- a/forest-server/package.yaml +++ b/forest-server/package.yaml @@ -15,6 +15,7 @@ dependencies: - base >= 4.7 && < 5 - containers - forest-common + - microlens - stm - text - transformers diff --git a/forest-server/src/Forest/Server/Branch/SharedEdit.hs b/forest-server/src/Forest/Server/Branch/SharedEdit.hs new file mode 100644 index 0000000..d7502fe --- /dev/null +++ b/forest-server/src/Forest/Server/Branch/SharedEdit.hs @@ -0,0 +1,80 @@ +module Forest.Server.Branch.SharedEdit + ( SharedEditGlobal + , sharedEditGlobal + , SharedEditLocal + , sharedEditLocal + , sharedEditDraw + , sharedEditUpdate + , sharedEditHandleEvent + , sharedEditBranch + ) where + +import Control.Concurrent +import Control.Monad +import qualified Data.Text as T + +import Forest.Node +import Forest.Server.Schema +import Forest.Server.TreeApp + +data SharedEditGlobal = SharedEditGlobal + { seOnUpdate :: IO () + , seNodeVar :: MVar Node + } + +sharedEditGlobal :: IO () -> T.Text -> IO SharedEditGlobal +sharedEditGlobal onUpdate initialText = do + nodeVar <- newMVar $ txtNode "r" initialText + pure SharedEditGlobal + { seOnUpdate = onUpdate + , seNodeVar = nodeVar + } + +data SharedEditLocal = SharedEditLocal + { seGlobal :: SharedEditGlobal + , seNode :: Node + } + +sharedEditLocal :: SharedEditGlobal -> IO SharedEditLocal +sharedEditLocal seg = do + node <- readMVar $ seNodeVar seg + pure SharedEditLocal + { seGlobal = seg + , seNode = node + } + +sharedEditDraw :: SharedEditLocal -> Node +sharedEditDraw = seNode + +sharedEditUpdate :: SharedEditLocal -> IO SharedEditLocal +sharedEditUpdate sel = do + node <- readMVar $ seNodeVar $ seGlobal sel + pure sel{seNode = node} + +updateNode :: SharedEditLocal -> (Node -> Node) -> IO SharedEditLocal +updateNode sel f = do + let seg = seGlobal sel + nodeVar = seNodeVar seg + node <- takeMVar nodeVar + let node' = f node + putMVar nodeVar node' + when (node /= node') $ seOnUpdate seg + pure sel{seNode = node'} + +sharedEditHandleEvent :: SharedEditLocal -> Path -> Event e -> IO SharedEditLocal +-- Ignore edits to the top node since it's only reply-able, not edit-able +sharedEditHandleEvent sel (Path []) (Edit _ _) = pure sel +sharedEditHandleEvent sel (Path []) (Delete _) = pure sel +sharedEditHandleEvent sel path (Edit _ text) = + updateNode sel $ adjustAt (\n -> n {nodeText = text}) path +sharedEditHandleEvent sel path (Delete _) = + updateNode sel $ deleteAt path +sharedEditHandleEvent sel path (Reply _ text) = + updateNode sel $ appendAt (txtNode "edr" text) path +sharedEditHandleEvent sel _ _ = pure sel + +sharedEditBranch :: SharedEditLocal -> Branch SharedEditLocal e +sharedEditBranch sel = Branch + { branchNode = sharedEditDraw sel + , branchHandleEvent = sharedEditHandleEvent sel + } diff --git a/forest-server/src/Forest/Server/Schema.hs b/forest-server/src/Forest/Server/Schema.hs index 3b7d1cf..e7856f8 100644 --- a/forest-server/src/Forest/Server/Schema.hs +++ b/forest-server/src/Forest/Server/Schema.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RankNTypes #-} + module Forest.Server.Schema ( Schema , fork @@ -6,12 +8,19 @@ module Forest.Server.Schema , collect , collectWith , dispatch + -- * Useful type + , Branch(..) + , schemaDraw + , schemaHandleEvent + , schemaLift ) where -import qualified Data.Text as T +import qualified Data.Text as T +import Lens.Micro import Forest.Node -import qualified Forest.OrderedMap as OMap +import qualified Forest.OrderedMap as OMap +import Forest.Server.TreeApp data Schema a = Fork T.Text (OMap.OrderedMap NodeId (Schema a)) @@ -44,3 +53,33 @@ dispatch :: Path -> Schema a -> Maybe (Path, a) dispatch path (Leaf a) = Just (path, a) dispatch (Path (x:xs)) (Fork _ omap) = dispatch (Path xs) =<< (omap OMap.!? x) dispatch (Path []) (Fork _ _ ) = Nothing -- More specfic than required + +data Branch s e = Branch + { branchNode :: Node + , branchHandleEvent :: Path -> Event e -> IO s + } + +schemaDraw :: Schema (Branch s e) -> Node +schemaDraw = collectWith branchNode + +schemaHandleEvent :: Schema (Branch s e) -> Event e -> Maybe (IO s) +schemaHandleEvent schema event = do + path <- getPath event + (relPath, branch) <- dispatch path schema + pure $ branchHandleEvent branch relPath event + where + getPath (Edit path _) = Just path + getPath (Delete path) = Just path + getPath (Reply path _) = Just path + getPath (Act path) = Just path + getPath _ = Nothing + +schemaLift :: Lens' s t -> (t -> Branch t e) -> s -> Branch s e +schemaLift l f s = Branch + { branchNode = branchNode branch + , branchHandleEvent = \path event -> do + t' <- branchHandleEvent branch path event + pure $ s & l .~ t' + } + where + branch = f $ s ^. l From 78235ef7cfb53f231ab62e1fbc73fbc772590ebe Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 18 Mar 2020 17:04:04 +0000 Subject: [PATCH 20/27] [cabin] Parse command-line options --- forest-cabin/app/Main.hs | 53 +++++++++++++++++++++++++++------ forest-cabin/forest-cabin.cabal | 2 ++ forest-cabin/package.yaml | 1 + 3 files changed, 47 insertions(+), 9 deletions(-) diff --git a/forest-cabin/app/Main.hs b/forest-cabin/app/Main.hs index 50e97b9..82c4a76 100644 --- a/forest-cabin/app/Main.hs +++ b/forest-cabin/app/Main.hs @@ -7,23 +7,55 @@ import Control.Concurrent.STM import Lens.Micro import Lens.Micro.TH import qualified Network.WebSockets as WS +import Options.Applicative import Forest.Node import Forest.Server.Branch.SharedEdit import Forest.Server.Schema import Forest.Server.TreeApp -{- Websocket server stuff -} +{- Command line options -} -pingDelay :: Int -pingDelay = 10 +data ServerOptions = ServerOptions + { serverPingDelay :: Int + , serverHost :: String + , serverPort :: Int + } -pongDelay :: Int -pongDelay = 3 * pingDelay +parser :: Parser ServerOptions +parser = ServerOptions + <$> option auto + ( long "ping-delay" + <> help "How many seconds to wait between each ping sent to the client" + <> value 10 + <> showDefault + <> metavar "SECONDS" + ) + <*> strOption + ( short 'h' + <> long "host" + <> help "The server's host" + <> value (WS.serverHost WS.defaultServerOptions) + <> showDefault + <> metavar "HOST" + ) + <*> option auto + ( short 'p' + <> long "port" + <> help "The port to listen for websocket connections on" + <> value (WS.serverPort WS.defaultServerOptions) + <> showDefault + <> metavar "PORT" + ) -options :: WS.ServerOptions -options = WS.defaultServerOptions - { WS.serverRequirePong = Just pongDelay +serverOptionsParserInfo :: ParserInfo ServerOptions +serverOptionsParserInfo = info (helper <*> parser) fullDesc + +wsOptions :: ServerOptions -> WS.ServerOptions +wsOptions o = WS.defaultServerOptions + { WS.serverHost = serverHost o + , WS.serverPort = serverPort o + , WS.serverRequirePong = Just $ serverPingDelay o * 2 } {- The actual app -} @@ -65,6 +97,8 @@ constructor broadcastChan seg cont = do main :: IO () main = do + opts <- execParser serverOptionsParserInfo + putStrLn "Preparing server" broadcastChan <- atomically newBroadcastTChan let onEditChange = atomically $ writeTChan broadcastChan UpdateSharedEdit @@ -76,4 +110,5 @@ main = do } putStrLn "Starting server" - WS.runServerWithOptions options $ runTreeApp pingDelay app + WS.runServerWithOptions (wsOptions opts) $ + runTreeApp (serverPingDelay opts) app diff --git a/forest-cabin/forest-cabin.cabal b/forest-cabin/forest-cabin.cabal index 6b40d14..4cd34f2 100644 --- a/forest-cabin/forest-cabin.cabal +++ b/forest-cabin/forest-cabin.cabal @@ -35,6 +35,7 @@ library , forest-server , microlens , microlens-th + , optparse-applicative , stm , websockets default-language: Haskell2010 @@ -53,6 +54,7 @@ executable forest-cabin , forest-server , microlens , microlens-th + , optparse-applicative , stm , websockets default-language: Haskell2010 diff --git a/forest-cabin/package.yaml b/forest-cabin/package.yaml index 143b8dc..6e7ebe9 100644 --- a/forest-cabin/package.yaml +++ b/forest-cabin/package.yaml @@ -17,6 +17,7 @@ dependencies: - forest-server - microlens - microlens-th + - optparse-applicative - stm - websockets From 54795b81ac2063e7988c5a5b61eef0190e196ddf Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 18 Mar 2020 18:08:04 +0000 Subject: [PATCH 21/27] [web] Connect to server The individual components are more-or-less working, but the code that glues them together is still pretty ugly. I should probably revisit and clean up the individual components too. Also, the cursor code is missing a few features, but everything is usable for the first time :D --- forest-web/node.css | 12 ++-- forest-web/node.js | 144 ++++++++++++++++++++++++++++++++++++-------- 2 files changed, 124 insertions(+), 32 deletions(-) diff --git a/forest-web/node.css b/forest-web/node.css index e02c175..d19ee56 100644 --- a/forest-web/node.css +++ b/forest-web/node.css @@ -29,21 +29,21 @@ } /* Fancy tree lines */ -.node, .node::before { +.node-children > *, .node-children > *::before { border-color: var(--bright-black); border-width: 2px; } -.node-children > .node { +.node-children > * { position: relative; /* .node is containing block for its .node::before */ margin-left: calc(0.5ch - 1px); padding-left: calc(1.5ch - 1px); border-left-style: solid; } -.node-children > .node:last-child { +.node-children > *:last-child { padding-left: calc(1.5ch + 1px); border-left-style: none; } -.node-children > .node::before { +.node-children > *::before { content: ""; position: absolute; left: 0; @@ -52,9 +52,9 @@ height: calc(0.6em - 1px); border-bottom-style: solid; } -.node-children > .node:last-child::before { +.node-children > *:last-child::before { border-left-style: solid; - transition: all 0.4s; + transition: border-bottom-left-radius 0.4s; } /* Curvy lines */ diff --git a/forest-web/node.js b/forest-web/node.js index 33e722c..a374cd7 100644 --- a/forest-web/node.js +++ b/forest-web/node.js @@ -349,6 +349,7 @@ class Editor { this.nodeTree = nodeTree; this.textarea = newElement("textarea"); + this.element = newElement("div", "node-editor", this.textarea); this.textarea.addEventListener("input", event => this._updateTextAreaHeight()); this.path = undefined; @@ -370,21 +371,22 @@ class Editor { node.elements.main.classList.remove("has-editor"); } - this.textarea.parentNode.removeChild(this.textarea); + this.element.parentNode.removeChild(this.element); } _attachTo(node, asChild) { if (asChild) { - node.elements.children.appendChild(this.textarea); + node.elements.children.appendChild(this.element); + node.setFolded(false); } else { node.elements.main.classList.add("has-editor"); - node.elements.main.insertBefore(this.textarea, node.elements.children); + node.elements.main.insertBefore(this.element, node.elements.children); } this._updateTextAreaHeight(); } restore() { - if (this.textarea.parentNode !== null) return; // Already attached + if (this.element.parentNode !== null) return; // Already attached let node = this._getAttachedNode(); if (node === undefined) return; // Nowhere to attach this._attachTo(node, this.asChild); @@ -417,6 +419,64 @@ class Editor { } } +class Connection { + constructor(nodeTree, cursor, editor, url) { + this.nodeTree = nodeTree; + this.cursor = cursor; + this.editor = editor; + + this.url = url; + this.ws = new WebSocket(this.url); + this.ws.addEventListener("message", msg => this.onMessage(msg)); + this.ws.addEventListener("open", _ => this.sendHello()); + } + + onMessage(msg) { + let content = JSON.parse(msg.data); + if (content.type === "hello") { + this.onHello(content); + } else if (content.type === "update") { + this.onUpdate(content); + } + } + + onHello(content) { + this.nodeTree.updateAt(new Path(), new Node(content.node)); + this.cursor.restore(); + this.editor.restore(); + } + + onUpdate(content) { + this.nodeTree.updateAt(new Path(...content.path), new Node(content.node)); + this.cursor.restore(); + this.editor.restore(); + } + + _send(thing) { + this.ws.send(JSON.stringify(thing)); + } + + sendHello() { + this._send({type: "hello", extensions: []}); + } + + sendEdit(path, text) { + this._send({type: "edit", path: path.elements, text: text}); + } + + sendDelete(path) { + this._send({type: "delete", path: path.elements}); + } + + sendReply(path, text) { + this._send({type: "reply", path: path.elements, text: text}); + } + + sendAct(path) { + this._send({type: "act", path: path.elements}); + } +} + /* * The main application */ @@ -426,29 +486,48 @@ const loadingNode = new Node({text: "Connecting...", children: {}, order: []}); const nodeTree = new NodeTree(rootNodeContainer, loadingNode); const cursor = new Cursor(nodeTree); const editor = new Editor(nodeTree); +const conn = new Connection(nodeTree, cursor, editor, "ws://127.0.0.1:8080/"); -// TODO Replace this testing node with the real websocket code -const testNode = new Node({text: "Forest", children: [ - {text: "Test", children: [ - {text: "Bla", children: [], order: []}, - ], order: [0]}, - {text: "Sandbox", edit: true, delete: true, reply: true, act: true, children: [], order: []}, - {text: "About", children: [ - {text: "This project is an experiment in tree-based interaction.", children: [], order: []}, - {text: "Motivation", children: [], order: []}, - {text: "Inspirations", children: [], order: []}, - ], order: [0, 1, 2]} -], order: [0, 1, 2]}); -nodeTree.updateAt(new Path(), testNode); +function beginEdit() { + let node = cursor.getSelectedNode(); + editor.content = node.text; + editor.attachTo(cursor.path, false); +} + +function beginDirectReply() { + editor.content = ""; + editor.attachTo(cursor.path, true); +} + +function beginIndirectReply() { + let path = cursor.path.parent; + if (path === undefined) return; + editor.content = ""; + editor.attachTo(path, true); +} + +function cancelEdit() { + editor.detach(); +} + +function completeEdit() { + let path = editor.path; + let text = editor.textarea.value; + if (editor.asChild) { + conn.sendReply(path, text); + } else { + conn.sendEdit(path, text); + } + editor.detach(); +} document.addEventListener("keydown", event => { - console.log(event); if (event.code === "Escape") { - editor.detach(); - } else if (document.activeElement === editor.textarea) { - if (event.code === "Enter" && !event.shiftKey) { - editor.detach(); - } + cancelEdit(); + event.preventDefault(); + } else if (event.code === "Enter" && !event.shiftKey) { + completeEdit(); + event.preventDefault(); } else if (document.activeElement.tagName === "TEXTAREA") { return; // Do nothing special } else if (event.code === "Tab") { @@ -461,9 +540,22 @@ document.addEventListener("keydown", event => { cursor.moveDown(); event.preventDefault(); } else if (event.code === "KeyE") { - let node = cursor.getSelectedNode(); - editor.content = node.text; - editor.attachTo(cursor.path, false); + beginEdit(); + event.preventDefault(); + } else if (event.code === "KeyR") { + if (event.shiftKey) { + console.log("indirect"); + beginIndirectReply(); + } else { + console.log("direct"); + beginDirectReply(); + } + event.preventDefault(); + } else if (event.code === "KeyD") { + conn.sendDelete(cursor.path); + event.preventDefault(); + } else if (event.code === "KeyA") { + conn.sendAct(cursor.path); event.preventDefault(); } }); From 60c61974fbcac680f11b5be1a455ea29e8ad8a48 Mon Sep 17 00:00:00 2001 From: Joscha Date: Thu, 19 Mar 2020 00:44:40 +0000 Subject: [PATCH 22/27] [tui] Move cursor to newly created nodes --- forest-tui/src/Forest/Client/UiState.hs | 125 +++++++++++++++++------- 1 file changed, 91 insertions(+), 34 deletions(-) diff --git a/forest-tui/src/Forest/Client/UiState.hs b/forest-tui/src/Forest/Client/UiState.hs index d6dff76..4531b45 100644 --- a/forest-tui/src/Forest/Client/UiState.hs +++ b/forest-tui/src/Forest/Client/UiState.hs @@ -45,6 +45,7 @@ import Forest.Client.Widgets.NodeEditor import Forest.Client.Widgets.WidgetTree import Forest.Node import qualified Forest.OrderedMap as OMap +import Forest.Util data EditorInfo n = EditorInfo { eiEditor :: !(NodeEditor n) @@ -52,9 +53,22 @@ data EditorInfo n = EditorInfo , eiReply :: !Bool } deriving (Show) +-- | This type is used to move the cursor to a node that is expected to appear +-- soon. For example, if the user creates a new node by replying, the cursor +-- should move to this new node as soon as it appears (unless the cursor has +-- been moved in-between). +data FocusTarget = FocusTarget + { ftPath :: !Path + -- ^ The node relative to which the target is set + , ftChild :: !Bool + -- ^ If this is 'True', the target points towards the node's first child. If + -- it is 'False', the target points towards the node's next sibling. + } deriving (Show) + data UiState n = UiState { uiRootNode :: !Node , uiFocused :: !Path + , uiTarget :: !(Maybe FocusTarget) , uiUnfolded :: !Unfolded , uiEditor :: !(Maybe (EditorInfo n)) , uiEditorName :: !n @@ -64,6 +78,7 @@ newUiState :: n -> Node -> UiState n newUiState editorName node = UiState { uiRootNode = node , uiFocused = mempty + , uiTarget = Nothing , uiUnfolded = mempty , uiEditor = Nothing , uiEditorName = editorName @@ -77,6 +92,9 @@ getFocusedNode s = fromMaybe rootNode $ applyPath (uiFocused s) rootNode where rootNode = uiRootNode s +foldedRootNode :: UiState n -> Node +foldedRootNode s = applyFolds (uiUnfolded s) (uiRootNode s) + {- Modifying -} -- | Only keep those unfolded nodes that actually exist. @@ -84,6 +102,25 @@ validateUnfolded :: UiState n -> UiState n validateUnfolded s = s {uiUnfolded = Set.filter (referencedNodeExists $ uiRootNode s) (uiUnfolded s)} +-- | Try to apply the focus target if it is set and the corresponding node is +-- visible. Does not modify the UI state otherwise. +-- +-- The plan is that this does not behave in an unexpected way. It definitely +-- should not move the cursor around if the user does not expect it, because +-- that would be annoying. +-- +-- One scenario this tries to avoid: The targeted node exists but is not +-- visible. The cursor is moved to the target node, and since it is not visible, +-- 'moveToValidParent' moves it upwards to the first visible parent. This causes +-- the cursor to jump weirdly and without explanation. +moveToTarget :: UiState n -> UiState n +moveToTarget s = fromMaybe s $ do + target <- uiTarget s + let s' = s{uiFocused = ftPath target, uiTarget = Nothing} + pure $ if ftChild target + then moveFocusToFirstChild s' + else moveFocusToNextSibling s' + -- | Try to find the closest parent to a 'Path' that exists in the 'Node'. findValidParent :: Node -> Path -> Path findValidParent _ (Path []) = Path [] @@ -91,11 +128,16 @@ 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. +-- | Move to the closest valid parent as a last-ditch effort if the current +-- focus path becomes invalid. +moveToValidParent :: UiState n -> UiState n +moveToValidParent s = + s{uiFocused = findValidParent (foldedRootNode s) (uiFocused s)} + +-- | Modify the focused path so it always points to an existing node. Apply the +-- focus target if possible. validateFocused :: UiState n -> UiState n -validateFocused s = - let foldedRootNode = applyFolds (uiUnfolded s) (uiRootNode s) - in s {uiFocused = findValidParent foldedRootNode $ uiFocused s} +validateFocused = moveToValidParent . moveToTarget -- | Close the editor if it doesn't point to a valid path. validateEditor :: UiState n -> UiState n @@ -114,7 +156,8 @@ validate :: UiState n -> UiState n validate = validateEditor . validateFocused . validateUnfolded replaceRootNode :: Node -> UiState n -> UiState n -replaceRootNode node s = validate s { uiRootNode = node +replaceRootNode node s = validate s + { uiRootNode = node , uiFocused = findNextValidNode (uiRootNode s) node (uiFocused s) } @@ -139,9 +182,10 @@ findNextValidNode from to (Path (x:xs)) = fromMaybe (Path []) $ do | otherwise = Just $ last list 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} +moveFocus f s = validateFocused s + { uiFocused = f (foldedRootNode s) (uiFocused s) + , uiTarget = Nothing + } moveFocusUp :: UiState n -> UiState n moveFocusUp = moveFocus findPrevNode @@ -175,11 +219,22 @@ moveFocusToFirstSibling = moveFocusToSibling headMay moveFocusToLastSibling :: UiState n -> UiState n moveFocusToLastSibling = moveFocusToSibling lastMay +moveFocusToNextSibling :: UiState n -> UiState n +moveFocusToNextSibling s = fromMaybe s $ do + (_, nodeId) <- splitInitLast $ uiFocused s + pure $ moveFocusToSibling (findNext (==nodeId)) s + foldAtFocus :: UiState n -> UiState n -foldAtFocus s = validateUnfolded $ s {uiUnfolded = Set.delete (uiFocused s) (uiUnfolded s)} +foldAtFocus s = validateUnfolded s + { uiUnfolded = Set.delete (uiFocused s) (uiUnfolded s) + , uiTarget = Nothing + } unfoldAtFocus :: UiState n -> UiState n -unfoldAtFocus s = validateUnfolded $ s {uiUnfolded = Set.insert (uiFocused s) (uiUnfolded s)} +unfoldAtFocus s = validateUnfolded s + { uiUnfolded = Set.insert (uiFocused s) (uiUnfolded s) + , uiTarget = Nothing + } toggleFoldAtFocus :: UiState n -> UiState n toggleFoldAtFocus s = if uiFocused s `Set.member` uiUnfolded s @@ -194,7 +249,7 @@ editNode reply path s = , eiPath = path , eiReply = reply } - in validateEditor $ s {uiEditor = Just editorInfo} + in validateEditor s{uiEditor = Just editorInfo, uiTarget = Nothing} -- | Begin editing the currently focused node. Discards any current editor -- status. @@ -203,20 +258,18 @@ 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 +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 $ moveFocusToLastSibling 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 @@ -230,16 +283,23 @@ data EditResult = EditResult , erReply :: Bool } deriving (Show) +findTarget :: EditorInfo n -> UiState n -> FocusTarget +findTarget e s = fromMaybe (FocusTarget (eiPath e) (eiReply e)) $ do + node <- applyPath (eiPath e) (uiRootNode s) + lastChildId <- lastMay $ OMap.keys $ nodeChildren node + let path = eiPath e <> Path [lastChildId] + pure $ FocusTarget path False + 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) +finishEditing s = fromMaybe (s, Nothing) $ do + e <- uiEditor s + let editResult = EditResult + { erText = getCurrentText $ eiEditor e + , erPath = eiPath e + , erReply = eiReply e + } + s' = (abortEditing s){uiTarget = Just $ findTarget e s} + pure (s', Just editResult) abortEditing :: UiState n -> UiState n abortEditing s = s {uiEditor = Nothing} @@ -276,18 +336,15 @@ renderNode focused 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 -> + Just e | path == eiPath 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 + in if eiReply e + then WidgetTree renderedNode $ children ++ [WidgetTree renderedEditor []] + else WidgetTree renderedEditor children + _ -> WidgetTree renderedNode children where + isFocused = path == uiFocused s + renderedNode = renderNode isFocused node children = fromMaybe [] maybeChildren renderUiState :: (Ord n, Show n) => IndentOptions -> UiState n -> Widget n From 68b1129a49b9857c688840822b2cc1b21d232dd9 Mon Sep 17 00:00:00 2001 From: Joscha Date: Thu, 19 Mar 2020 19:07:53 +0000 Subject: [PATCH 23/27] [common] Clean up node module and add some useful functions --- forest-common/forest-common.cabal | 1 + forest-common/package.yaml | 1 + forest-common/src/Forest/Node.hs | 130 ++++++++++++++++++----- forest-tui/src/Forest/Client/NodeUtil.hs | 9 -- forest-tui/src/Forest/Client/UiState.hs | 15 +-- 5 files changed, 116 insertions(+), 40 deletions(-) diff --git a/forest-common/forest-common.cabal b/forest-common/forest-common.cabal index b888552..80b2f04 100644 --- a/forest-common/forest-common.cabal +++ b/forest-common/forest-common.cabal @@ -39,6 +39,7 @@ library , async , base >=4.7 && <5 , containers + , safe , text , websockets default-language: Haskell2010 diff --git a/forest-common/package.yaml b/forest-common/package.yaml index cc74cc9..b49c2d7 100644 --- a/forest-common/package.yaml +++ b/forest-common/package.yaml @@ -16,6 +16,7 @@ dependencies: - aeson - async - containers + - safe - text - websockets diff --git a/forest-common/src/Forest/Node.hs b/forest-common/src/Forest/Node.hs index b78a70a..d30ebb1 100644 --- a/forest-common/src/Forest/Node.hs +++ b/forest-common/src/Forest/Node.hs @@ -2,7 +2,9 @@ {-# LANGUAGE OverloadedStrings #-} module Forest.Node - ( NodeId + ( + -- * Nodes + NodeId , enumerateIds , findUnusedId , NodeFlags(..) @@ -11,14 +13,27 @@ module Forest.Node , newNode , txtNode , hasChildren - , mapChildren + , diffNodes + , flatten + -- ** Traversing the tree , applyId , applyPath + , firstChild + , lastChild + , firstSibling + , prevSibling + , nextSibling + , lastSibling + , firstNode + , prevNode + , nextNode + , lastNode + -- ** Modifying at a path , adjustAt , replaceAt , deleteAt , appendAt - , diffNodes + -- * Paths , Path(..) , referencedNodeExists , splitHeadTail @@ -34,14 +49,21 @@ import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Set as Set import qualified Data.Text as T +import Safe import qualified Forest.OrderedMap as OMap +import Forest.Util + +{- Nodes -} type NodeId = T.Text +-- | An infinite list of 'NodeId's. Does *not* contain every possible 'NodeId'. enumerateIds :: [NodeId] enumerateIds = map (T.pack . show) [(0::Integer)..] +-- | Find a 'NodeId' that is not contained in the given set of IDs. Returns the +-- first matching ID from 'enumerateIds'. findUnusedId :: Set.Set NodeId -> NodeId findUnusedId usedIds = head $ filter (\nid -> not $ nid `Set.member` usedIds) enumerateIds @@ -140,14 +162,87 @@ txtNode flags text = newNode flags text [] hasChildren :: Node -> Bool hasChildren = not . OMap.null . nodeChildren -mapChildren :: (NodeId -> Node -> a) -> Node -> [a] -mapChildren f = map (uncurry f) . OMap.toList . nodeChildren +diffNodes :: Node -> Node -> Maybe (Path, Node) +diffNodes a b + | nodesDiffer || childrenChanged = Just (Path [], b) + | otherwise = case differingChildren of + [] -> Nothing + [(x, Path xs, node)] -> Just (Path (x:xs), node) + _ -> Just (Path [], b) + where + nodesDiffer = nodeText a /= nodeText b || nodeFlags a /= nodeFlags b + aChildren = nodeChildren a + bChildren = nodeChildren b + childrenChanged = OMap.keys aChildren /= OMap.keys bChildren + diffedChildren = Map.toList $ Map.intersectionWith diffNodes (OMap.toMap aChildren) (OMap.toMap bChildren) + differingChildren = [(key, path, node) | (key, Just (path, node)) <- diffedChildren] -applyId :: NodeId -> Node -> Maybe Node -applyId nid node = nodeChildren node OMap.!? nid +-- | Return the 'Path's to a node and its subnodes in the order they would be +-- displayed in. +flatten :: Node -> [Path] +flatten node = Path [] : flattenedChildren + where + flattenChild nid n = map (Path [nid] <>) (flatten n) + flattenedChildren = + concat $ OMap.elems $ OMap.mapWithKey flattenChild $ nodeChildren node -applyPath :: Path -> Node -> Maybe Node -applyPath (Path ids) node = foldM (flip applyId) node ids +{- Traversing the tree -} + +applyId :: Node -> NodeId -> Maybe Node +applyId node nid = nodeChildren node OMap.!? nid + +applyPath :: Node -> Path -> Maybe Node +applyPath node (Path ids) = foldM applyId node ids + +getChild :: ([NodeId] -> Maybe NodeId) -> Node -> Path -> Maybe Path +getChild f root path = do + node <- applyPath root path + let childIds = OMap.keys $ nodeChildren node + childId <- f childIds + pure $ path <> Path [childId] + +firstChild :: Node -> Path -> Maybe Path +firstChild = getChild headMay + +lastChild :: Node -> Path -> Maybe Path +lastChild = getChild lastMay + +getSibling :: (NodeId -> [NodeId] -> Maybe NodeId) -> Node -> Path -> Maybe Path +getSibling f root path = do + (parentPath, nodeId) <- splitInitLast path + parentNode <- applyPath root parentPath + let siblingIds = OMap.keys $ nodeChildren parentNode + siblingId <- f nodeId siblingIds + pure $ parentPath <> Path [siblingId] + +firstSibling :: Node -> Path -> Maybe Path +firstSibling = getSibling $ const headMay + +prevSibling :: Node -> Path -> Maybe Path +prevSibling = getSibling $ findPrev . (==) + +nextSibling :: Node -> Path -> Maybe Path +nextSibling = getSibling $ findNext . (==) + +lastSibling :: Node -> Path -> Maybe Path +lastSibling = getSibling $ const lastMay + +getNode :: (Path -> [Path] -> Maybe Path) -> Node -> Path -> Maybe Path +getNode f root path = f path $ flatten root + +firstNode :: Node -> Path -> Maybe Path +firstNode = getNode $ const headMay + +prevNode :: Node -> Path -> Maybe Path +prevNode = getNode $ findPrev . (==) + +nextNode :: Node -> Path -> Maybe Path +nextNode = getNode $ findNext . (==) + +lastNode :: Node -> Path -> Maybe Path +lastNode = getNode $ const lastMay + +{- Modifying at a path -} adjustAt :: (Node -> Node) -> Path -> Node -> Node adjustAt f (Path []) node = f node @@ -176,27 +271,14 @@ appendAt node = let nid = findUnusedId $ OMap.keysSet m in OMap.append nid node m -diffNodes :: Node -> Node -> Maybe (Path, Node) -diffNodes a b - | nodesDiffer || childrenChanged = Just (Path [], b) - | otherwise = case differingChildren of - [] -> Nothing - [(x, Path xs, node)] -> Just (Path (x:xs), node) - _ -> Just (Path [], b) - where - nodesDiffer = nodeText a /= nodeText b || nodeFlags a /= nodeFlags b - aChildren = nodeChildren a - bChildren = nodeChildren b - childrenChanged = OMap.keys aChildren /= OMap.keys bChildren - diffedChildren = Map.toList $ Map.intersectionWith diffNodes (OMap.toMap aChildren) (OMap.toMap bChildren) - differingChildren = [(key, path, node) | (key, Just (path, node)) <- diffedChildren] +{- Paths -} newtype Path = Path { pathElements :: [NodeId] } deriving (Show, Eq, Ord, Semigroup, Monoid, ToJSON, FromJSON) referencedNodeExists :: Node -> Path -> Bool -referencedNodeExists node path = isJust $ applyPath path node +referencedNodeExists node path = isJust $ applyPath node path splitHeadTail :: Path -> Maybe (NodeId, Path) splitHeadTail (Path []) = Nothing diff --git a/forest-tui/src/Forest/Client/NodeUtil.hs b/forest-tui/src/Forest/Client/NodeUtil.hs index 1f0c031..3712e83 100644 --- a/forest-tui/src/Forest/Client/NodeUtil.hs +++ b/forest-tui/src/Forest/Client/NodeUtil.hs @@ -2,7 +2,6 @@ module Forest.Client.NodeUtil ( Unfolded , foldVisibleNodes , applyFolds - , flatten , findPrevNode , findNextNode ) where @@ -41,14 +40,6 @@ applyFolds unfolded node 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 diff --git a/forest-tui/src/Forest/Client/UiState.hs b/forest-tui/src/Forest/Client/UiState.hs index 4531b45..28ae335 100644 --- a/forest-tui/src/Forest/Client/UiState.hs +++ b/forest-tui/src/Forest/Client/UiState.hs @@ -88,7 +88,7 @@ getFocusedPath :: UiState n -> Path getFocusedPath = uiFocused getFocusedNode :: UiState n -> Node -getFocusedNode s = fromMaybe rootNode $ applyPath (uiFocused s) rootNode +getFocusedNode s = fromMaybe rootNode $ applyPath rootNode $ uiFocused s where rootNode = uiRootNode s @@ -124,7 +124,7 @@ moveToTarget s = fromMaybe s $ do -- | 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 +findValidParent node (Path (x:xs)) = case applyId node x of Nothing -> Path [] Just child -> Path [x] <> findValidParent child (Path xs) @@ -144,7 +144,7 @@ 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) + node <- applyPath (uiRootNode s) (eiPath e) let flags = nodeFlags node pure $ if eiReply e then flagReply flags else flagEdit flags where @@ -166,8 +166,8 @@ replaceRootNode node s = validate s findNextValidNode :: Node -> Node -> Path -> Path findNextValidNode _ _ (Path []) = Path [] findNextValidNode from to (Path (x:xs)) = fromMaybe (Path []) $ do - fromNode <- applyId x from - case applyId x to of + fromNode <- applyId from x + case applyId to x of Just toNode -> pure $ Path [x] <> findNextValidNode fromNode toNode (Path xs) Nothing -> do fromIdx <- elemIndex x $ OMap.keys $ nodeChildren from @@ -198,7 +198,7 @@ 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 + siblings <- nodeChildren <$> applyPath node focused firstSiblingName <- f $ OMap.keys siblings pure $ focused <> Path [firstSiblingName] @@ -283,9 +283,10 @@ data EditResult = EditResult , erReply :: Bool } deriving (Show) +-- TODO use new functions from the node module findTarget :: EditorInfo n -> UiState n -> FocusTarget findTarget e s = fromMaybe (FocusTarget (eiPath e) (eiReply e)) $ do - node <- applyPath (eiPath e) (uiRootNode s) + node <- applyPath (uiRootNode s) (eiPath e) lastChildId <- lastMay $ OMap.keys $ nodeChildren node let path = eiPath e <> Path [lastChildId] pure $ FocusTarget path False From c2b4a23542fae372765dc3d18e8720f8d317f7e8 Mon Sep 17 00:00:00 2001 From: Joscha Date: Thu, 19 Mar 2020 21:38:41 +0000 Subject: [PATCH 24/27] [tui] Clean up the UI state --- forest-tui/src/Forest/Client.hs | 10 +- forest-tui/src/Forest/Client/UiState.hs | 194 +++++++----------------- 2 files changed, 61 insertions(+), 143 deletions(-) diff --git a/forest-tui/src/Forest/Client.hs b/forest-tui/src/Forest/Client.hs index c621828..faa9155 100644 --- a/forest-tui/src/Forest/Client.hs +++ b/forest-tui/src/Forest/Client.hs @@ -63,14 +63,14 @@ onKeyWithoutEditor cs (Vty.EvKey k _) | 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) + when (flagDelete $ nodeFlags $ focusedNode $ csUiState cs) $ + liftIO $ sendPacket (csConn cs) $ ClientDelete (focusedPath $ 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) + when (flagAct $ nodeFlags $ focusedNode $ csUiState cs) $ + liftIO $ sendPacket (csConn cs) $ ClientAct (focusedPath $ csUiState cs) continue cs where quitKeys = [Vty.KChar 'q', Vty.KEsc] @@ -80,7 +80,7 @@ onKeyWithoutEditor cs (Vty.EvKey k _) editKeys = [Vty.KChar 'e'] deleteKeys = [Vty.KChar 'd'] replyKeys = [Vty.KChar 'r'] - replyKeys' = [Vty.KChar 'R'] + replyKeys' = [Vty.KChar 'R'] actKeys = [Vty.KChar 'a', Vty.KChar ' ', Vty.KEnter] onKeyWithoutEditor cs _ = continue cs diff --git a/forest-tui/src/Forest/Client/UiState.hs b/forest-tui/src/Forest/Client/UiState.hs index 28ae335..46d9746 100644 --- a/forest-tui/src/Forest/Client/UiState.hs +++ b/forest-tui/src/Forest/Client/UiState.hs @@ -3,16 +3,12 @@ module Forest.Client.UiState ( UiState , newUiState - , getFocusedPath - , getFocusedNode + , focusedPath + , focusedNode -- * Modifying the UI state , replaceRootNode , moveFocusUp , moveFocusDown - , moveFocusToFirstChild - , moveFocusToLastChild - , moveFocusToFirstSibling - , moveFocusToLastSibling , foldAtFocus , unfoldAtFocus , toggleFoldAtFocus @@ -33,19 +29,18 @@ module Forest.Client.UiState ) where import Brick +import Control.Monad import Data.List 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.NodeUtil import Forest.Client.Widgets.NodeEditor import Forest.Client.Widgets.WidgetTree import Forest.Node import qualified Forest.OrderedMap as OMap -import Forest.Util data EditorInfo n = EditorInfo { eiEditor :: !(NodeEditor n) @@ -53,22 +48,9 @@ data EditorInfo n = EditorInfo , eiReply :: !Bool } deriving (Show) --- | This type is used to move the cursor to a node that is expected to appear --- soon. For example, if the user creates a new node by replying, the cursor --- should move to this new node as soon as it appears (unless the cursor has --- been moved in-between). -data FocusTarget = FocusTarget - { ftPath :: !Path - -- ^ The node relative to which the target is set - , ftChild :: !Bool - -- ^ If this is 'True', the target points towards the node's first child. If - -- it is 'False', the target points towards the node's next sibling. - } deriving (Show) - data UiState n = UiState { uiRootNode :: !Node , uiFocused :: !Path - , uiTarget :: !(Maybe FocusTarget) , uiUnfolded :: !Unfolded , uiEditor :: !(Maybe (EditorInfo n)) , uiEditorName :: !n @@ -78,17 +60,16 @@ newUiState :: n -> Node -> UiState n newUiState editorName node = UiState { uiRootNode = node , uiFocused = mempty - , uiTarget = Nothing , uiUnfolded = mempty , uiEditor = Nothing , uiEditorName = editorName } -getFocusedPath :: UiState n -> Path -getFocusedPath = uiFocused +focusedPath :: UiState n -> Path +focusedPath = uiFocused -getFocusedNode :: UiState n -> Node -getFocusedNode s = fromMaybe rootNode $ applyPath rootNode $ uiFocused s +focusedNode :: UiState n -> Node +focusedNode s = fromMaybe rootNode $ applyPath rootNode $ uiFocused s where rootNode = uiRootNode s @@ -102,25 +83,6 @@ validateUnfolded :: UiState n -> UiState n validateUnfolded s = s {uiUnfolded = Set.filter (referencedNodeExists $ uiRootNode s) (uiUnfolded s)} --- | Try to apply the focus target if it is set and the corresponding node is --- visible. Does not modify the UI state otherwise. --- --- The plan is that this does not behave in an unexpected way. It definitely --- should not move the cursor around if the user does not expect it, because --- that would be annoying. --- --- One scenario this tries to avoid: The targeted node exists but is not --- visible. The cursor is moved to the target node, and since it is not visible, --- 'moveToValidParent' moves it upwards to the first visible parent. This causes --- the cursor to jump weirdly and without explanation. -moveToTarget :: UiState n -> UiState n -moveToTarget s = fromMaybe s $ do - target <- uiTarget s - let s' = s{uiFocused = ftPath target, uiTarget = Nothing} - pure $ if ftChild target - then moveFocusToFirstChild s' - else moveFocusToNextSibling s' - -- | Try to find the closest parent to a 'Path' that exists in the 'Node'. findValidParent :: Node -> Path -> Path findValidParent _ (Path []) = Path [] @@ -129,38 +91,24 @@ findValidParent node (Path (x:xs)) = case applyId node x of Just child -> Path [x] <> findValidParent child (Path xs) -- | Move to the closest valid parent as a last-ditch effort if the current --- focus path becomes invalid. -moveToValidParent :: UiState n -> UiState n -moveToValidParent s = - s{uiFocused = findValidParent (foldedRootNode s) (uiFocused s)} - --- | Modify the focused path so it always points to an existing node. Apply the --- focus target if possible. +-- focus path is invalid. validateFocused :: UiState n -> UiState n -validateFocused = moveToValidParent . moveToTarget +validateFocused s = + s {uiFocused = findValidParent (foldedRootNode s) (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 (uiRootNode s) (eiPath e) - let flags = nodeFlags node - pure $ if eiReply e then flagReply flags else flagEdit flags - where - keepEditor True = s - keepEditor False = s {uiEditor = Nothing} +validateEditor s = fromMaybe s{uiEditor = Nothing} $ do + e <- uiEditor s + node <- applyPath (uiRootNode s) (eiPath e) + let flags = nodeFlags node + guard $ if eiReply e then flagReply flags else flagEdit flags + pure s -- | 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 - , uiFocused = findNextValidNode (uiRootNode s) node (uiFocused s) - } - -- | Find a node that is close to the previously focused node, taking into -- account its previous position in the tree. findNextValidNode :: Node -> Node -> Path -> Path @@ -181,60 +129,30 @@ findNextValidNode from to (Path (x:xs)) = fromMaybe (Path []) $ do | null list = Nothing | otherwise = Just $ last list -moveFocus :: (Node -> Path -> Path) -> UiState n -> UiState n -moveFocus f s = validateFocused s - { uiFocused = f (foldedRootNode s) (uiFocused s) - , uiTarget = Nothing +replaceRootNode :: Node -> UiState n -> UiState n +replaceRootNode node s = validate s + { uiRootNode = node + , uiFocused = findNextValidNode (uiRootNode s) node (uiFocused s) } +moveFocus :: (Node -> Path -> Maybe Path) -> UiState n -> UiState n +moveFocus f s = fromMaybe s $ do + newFocus <- f (foldedRootNode s) (uiFocused s) + pure $ validateFocused s{uiFocused = newFocus} + moveFocusUp :: UiState n -> UiState n -moveFocusUp = moveFocus findPrevNode +moveFocusUp = moveFocus prevNode 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 node focused - 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 - -moveFocusToNextSibling :: UiState n -> UiState n -moveFocusToNextSibling s = fromMaybe s $ do - (_, nodeId) <- splitInitLast $ uiFocused s - pure $ moveFocusToSibling (findNext (==nodeId)) s +moveFocusDown = moveFocus nextNode foldAtFocus :: UiState n -> UiState n -foldAtFocus s = validateUnfolded s - { uiUnfolded = Set.delete (uiFocused s) (uiUnfolded s) - , uiTarget = Nothing - } +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) - , uiTarget = Nothing - } +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 @@ -243,13 +161,13 @@ toggleFoldAtFocus s = if uiFocused s `Set.member` uiUnfolded s editNode :: Bool -> Path -> UiState n -> UiState n editNode reply path s = - let text = if reply then "" else nodeText $ getFocusedNode s + let text = if reply then "" else nodeText $ focusedNode s editorInfo = EditorInfo { eiEditor = beginEdit (uiEditorName s) text , eiPath = path , eiReply = reply } - in validateEditor s{uiEditor = Just editorInfo, uiTarget = Nothing} + in validateEditor s{uiEditor = Just editorInfo} -- | Begin editing the currently focused node. Discards any current editor -- status. @@ -283,14 +201,6 @@ data EditResult = EditResult , erReply :: Bool } deriving (Show) --- TODO use new functions from the node module -findTarget :: EditorInfo n -> UiState n -> FocusTarget -findTarget e s = fromMaybe (FocusTarget (eiPath e) (eiReply e)) $ do - node <- applyPath (uiRootNode s) (eiPath e) - lastChildId <- lastMay $ OMap.keys $ nodeChildren node - let path = eiPath e <> Path [lastChildId] - pure $ FocusTarget path False - finishEditing :: UiState n -> (UiState n, Maybe EditResult) finishEditing s = fromMaybe (s, Nothing) $ do e <- uiEditor s @@ -299,21 +209,20 @@ finishEditing s = fromMaybe (s, Nothing) $ do , erPath = eiPath e , erReply = eiReply e } - s' = (abortEditing s){uiTarget = Just $ findTarget e s} - pure (s', Just editResult) + pure (abortEditing s, Just editResult) abortEditing :: UiState n -> UiState n -abortEditing s = s {uiEditor = Nothing} +abortEditing s = s{uiEditor = Nothing} {- Rendering -} decorateExpand :: Bool -> Widget n -> Widget n -decorateExpand True widget = withDefAttr "expand" widget -decorateExpand False widget = withDefAttr "noexpand" widget +decorateExpand True = withDefAttr "expand" +decorateExpand False = id decorateFocus :: Bool -> Widget n -> Widget n -decorateFocus True widget = visible $ withDefAttr "focus" widget -decorateFocus False widget = withDefAttr "nofocus" widget +decorateFocus True = withDefAttr "focus" +decorateFocus False = id decorateFlags :: NodeFlags -> Widget n -> Widget n decorateFlags node widget = @@ -328,24 +237,33 @@ renderNode :: Bool -> Node -> Widget n renderNode focused node = decorateFlags (nodeFlags node) $ decorateFocus focused $ - decorateExpand (not $ OMap.null $ nodeChildren node) $ - padRight Max $ txtWrap text + decorateExpand (hasChildren node) $ + padRight Max text where + -- The height of the text widget must be at least 1 for 'padRight Max' to + -- expand it. As far as I know, if the text has at least one character, it + -- also has a height of at least 1, but if it has no characters, its height + -- is 0. Because of that, we insert a filler space if the text is empty. text - | T.null $ nodeText node = " " - | otherwise = nodeText node + | T.null $ nodeText node = txt " " + | otherwise = txtWrap $ nodeText node -nodeToTree :: (Ord n, Show n) => UiState n -> Path -> Node -> Maybe [WidgetTree n] -> WidgetTree n +nodeToTree + :: (Ord n, Show n) + => UiState n + -> Path + -> Node + -> Maybe [WidgetTree n] + -> WidgetTree n nodeToTree s path node maybeChildren = case uiEditor s of Just e | path == eiPath e -> let renderedEditor = renderNodeEditor $ eiEditor e in if eiReply e then WidgetTree renderedNode $ children ++ [WidgetTree renderedEditor []] else WidgetTree renderedEditor children - _ -> WidgetTree renderedNode children + _ -> WidgetTree (visible renderedNode) children where - isFocused = path == uiFocused s - renderedNode = renderNode isFocused node + renderedNode = renderNode (path == uiFocused s) node children = fromMaybe [] maybeChildren renderUiState :: (Ord n, Show n) => IndentOptions -> UiState n -> Widget n From 53b4b2c9a007fe25340f8f39639ec513f242bea0 Mon Sep 17 00:00:00 2001 From: Joscha Date: Fri, 20 Mar 2020 00:25:39 +0000 Subject: [PATCH 25/27] [tui] Clean up and add more key bindings --- forest-tui/src/Forest/Client.hs | 64 ++++++++++++++----------- forest-tui/src/Forest/Client/UiState.hs | 20 ++++++++ 2 files changed, 55 insertions(+), 29 deletions(-) diff --git a/forest-tui/src/Forest/Client.hs b/forest-tui/src/Forest/Client.hs index faa9155..8f7bacd 100644 --- a/forest-tui/src/Forest/Client.hs +++ b/forest-tui/src/Forest/Client.hs @@ -55,33 +55,39 @@ onUiState' cs f = do {- ... without active editor -} +deleteNode :: ClientState -> ClientM () +deleteNode cs = + when (flagDelete $ nodeFlags $ focusedNode s) $ + liftIO $ sendPacket (csConn cs) $ ClientDelete (focusedPath s) + where + s = csUiState cs + +actUponNode :: ClientState -> ClientM () +actUponNode cs = + when (flagAct $ nodeFlags $ focusedNode s) $ + liftIO $ sendPacket (csConn cs) $ ClientAct (focusedPath s) + where + s = csUiState cs + 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 $ focusedNode $ csUiState cs) $ - liftIO $ sendPacket (csConn cs) $ ClientDelete (focusedPath $ csUiState cs) - continue cs - | k `elem` replyKeys = onUiState cs (replyToCurrentNode . unfoldAtFocus) - | k `elem` replyKeys' = onUiState cs replyAfterCurrentNode - | k `elem` actKeys = do - when (flagAct $ nodeFlags $ focusedNode $ csUiState cs) $ - liftIO $ sendPacket (csConn cs) $ ClientAct (focusedPath $ 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] + | k `elem` [Vty.KChar 'q', Vty.KEsc] = halt cs + | k == Vty.KChar '\t' = onUiState cs toggleFoldAtFocus + | k `elem` [Vty.KChar 'k', Vty.KUp] = onUiState cs moveFocusUp + | k `elem` [Vty.KChar 'j', Vty.KDown] = onUiState cs moveFocusDown + | k `elem` [Vty.KChar 'K', Vty.KPageUp] = onUiState cs moveFocusToPrevSibling + | k `elem` [Vty.KChar 'J', Vty.KPageDown] = + onUiState cs moveFocusToNextSibling + | k `elem` [Vty.KChar 'h', Vty.KLeft] = onUiState cs moveFocusToParent + | k `elem` [Vty.KChar 'g', Vty.KHome] = onUiState cs moveFocusToTop + | k `elem` [Vty.KChar 'G', Vty.KEnd] = onUiState cs moveFocusToBottom + | k == Vty.KChar 'e' = onUiState cs editCurrentNode + | k == Vty.KChar 'r' = onUiState cs (replyToCurrentNode . unfoldAtFocus) + | k == Vty.KChar 'R' = onUiState cs replyAfterCurrentNode + | k `elem` [Vty.KChar 'd', Vty.KChar 'x', Vty.KDel, Vty.KBS] = + deleteNode cs *> continue cs + | k `elem` [Vty.KChar 'a', Vty.KChar ' ', Vty.KEnter] = + actUponNode cs *> continue cs onKeyWithoutEditor cs _ = continue cs {- ... with active editor -} @@ -134,11 +140,11 @@ clientAttrMap = attrMap Vty.defAttr clientApp :: App ClientState Event ResourceName clientApp = App - { appDraw = clientDraw + { appDraw = clientDraw , appChooseCursor = showFirstCursor - , appHandleEvent = clientHandleEvent - , appStartEvent = pure - , appAttrMap = const clientAttrMap + , appHandleEvent = clientHandleEvent + , appStartEvent = pure + , appAttrMap = const clientAttrMap } runClient :: WS.Connection -> BChan Event -> Node -> IO () diff --git a/forest-tui/src/Forest/Client/UiState.hs b/forest-tui/src/Forest/Client/UiState.hs index 46d9746..2f4ac86 100644 --- a/forest-tui/src/Forest/Client/UiState.hs +++ b/forest-tui/src/Forest/Client/UiState.hs @@ -9,6 +9,11 @@ module Forest.Client.UiState , replaceRootNode , moveFocusUp , moveFocusDown + , moveFocusToParent + , moveFocusToPrevSibling + , moveFocusToNextSibling + , moveFocusToTop + , moveFocusToBottom , foldAtFocus , unfoldAtFocus , toggleFoldAtFocus @@ -146,6 +151,21 @@ moveFocusUp = moveFocus prevNode moveFocusDown :: UiState n -> UiState n moveFocusDown = moveFocus nextNode +moveFocusToPrevSibling :: UiState n -> UiState n +moveFocusToPrevSibling = moveFocus prevSibling + +moveFocusToNextSibling :: UiState n -> UiState n +moveFocusToNextSibling = moveFocus nextSibling + +moveFocusToParent :: UiState n -> UiState n +moveFocusToParent = moveFocus $ const parent + +moveFocusToTop :: UiState n -> UiState n +moveFocusToTop = moveFocus firstNode + +moveFocusToBottom :: UiState n -> UiState n +moveFocusToBottom = moveFocus lastNode + foldAtFocus :: UiState n -> UiState n foldAtFocus s = validateUnfolded s{uiUnfolded = Set.delete (uiFocused s) (uiUnfolded s)} From a3ed8012b2df69ad6543971470c353141592e8ad Mon Sep 17 00:00:00 2001 From: Joscha Date: Fri, 20 Mar 2020 21:18:39 +0000 Subject: [PATCH 26/27] [web] Fix editor line sometimes not being curved --- forest-web/node.css | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/forest-web/node.css b/forest-web/node.css index d19ee56..7fdefee 100644 --- a/forest-web/node.css +++ b/forest-web/node.css @@ -58,7 +58,7 @@ } /* Curvy lines */ -.curvy .node:last-child::before { +.curvy .node-children > *:last-child, .curvy .node-children > *:last-child::before { border-bottom-left-radius: 6px; } From 3f8057490f5864d98f672e7be60947c174f8cf33 Mon Sep 17 00:00:00 2001 From: Joscha Date: Fri, 19 Jun 2020 13:51:59 +0000 Subject: [PATCH 27/27] Commit unstaged changes Coming back to this project after a while, these changes were still unstaged. In order not to lose them I'm committing them here, even though I don't remember what they're for. They might not even work properly. --- forest-web/node.js | 355 ++++++++++++++++++++++++++++++--------------- 1 file changed, 239 insertions(+), 116 deletions(-) diff --git a/forest-web/node.js b/forest-web/node.js index a374cd7..b276399 100644 --- a/forest-web/node.js +++ b/forest-web/node.js @@ -4,6 +4,12 @@ * Utility functions */ +function removeAllChildren(element) { + while (element.firstChild) { + element.removeChild(element.lastChild); + } +} + // Create a new DOM element. // 'classes' can either be a string or a list of strings. // A child can either be a string or a DOM element. @@ -40,71 +46,132 @@ const RelPos = Object.freeze({ }); class Path { - constructor(...nodeIds) { - this.elements = nodeIds; + constructor(...components) { + this._components = components.slice(); + } + + get components() { + return this._components.slice(); } get length() { - return this.elements.length; + return this._components.length; } get last() { - return this.elements[this.length - 1]; + return this._components[this.length - 1]; } get parent() { if (this.length === 0) return undefined; - return new Path(...this.elements.slice(0, this.length - 1)); + return new Path(...this._components.slice(0, this.length - 1)); } append(nodeId) { - return new Path(...this.elements.concat([nodeId])); + return new Path(...this._components.concat([nodeId])); } concat(otherPath) { - return new Path(...this.elements.concat(otherPath.elements)); + return new Path(...this._components.concat(otherPath._components)); } } class NodeElements { constructor() { - this.text = newElement("span", "node-text"); - this.permissions = newElement("span", "node-permissions"); - this.children = newElement("div", "node-children"); + this._elText = newElement("span", "node-text"); + this._elPermissions = newElement("span", "node-permissions"); + this._elChildren = newElement("div", "node-children"); - let line = newElement("div", "node-line", this.text, this.permissions); - this.main = newElement("div", ["node", "is-folded"], line, this.children); + let line = newElement("div", "node-line", this._elText, this._elPermissions); + this._elMain = newElement("div", ["node", "is-folded"], line, this._elChildren); + } + + get text() { + return this._elText.textContent; + } + + set text(text) { + this._elText.textContent = text; + } + + set permissions(perms) { + this._elPermissions.textContent = perms.asText; + } + + get hasChildren() { + return this._elMain.classList.contains("has-children"); + } + + set hasChildren(flag) { + return this._elMain.classList.toggle("has-children", flag); } removeAllChildren() { - while (this.children.firstChild) { - this.children.removeChild(this.children.lastChild); - } + removeAllChildren(this._elChildren); + } + + addChild(child) { + this._elChildren.appendChild(child._elMain); + } + + appendTo(element) { + element.appendChild(this._elMain); + } + + get folded() { + return this._elMain.classList.contains("is-folded"); + } + + set folded(flag) { + this._elMain.classList.toggle("is-folded", flag); + } + + toggleFolded() { + this.folded = !this.folded; + } + + get hasCursor() { + return this._elMain.classList.contains("has-cursor"); + } + + set hasCursor(flag) { + return this._elMain.classList.toggle("has-cursor", flag); + } + + get hasEditor() { + return this._elMain.classList.contains("has-editor"); + } + + set hasEditor(flag) { + return this._elMain.classList.toggle("has-editor", flag); } } -class Node { - constructor(nodeJson) { - this.elements = undefined; - - this.text = nodeJson.text; - - // Permissions - this.edit = nodeJson.edit; - this.delete = nodeJson.delete; - this.reply = nodeJson.reply; - this.act = nodeJson.act; - - this.children = new Map(); - this.order = nodeJson.order; - this.order.forEach(childId => { - let childJson = nodeJson.children[childId]; - let childNode = new Node(childJson); - this.children.set(childId, childNode); - }); +class NodePermissions { + constructor(edit, delete_, reply, act) { + this._edit = edit; + this._delete = delete_; + this._reply = reply; + this._act = act; } - getPermissionText() { + get edit() { + return this._edit; + } + + get delete() { + return this._delete; + } + + get reply() { + return this._reply; + } + + get act() { + return this._act; + } + + get asText() { return [ "(", this.edit ? "e" : "-", @@ -114,23 +181,44 @@ class Node { ")" ].join(""); } +} - hasChildren() { - return this.order.length > 0; +class Node { + constructor(nodeJson) { + this._el = undefined; + + this._text = nodeJson.text; + + this._permissions = new NodePermissions( + nodeJson.edit, + nodeJson.delete, + nodeJson.reply, + nodeJson.act, + ); + + this._children = new Map(); + this._order = nodeJson.order; + this._order.forEach(childId => { + let childJson = nodeJson.children[childId]; + let childNode = new Node(childJson); + this._children.set(childId, childNode); + }); } - isFolded() { - if (this.elements === undefined) return undefined; - return this.elements.main.classList.contains("is-folded"); + child(childId) { + return this._children.get(childId); } - setFolded(folded) { - if (this.elements === undefined) return; - this.elements.main.classList.toggle("is-folded", folded); + get order() { + return this._order.slice(); } - toggleFolded() { - this.setFolded(!this.isFolded()); + // Only replaces existing children. Does not add new children. + replaceChild(childId, newChild) { + let oldChild = this.child(childId); + if (oldChild === undefined) return; + newChild.obtainElements(oldChild); + this._children.set(childId, newChild); } // Obtain and update this node's DOM elements. After this call, this.el @@ -140,49 +228,87 @@ class Node { // its children already has existing DOM elements, they are repurposed. // Otherwise, new DOM elements are created. obtainElements(oldNode) { - if (this.elements === undefined) { + if (this._el === undefined) { // Obtain DOM elements because we don't yet have any - if (oldNode === undefined || oldNode.elements === undefined) { - this.elements = new NodeElements(); + if (oldNode === undefined || oldNode._el === undefined) { + this._el = new NodeElements(); } else { - this.elements = oldNode.elements; + this._el = oldNode._el; } } - this.elements.text.textContent = this.text; - this.elements.permissions.textContent = this.getPermissionText(); - this.elements.main.classList.toggle("has-children", this.hasChildren()); + this._el.text = this._text; + this._el.permissions = this._permissions; + this._el.hasChildren = this.order.length > 0; - let oldChildren = (oldNode === undefined) ? - new Map() : oldNode.children; + this._el.removeAllChildren(); - this.elements.removeAllChildren(); - this.order.forEach(childId => { + let oldChildren = (oldNode === undefined) ? new Map() : oldNode._children; + this._order.forEach(childId => { let oldChild = oldChildren.get(childId); // May be undefined - let child = this.children.get(childId); + let child = this._children.get(childId); // Not undefined child.obtainElements(oldChild); - this.elements.children.appendChild(child.elements.main); + this._el.addChild(child._el); }); } + + // Wrapper functions for this._el + + appendTo(element) { + if (this._el === undefined) this.obtainElements(); + this._el.appendTo(element); + } + + get folded() { + if (this._el === undefined) return undefined; + return this._el.folded; + } + + set folded(flag) { + if (this._el === undefined) return; + this._el.folded = flag; + } + + toggleFolded() { + if (this._el === undefined) return; + this._el.toggleFolded(); + } + + get hasCursor() { + if (this._el === undefined) return undefined; + return this._el.hasCursor; + } + + set hasCursor(flag) { + if (this._el === undefined) return; + this._el.hasCursor = flag; + } + + get hasEditor() { + if (this._el === undefined) return undefined; + return this._el.hasEditor; + } + + set hasEditor(flag) { + if (this._el === undefined) return; + this._el.hasEditor = flag; + } } class NodeTree { constructor(rootNodeContainer, rootNode) { - this.rootNodeContainer = rootNodeContainer; - this.rootNode = rootNode; + this._rootNodeContainer = rootNodeContainer; + this._rootNode = rootNode; // Prepare root node container - rootNode.obtainElements(); - while (rootNodeContainer.firstChild) { - rootNodeContainer.removeChild(rootNodeContainer.lastChild); - } - rootNodeContainer.appendChild(rootNode.elements.main); + removeAllChildren(this._rootNodeContainer); + this._rootNode.appendTo(this._rootNodeContainer); } at(path) { - let node = this.rootNode; - for (let childId of path.elements) { - node = node.children.get(childId); + let node = this._rootNode; + for (let childId of path.components) { + node = node.child(childId); if (node === undefined) break; } return node; @@ -190,14 +316,11 @@ class NodeTree { updateAt(path, newNode) { if (path.length === 0) { - newNode.obtainElements(this.rootNode); - this.rootNode = newNode; + newNode.obtainElements(this._rootNode); + this._rootNode = newNode; } else { let parentNode = this.at(path.parent); - let oldNode = parentNode.children.get(path.last); - if (oldNode === undefined) return; - newNode.obtainElements(oldNode); - parentNode.children.set(path.last, newNode); + parentNode.replaceChild(path.last, newNode); } } @@ -249,7 +372,7 @@ class NodeTree { // Get last child of previous path while (true) { let prevNode = this.at(prevPath); - if (prevNode.isFolded()) return prevPath; + if (prevNode.folded) return prevPath; let childPath = this.getLastChild(prevPath); if (childPath === undefined) return prevPath; @@ -260,7 +383,7 @@ class NodeTree { getNodeBelow(path) { let node = this.at(path); - if (!node.isFolded()) { + if (!node.folded) { let childPath = this.getFirstChild(path); if (childPath !== undefined) return childPath; } @@ -277,49 +400,49 @@ class NodeTree { class Cursor { constructor(nodeTree) { - this.nodeTree = nodeTree; + this._nodeTree = nodeTree; - this.path = new Path(); - this.relPos = null; // Either null or a RelPos value + this._path = new Path(); + this._relPos = null; // Either null or a RelPos value this.restore(); } getSelectedNode() { - return this.nodeTree.at(this.path); + return this._nodeTree.at(this._path); } _applyRelPos() { - if (this.relPos === null) return; + if (this._relPos === null) return; let newPath; - if (this.relPos === RelPos.FIRST_CHILD) { - newPath = this.nodeTree.getFirstChild(this.path); - } else if (this.relPos === RelPos.NEXT_SIBLING) { - newPath = this.nodeTree.getNextSibling(this.path); + if (this._relPos === RelPos.FIRST_CHILD) { + newPath = this._nodeTree.getFirstChild(this._path); + } else if (this._relPos === RelPos.NEXT_SIBLING) { + newPath = this._nodeTree.getNextSibling(this._path); } if (newPath !== undefined) { - this.path = newPath; - this.relPos = null; + this._path = newPath; + this._relPos = null; } } _moveToNearestValidNode() { // TODO Maybe select a sibling instead of going to nearest visible parent let path = new Path(); - for (let element of this.path.elements) { - let newPath = path.append(element); - let newNode = this.nodeTree.at(newPath); + for (let component of this._path.components) { + let newPath = path.append(component); + let newNode = this._nodeTree.at(newPath); if (newNode === undefined) break; - if (newNode.isFolded()) break; + if (newNode.folded) break; path = newPath; } - this.path = path; + this._path = path; } _set(visible) { - this.getSelectedNode().elements.main.classList.toggle("has-cursor", visible); + this.getSelectedNode().hasCursor = visible; } restore() { @@ -331,56 +454,56 @@ class Cursor { moveTo(path) { if (path === undefined) return; this._set(false); - this.path = path; + this._path = path; this._set(true); } moveUp() { - this.moveTo(this.nodeTree.getNodeAbove(this.path)); + this.moveTo(this._nodeTree.getNodeAbove(this._path)); } moveDown() { - this.moveTo(this.nodeTree.getNodeBelow(this.path)); + this.moveTo(this._nodeTree.getNodeBelow(this._path)); } } class Editor { constructor(nodeTree) { - this.nodeTree = nodeTree; + this._nodeTree = nodeTree; - this.textarea = newElement("textarea"); - this.element = newElement("div", "node-editor", this.textarea); - this.textarea.addEventListener("input", event => this._updateTextAreaHeight()); + this._elTextarea = newElement("textarea"); + this._elTextarea.addEventListener("input", event => this._updateTextAreaHeight()); + this._elMain = newElement("div", "node-editor", this.textarea); - this.path = undefined; - this.asChild = false; + this._path = undefined; + this._asChild = false; } _updateTextAreaHeight() { - this.textarea.style.height = 0; - this.textarea.style.height = this.textarea.scrollHeight + "px"; + this._elTextarea.style.height = 0; + this._elTextarea.style.height = this._elTextarea.scrollHeight + "px"; } _getAttachedNode() { - if (this.path === undefined) return undefined; - return this.nodeTree.at(this.path); + if (this._path === undefined) return undefined; + return this._nodeTree.at(this._path); } _detach(node, asChild) { if (!asChild) { - node.elements.main.classList.remove("has-editor"); + node.hasEditor = false; } - this.element.parentNode.removeChild(this.element); + this._elMain.parentNode.removeChild(this._elMain); } _attachTo(node, asChild) { if (asChild) { - node.elements.children.appendChild(this.element); - node.setFolded(false); + node._el._elChildren.appendChild(this.element); + node.folded = false; } else { - node.elements.main.classList.add("has-editor"); - node.elements.main.insertBefore(this.element, node.elements.children); + node._el._elMain.classList.add("has-editor"); + node._el._elMain.insertBefore(this.element, node._el._elChildren); } this._updateTextAreaHeight(); } @@ -461,19 +584,19 @@ class Connection { } sendEdit(path, text) { - this._send({type: "edit", path: path.elements, text: text}); + this._send({type: "edit", path: path.components, text: text}); } sendDelete(path) { - this._send({type: "delete", path: path.elements}); + this._send({type: "delete", path: path.components}); } sendReply(path, text) { - this._send({type: "reply", path: path.elements, text: text}); + this._send({type: "reply", path: path.components, text: text}); } sendAct(path) { - this._send({type: "act", path: path.elements}); + this._send({type: "act", path: path.components}); } }