diff --git a/client/Main.hs b/client/Main.hs index bbeaa59..55cd526 100644 --- a/client/Main.hs +++ b/client/Main.hs @@ -192,9 +192,9 @@ receiveUpdates eventChan node conn = handle (sendCloseEvent eventChan) $ do packet <- receivePacket conn case packet of ServerUpdate path subnode -> do - let newNode = replaceAt subnode path node - writeBChan eventChan $ EventNode newNode - receiveUpdates eventChan newNode conn -- Aaand close the loop :D + let node' = replaceAt subnode path node + writeBChan eventChan $ EventNode node' + receiveUpdates eventChan node' conn -- Aaand close the loop :D _ -> closeWithErrorMessage conn "Invalid packet: Expected update" runCorrectClient :: ClientOptions -> WS.ClientApp a -> IO a diff --git a/server/Main.hs b/server/Main.hs index ba216f9..3c04c82 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -19,4 +19,4 @@ options = WS.defaultServerOptions main :: IO () main = do putStrLn "Starting server" - WS.runServerWithOptions options $ serverApp pingDelay constModule + WS.runServerWithOptions options $ serverApp pingDelay $ constModule projectDescriptionNode diff --git a/src/Forest/Node.hs b/src/Forest/Node.hs index 487ceff..5c76fce 100644 --- a/src/Forest/Node.hs +++ b/src/Forest/Node.hs @@ -1,12 +1,12 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} module Forest.Node ( -- * Node NodeId , Node(..) + , newNode , emptyNode , hasChildren , mapChildren @@ -20,8 +20,6 @@ module Forest.Node , isValidPath , narrowPath , narrowSet - -- * Example values - , exampleNode ) where import Control.Monad @@ -39,10 +37,10 @@ type NodeId = T.Text data Node = Node { nodeText :: !T.Text - , nodeAct :: !Bool , nodeEdit :: !Bool , nodeDelete :: !Bool , nodeReply :: !Bool + , nodeAct :: !Bool , nodeChildren :: !(Map.Map NodeId Node) } deriving (Show, Generic) @@ -56,8 +54,17 @@ instance ToJSON Node where instance FromJSON Node where parseJSON = genericParseJSON nodeOptions -emptyNode :: T.Text -> Bool -> Bool -> Bool -> Bool -> Node -emptyNode text edit delete reply act = Node text edit delete reply act Map.empty +newNode :: String -> T.Text -> [Node] -> Node +newNode flags text children = + let edit = 'e' `elem` flags + delete = 'd' `elem` flags + reply = 'r' `elem` flags + act = 'a' `elem` flags + pairedChildren = zip (map (T.pack . show) [(0::Integer)..]) children + in Node text edit delete reply act $ Map.fromList pairedChildren + +emptyNode :: String -> T.Text -> Node +emptyNode flags text = newNode flags text [] hasChildren :: Node -> Bool hasChildren = not . Map.null . nodeChildren @@ -99,46 +106,3 @@ narrowPath _ _ = Nothing narrowSet :: NodeId -> Set.Set Path -> Set.Set Path narrowSet x s = Set.fromList [Path ys | Path (y:ys) <- Set.toList s, x == y] - -{- For testing -} - -exampleNode :: Node -exampleNode = - Node "forest" False False True True (Map.fromList - [("0", Node "CHANGELOG.md" True True False False (Map.fromList [])) - , ("1", Node "LICENSE" False False False True (Map.fromList [])) - , ("2", Node "README.md" False False False True (Map.fromList [])) - , ("3", Node "Setup.hs" True True False False (Map.fromList [])) - , ("4", Node "client" True False True False (Map.fromList - [("0", Node "Main.hs" False True True False (Map.fromList [])) - ])) - , ("5", Node "forest.cabal" True True True False (Map.fromList [])) - , ("6", Node "gen_file_node.py" True False False True (Map.fromList [])) - , ("7", Node "package.yaml" True False True False (Map.fromList [])) - , ("8", Node "server" True True True False (Map.fromList - [("0", Node "Main.hs" False False True True (Map.fromList [])) - ])) - , ("9", Node "src" False False False True (Map.fromList - [("0", Node "Forest" False True True False (Map.fromList - [("0", Node "Api.hs" True True True False (Map.fromList [])) - , ("1", Node "Broadcast.hs" False False False False (Map.fromList [])) - , ("2", Node "Client" True True True False (Map.fromList - [("0", Node "Node.hs" True True True True (Map.fromList [])) - , ("1", Node "NodeEditor.hs" True False False True (Map.fromList [])) - , ("2", Node "ResourceName.hs" True False False False (Map.fromList [])) - , ("3", Node "Tree.hs" False True True True (Map.fromList [])) - , ("4", Node "WidgetTree.hs" True False True False (Map.fromList [])) - ])) - , ("3", Node "Node.hs" True False False False (Map.fromList [])) - , ("4", Node "Server.hs" False False False False (Map.fromList [])) - , ("5", Node "TreeModule" False True False True (Map.fromList - [("0", Node "ConstModule.hs" True False False False (Map.fromList [])) - ])) - , ("6", Node "TreeModule.hs" True True False False (Map.fromList [])) - , ("7", Node "Util.hs" False True False True (Map.fromList [])) - ])) - , ("1", Node "Forest.hs" False True False False (Map.fromList [])) - ])) - , ("10", Node "stack.yaml" True False False True (Map.fromList [])) - , ("11", Node "stack.yaml.lock" False False False True (Map.fromList [])) - ]) diff --git a/src/Forest/Server.hs b/src/Forest/Server.hs index 739d4b5..0dd1f62 100644 --- a/src/Forest/Server.hs +++ b/src/Forest/Server.hs @@ -18,11 +18,11 @@ import Forest.Util sendUpdatesThread :: WS.Connection -> Chan Node -> Node -> IO () sendUpdatesThread conn nodeChan _ = do - newNode <- readChan nodeChan + node' <- readChan nodeChan -- TODO Don't send the whole node every time - putStrLn $ "Sending full node update with " ++ show newNode - sendPacket conn $ ServerUpdate (Path []) newNode - sendUpdatesThread conn nodeChan newNode + putStrLn $ "Sending full node update with " ++ show node' + sendPacket conn $ ServerUpdate (Path []) node' + sendUpdatesThread conn nodeChan node' {- Main server application that receives and processes client packets -} @@ -58,4 +58,4 @@ serverApp pingDelay constructor pendingConnection = do constructor (writeChan chan) $ receivePackets conn _ -> closeWithErrorMessage conn "Invalid packet: Expected a hello packet" where - initialNode = emptyNode "Loading ..." False False False False + initialNode = emptyNode "" "Loading ..." diff --git a/src/Forest/TreeModule/ConstModule.hs b/src/Forest/TreeModule/ConstModule.hs index 01b657c..94333a1 100644 --- a/src/Forest/TreeModule/ConstModule.hs +++ b/src/Forest/TreeModule/ConstModule.hs @@ -2,11 +2,9 @@ module Forest.TreeModule.ConstModule ( constModule + , projectDescriptionNode ) where -import Control.Concurrent -import Control.Monad - import Forest.Node import Forest.TreeModule @@ -18,9 +16,47 @@ instance TreeModule ConstModule where reply _ _ _ = pure () act _ _ = pure () -constModule :: ModuleConstructor ConstModule -constModule sendNode continue = do - void $ forkIO $ do - threadDelay $ 1000 * 1000 -- One second - sendNode (emptyNode "Loaded ConstModule" True True True True) +constModule :: Node -> ModuleConstructor ConstModule +constModule node sendNode continue = do + sendNode node continue ConstModule + +projectDescriptionNode :: Node +projectDescriptionNode = + newNode "" "Hello." + [ newNode "" "This project is an experiment in tree-based interaction." [] + , newNode "" "Its basic unit is the node (you're looking at one right now)." [] + , newNode "" "A node mostly contains text\nthat is not constrained\nto a\nsingle\nline." [] + , newNode "" "In addition to that, a node can have any number of child nodes." + [ newNode "" "This node is an example child node." [] + , newNode "" "Of course, children can have children too." + [ newNode "" "It's nodes all the way down." + [ newNode "" "Just kidding, it's turtles of course." [] + ] + ] + ] + , newNode "" "But that's not all there is to nodes." [] + , newNode "" "Each node also has a set of four different permissions." + [ newNode "" "Those permissions describe how you can interact with a node (besides folding and unfolding it)." [] + , newNode "" "Here are the four permissions, by name:" + [ newNode "e" "edit" + [ newNode "" "If a node has the 'edit' permission, its text can be edited." [] + ] + , newNode "d" "delete" + [ newNode "" "If a node has the 'delete' permission, it can be deleted." [] + ] + , newNode "r" "reply" + [ newNode "" "If a node has the 'reply' permission, a child node with custom text can be created." [] + ] + , newNode "a" "act" + [ newNode "" "If a node has the 'act' permission, a node-specific action can be performed with it." [] + ] + , newNode "" "The above nodes have their respective permission set, but the server will ignore any actions." [] + , newNode "" "Feel free to try out all the permissions, but don't be surprised if you try to delete a node and nothing happens." [] + ] + , newNode "" "Of course, a single node can have any combination of permissions." + [ newNode "er" "For example, this node has both the 'edit' and 'reply' permissions." [] + , newNode "eda" "And this node has all permissions except the 'reply' permission." [] + ] + ] + ]