Display custom node in ConstModule

Also wrote a short introductory node explaining node permissions.

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
+      let node' = replaceAt subnode path node
-      writeBChan eventChan $ EventNode newNode
+      writeBChan eventChan $ EventNode node'
-      receiveUpdates eventChan newNode conn -- Aaand close the loop :D
+      receiveUpdates eventChan node' conn -- Aaand close the loop :D
     _ -> closeWithErrorMessage conn "Invalid packet: Expected update"
 
 runCorrectClient :: ClientOptions -> WS.ClientApp a -> IO a

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

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
+newNode :: String -> T.Text -> [Node] -> Node
-emptyNode text edit delete reply act = Node text edit delete reply act Map.empty
+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 []))
-    ])

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
+  putStrLn $ "Sending full node update with " ++ show node'
-  sendPacket conn $ ServerUpdate (Path []) newNode
+  sendPacket conn $ ServerUpdate (Path []) node'
-  sendUpdatesThread conn nodeChan newNode
+  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 ..."

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 :: Node -> ModuleConstructor ConstModule
-constModule sendNode continue = do
+constModule node sendNode continue = do
-  void $ forkIO $ do
+  sendNode node
-    threadDelay $ 1000 * 1000 -- One second
-    sendNode (emptyNode "Loaded ConstModule" True True True True)
   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." []
+      ]
+    ]
+  ]