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/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) 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/forest-cabin/app/Main.hs b/forest-cabin/app/Main.hs new file mode 100644 index 0000000..82c4a76 --- /dev/null +++ b/forest-cabin/app/Main.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +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 + +{- Command line options -} + +data ServerOptions = ServerOptions + { serverPingDelay :: Int + , serverHost :: String + , serverPort :: Int + } + +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" + ) + +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 -} + +data AppEvent = UpdateSharedEdit + deriving (Show, Eq) + +newtype AppState = AppState + { _asSharedEdit :: SharedEditLocal + } + +makeLenses ''AppState + +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 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 + -> SharedEditGlobal + -> (AppState -> Maybe (TChan AppEvent) -> IO a) + -> IO a +constructor broadcastChan seg cont = do + sel <- sharedEditLocal seg + receiveChan <- atomically $ dupTChan broadcastChan + cont (AppState sel) (Just receiveChan) + +main :: IO () +main = do + opts <- execParser serverOptionsParserInfo + + 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 seg + } + + putStrLn "Starting server" + WS.runServerWithOptions (wsOptions opts) $ + runTreeApp (serverPingDelay opts) app diff --git a/forest-cabin/forest-cabin.cabal b/forest-cabin/forest-cabin.cabal new file mode 100644 index 0000000..4cd34f2 --- /dev/null +++ b/forest-cabin/forest-cabin.cabal @@ -0,0 +1,60 @@ +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 + , microlens + , microlens-th + , optparse-applicative + , stm + , 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 + , microlens + , microlens-th + , optparse-applicative + , stm + , websockets + default-language: Haskell2010 diff --git a/forest-cabin/package.yaml b/forest-cabin/package.yaml new file mode 100644 index 0000000..6e7ebe9 --- /dev/null +++ b/forest-cabin/package.yaml @@ -0,0 +1,36 @@ +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 + - microlens + - microlens-th + - optparse-applicative + - stm + - 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..80b2f04 --- /dev/null +++ b/forest-common/forest-common.cabal @@ -0,0 +1,45 @@ +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 + , safe + , text + , websockets + default-language: Haskell2010 diff --git a/forest-common/package.yaml b/forest-common/package.yaml new file mode 100644 index 0000000..b49c2d7 --- /dev/null +++ b/forest-common/package.yaml @@ -0,0 +1,24 @@ +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 + - safe + - 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 68% rename from src/Forest/Node.hs rename to forest-common/src/Forest/Node.hs index c89b6c3..d30ebb1 100644 --- a/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 @@ -82,7 +104,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 @@ -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/src/Forest/OrderedMap.hs b/forest-common/src/Forest/OrderedMap.hs similarity index 97% rename from src/Forest/OrderedMap.hs rename to forest-common/src/Forest/OrderedMap.hs index a29f3af..5d13333 100644 --- a/src/Forest/OrderedMap.hs +++ b/forest-common/src/Forest/OrderedMap.hs @@ -65,11 +65,17 @@ 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) +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/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..b581d18 --- /dev/null +++ b/forest-server/forest-server.cabal @@ -0,0 +1,45 @@ +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.Branch.SharedEdit + Forest.Server.Schema + Forest.Server.TreeApp + other-modules: + Paths_forest_server + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , containers + , forest-common + , microlens + , stm + , text + , transformers + , websockets + default-language: Haskell2010 diff --git a/forest-server/package.yaml b/forest-server/package.yaml new file mode 100644 index 0000000..f9395d9 --- /dev/null +++ b/forest-server/package.yaml @@ -0,0 +1,25 @@ +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 + - microlens + - stm + - text + - transformers + - websockets + +library: + source-dirs: src 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 new file mode 100644 index 0000000..e7856f8 --- /dev/null +++ b/forest-server/src/Forest/Server/Schema.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE RankNTypes #-} + +module Forest.Server.Schema + ( Schema + , fork + , fork' + , leaf + , collect + , collectWith + , dispatch + -- * Useful type + , Branch(..) + , schemaDraw + , schemaHandleEvent + , schemaLift + ) where + +import qualified Data.Text as T +import Lens.Micro + +import Forest.Node +import qualified Forest.OrderedMap as OMap +import Forest.Server.TreeApp + +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 + +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 diff --git a/forest-server/src/Forest/Server/TreeApp.hs b/forest-server/src/Forest/Server/TreeApp.hs new file mode 100644 index 0000000..a43e16d --- /dev/null +++ b/forest-server/src/Forest/Server/TreeApp.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +-- | 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 + { appDraw :: s -> Node + , appHandleEvent :: s -> Event e -> IO (Next s) + , appConstructor :: forall a. (s -> Maybe (TChan e) -> 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' = appDraw app state' + sendNodeUpdate conn (rsNode rs) node' + runUntilHalt conn app rs{rsState = state', rsNode = node'} + +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 customChan -> do + firstPacket <- receivePacket conn + case firstPacket of + ClientHello _ -> do + let initialNode = appDraw 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" 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 66% rename from src/Forest/Client.hs rename to forest-tui/src/Forest/Client.hs index 9ed37fe..8f7bacd 100644 --- a/src/Forest/Client.hs +++ b/forest-tui/src/Forest/Client.hs @@ -8,15 +8,16 @@ 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 -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 @@ -54,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 $ 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] + | 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 -} @@ -118,7 +125,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,15 +135,16 @@ 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 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/src/Forest/Client/NodeUtil.hs b/forest-tui/src/Forest/Client/NodeUtil.hs similarity index 85% rename from src/Forest/Client/NodeUtil.hs rename to forest-tui/src/Forest/Client/NodeUtil.hs index 1f0c031..3712e83 100644 --- a/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/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 50% rename from src/Forest/Client/UiState.hs rename to forest-tui/src/Forest/Client/UiState.hs index 915172b..2f4ac86 100644 --- a/src/Forest/Client/UiState.hs +++ b/forest-tui/src/Forest/Client/UiState.hs @@ -3,16 +3,17 @@ module Forest.Client.UiState ( UiState , newUiState - , getFocusedPath - , getFocusedNode + , focusedPath + , focusedNode -- * Modifying the UI state , replaceRootNode , moveFocusUp , moveFocusDown - , moveFocusToFirstChild - , moveFocusToLastChild - , moveFocusToFirstSibling - , moveFocusToLastSibling + , moveFocusToParent + , moveFocusToPrevSibling + , moveFocusToNextSibling + , moveFocusToTop + , moveFocusToBottom , foldAtFocus , unfoldAtFocus , toggleFoldAtFocus @@ -33,17 +34,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 qualified Data.Set as Set +import qualified Data.Text as T +import qualified Graphics.Vty as Vty -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) @@ -68,14 +70,17 @@ newUiState editorName node = UiState , uiEditorName = editorName } -getFocusedPath :: UiState n -> Path -getFocusedPath = uiFocused +focusedPath :: UiState n -> Path +focusedPath = uiFocused -getFocusedNode :: UiState n -> Node -getFocusedNode s = fromMaybe rootNode $ applyPath (uiFocused s) rootNode +focusedNode :: UiState n -> Node +focusedNode s = fromMaybe rootNode $ applyPath rootNode $ uiFocused s where rootNode = uiRootNode s +foldedRootNode :: UiState n -> Node +foldedRootNode s = applyFolds (uiUnfolded s) (uiRootNode s) + {- Modifying -} -- | Only keep those unfolded nodes that actually exist. @@ -86,77 +91,88 @@ validateUnfolded 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 +findValidParent node (Path (x:xs)) = case applyId node x 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 is invalid. validateFocused :: UiState n -> UiState n validateFocused s = - let foldedRootNode = applyFolds (uiUnfolded s) (uiRootNode s) - in s {uiFocused = findValidParent foldedRootNode $ uiFocused 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 (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} +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} +-- | 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 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 + 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 = - let foldedRootNode = applyFolds (uiUnfolded s) (uiRootNode s) - in validateFocused s {uiFocused = f foldedRootNode $ uiFocused s} +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 +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 $ \_ focused -> fromMaybe focused $ parent focused +moveFocusToParent = moveFocus $ const parent -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] +moveFocusToTop :: UiState n -> UiState n +moveFocusToTop = moveFocus firstNode -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 +moveFocusToBottom :: UiState n -> UiState n +moveFocusToBottom = moveFocus lastNode 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)} 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)} toggleFoldAtFocus :: UiState n -> UiState n toggleFoldAtFocus s = if uiFocused s `Set.member` uiUnfolded s @@ -165,13 +181,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} + in validateEditor s{uiEditor = Just editorInfo} -- | Begin editing the currently focused node. Discards any current editor -- status. @@ -180,20 +196,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 @@ -208,28 +222,27 @@ data EditResult = EditResult } 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) +finishEditing s = fromMaybe (s, Nothing) $ do + e <- uiEditor s + let editResult = EditResult + { erText = getCurrentText $ eiEditor e + , erPath = eiPath e + , erReply = eiReply e + } + 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 = @@ -244,23 +257,33 @@ 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 + 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 = txt " " + | otherwise = 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 + 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 (visible renderedNode) children + where + renderedNode = renderNode (path == uiFocused s) node children = fromMaybe [] maybeChildren renderUiState :: (Ord n, Show n) => IndentOptions -> UiState n -> Widget 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 93% rename from src/Forest/Client/NodeEditor.hs rename to forest-tui/src/Forest/Client/Widgets/NodeEditor.hs index aae8142..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 @@ -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/forest-tui/src/Forest/Client/Widgets/WidgetTree.hs b/forest-tui/src/Forest/Client/Widgets/WidgetTree.hs new file mode 100644 index 0000000..17cd0ce --- /dev/null +++ b/forest-tui/src/Forest/Client/Widgets/WidgetTree.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Forest.Client.Widgets.WidgetTree + ( WidgetTree(..) + , renderWidgetTreeWith + , renderWidgetTree + , treeLineAttr + , IndentOptions(..) + , boxDrawingBranching + , boxDrawingLine + , asciiBranching + , asciiLine + ) where + +import Brick +import qualified Data.Text as T +import qualified Graphics.Vty as Vty + +data WidgetTree n = WidgetTree (Widget n) [WidgetTree n] + +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 $ 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) {image=combinedImage} + pure result + +indent :: AttrName -> IndentOptions -> [Widget n] -> Widget n +indent indentAttrName opts widgets = vBox $ reverse $ case reverse widgets of + [] -> [] + (w: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 = renderWidgetTreeWith treeLineAttr + +-- | The attribute that 'renderWidgetTree' uses. +treeLineAttr :: AttrName +treeLineAttr = "treeLine" + +-- | These options control how a tree is rendered. +-- +-- 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 + { 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 + { indentNodeFirstLine = "├╴" + , indentNodeRest = "│ " + , indentLastNodeFirstLine = "└╴" + , indentLastNodeRest = " " + } + +boxDrawingLine :: IndentOptions +boxDrawingLine = IndentOptions + { indentNodeFirstLine = "│ " + , indentNodeRest = "│ " + , indentLastNodeFirstLine = "│ " + , indentLastNodeRest = "│ " + } + +asciiBranching :: IndentOptions +asciiBranching = IndentOptions + { indentNodeFirstLine = "+-" + , indentNodeRest = "| " + , indentLastNodeFirstLine = "+-" + , indentLastNodeRest = " " + } + +asciiLine :: IndentOptions +asciiLine = IndentOptions + { indentNodeFirstLine = "| " + , indentNodeRest = "| " + , indentLastNodeFirstLine = "| " + , indentLastNodeRest = "| " + } 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..7fdefee --- /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-children > *, .node-children > *::before { + border-color: var(--bright-black); + border-width: 2px; +} +.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 > *:last-child { + padding-left: calc(1.5ch + 1px); + border-left-style: none; +} +.node-children > *::before { + content: ""; + position: absolute; + left: 0; + top: 0; + width: calc(1ch - 1px); + height: calc(0.6em - 1px); + border-bottom-style: solid; +} +.node-children > *:last-child::before { + border-left-style: solid; + transition: border-bottom-left-radius 0.4s; +} + +/* Curvy lines */ +.curvy .node-children > *:last-child, .curvy .node-children > *: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..b276399 --- /dev/null +++ b/forest-web/node.js @@ -0,0 +1,684 @@ +"use strict"; + +/* + * 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. +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(...components) { + this._components = components.slice(); + } + + get components() { + return this._components.slice(); + } + + get length() { + return this._components.length; + } + + get last() { + return this._components[this.length - 1]; + } + + get parent() { + if (this.length === 0) return undefined; + return new Path(...this._components.slice(0, this.length - 1)); + } + + append(nodeId) { + return new Path(...this._components.concat([nodeId])); + } + + concat(otherPath) { + return new Path(...this._components.concat(otherPath._components)); + } +} + +class NodeElements { + constructor() { + 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._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() { + 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 NodePermissions { + constructor(edit, delete_, reply, act) { + this._edit = edit; + this._delete = delete_; + this._reply = reply; + this._act = act; + } + + 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" : "-", + this.delete ? "d" : "-", + this.reply ? "r" : "-", + this.act ? "a" : "-", + ")" + ].join(""); + } +} + +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); + }); + } + + child(childId) { + return this._children.get(childId); + } + + get order() { + return this._order.slice(); + } + + // 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 + // 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._el === undefined) { + // Obtain DOM elements because we don't yet have any + if (oldNode === undefined || oldNode._el === undefined) { + this._el = new NodeElements(); + } else { + this._el = oldNode._el; + } + } + + this._el.text = this._text; + this._el.permissions = this._permissions; + this._el.hasChildren = this.order.length > 0; + + this._el.removeAllChildren(); + + 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); // Not undefined + child.obtainElements(oldChild); + 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; + + // Prepare root node container + removeAllChildren(this._rootNodeContainer); + this._rootNode.appendTo(this._rootNodeContainer); + } + + at(path) { + let node = this._rootNode; + for (let childId of path.components) { + node = node.child(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); + parentNode.replaceChild(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.folded) return prevPath; + + let childPath = this.getLastChild(prevPath); + if (childPath === undefined) return prevPath; + + prevPath = childPath; + } + } + + getNodeBelow(path) { + let node = this.at(path); + if (!node.folded) { + 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 component of this._path.components) { + let newPath = path.append(component); + let newNode = this._nodeTree.at(newPath); + if (newNode === undefined) break; + if (newNode.folded) break; + path = newPath; + } + this._path = path; + } + + _set(visible) { + this.getSelectedNode().hasCursor = 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._elTextarea = newElement("textarea"); + this._elTextarea.addEventListener("input", event => this._updateTextAreaHeight()); + this._elMain = newElement("div", "node-editor", this.textarea); + + this._path = undefined; + this._asChild = false; + } + + _updateTextAreaHeight() { + 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); + } + + _detach(node, asChild) { + if (!asChild) { + node.hasEditor = false; + } + + this._elMain.parentNode.removeChild(this._elMain); + } + + _attachTo(node, asChild) { + if (asChild) { + node._el._elChildren.appendChild(this.element); + node.folded = false; + } else { + node._el._elMain.classList.add("has-editor"); + node._el._elMain.insertBefore(this.element, node._el._elChildren); + } + this._updateTextAreaHeight(); + } + + restore() { + if (this.element.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; + } +} + +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.components, text: text}); + } + + sendDelete(path) { + this._send({type: "delete", path: path.components}); + } + + sendReply(path, text) { + this._send({type: "reply", path: path.components, text: text}); + } + + sendAct(path) { + this._send({type: "act", path: path.components}); + } +} + +/* + * 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); +const conn = new Connection(nodeTree, cursor, editor, "ws://127.0.0.1:8080/"); + +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 => { + if (event.code === "Escape") { + 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") { + 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") { + 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(); + } +}); 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"); + } +} diff --git a/package.yaml b/package.yaml deleted file mode 100644 index 0d6dcdc..0000000 --- a/package.yaml +++ /dev/null @@ -1,53 +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 -- microlens -- 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/server/Main.hs b/server/Main.hs deleted file mode 100644 index 9dc690d..0000000 --- a/server/Main.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Main where - -import Control.Concurrent.MVar -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 - -pingDelay :: Int -pingDelay = 10 - -pongDelay :: Int -pongDelay = 3 * pingDelay - -options :: WS.ServerOptions -options = WS.defaultServerOptions - { WS.serverRequirePong = Just pongDelay - } - -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 - ] diff --git a/src/Forest/Broadcast.hs b/src/Forest/Broadcast.hs deleted file mode 100644 index 2c319c6..0000000 --- a/src/Forest/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.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/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 = "| " - } diff --git a/src/Forest/Server.hs b/src/Forest/Server.hs deleted file mode 100644 index e8e3716..0000000 --- a/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.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 = runUntilJustM $ 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/src/Forest/TreeModule.hs b/src/Forest/TreeModule.hs deleted file mode 100644 index bcd7036..0000000 --- a/src/Forest/TreeModule.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} - -module Forest.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/src/Forest/TreeModule/Animate.hs b/src/Forest/TreeModule/Animate.hs deleted file mode 100644 index 7a5b32c..0000000 --- a/src/Forest/TreeModule/Animate.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} - -module Forest.TreeModule.Animate - ( AnimateModule - , animateModule - ) where - -import Control.Concurrent - -import Forest.Node -import Forest.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/src/Forest/TreeModule/Const.hs b/src/Forest/TreeModule/Const.hs deleted file mode 100644 index 25ac72b..0000000 --- a/src/Forest/TreeModule/Const.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} - -module Forest.TreeModule.Const - ( ConstModule - , constModule - , projectDescriptionNode - ) where - -import Forest.Node -import Forest.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/src/Forest/TreeModule/Fork.hs b/src/Forest/TreeModule/Fork.hs deleted file mode 100644 index d1b4d67..0000000 --- a/src/Forest/TreeModule/Fork.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} - -module Forest.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.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/src/Forest/TreeModule/SharedEditing.hs b/src/Forest/TreeModule/SharedEditing.hs deleted file mode 100644 index b67d431..0000000 --- a/src/Forest/TreeModule/SharedEditing.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module Forest.TreeModule.SharedEditing - ( SharedEditingModule - , sharedEditingModule - ) where - -import Control.Concurrent.MVar -import Control.Monad - -import Forest.Broadcast -import Forest.Node -import Forest.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 diff --git a/stack.yaml b/stack.yaml index 465f104..2c294b0 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 +resolver: lts-15.3 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 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