[server] Add ForkModule for combining other modules

This one has some interesting code in its constructor, using the Cont monad
because of the way the ModuleConstructor is structured.

server/Main.hs

@@ -1,9 +1,13 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Main where
 
-import qualified Network.WebSockets as WS
+import qualified Network.WebSockets            as WS
 
-import Forest.Server
+import           Forest.Server
-import Forest.TreeModule.ConstModule
+import           Forest.Node
+import           Forest.TreeModule.ConstModule
+import           Forest.TreeModule.ForkModule
 
 pingDelay :: Int
 pingDelay = 10
@@ -19,4 +23,7 @@ options = WS.defaultServerOptions
 main :: IO ()
 main = do
   putStrLn "Starting server"
-  WS.runServerWithOptions options $ serverApp pingDelay $ constModule projectDescriptionNode
+  WS.runServerWithOptions options $ serverApp pingDelay $ forkModule "Forest"
+    [ ProngConstructor $ constModule $ newNode "" "Test" [txtNode "" "Bla"]
+    , ProngConstructor $ constModule projectDescriptionNode
+    ]

src/Forest/TreeModule.hs

@@ -8,9 +8,16 @@ import qualified Data.Text   as T
 import           Forest.Node
 
 class TreeModule a where
-  edit   :: a -> Path -> T.Text -> IO ()
+  edit :: a -> Path -> T.Text -> IO ()
+  edit _ _ _ = pure ()
+
   delete :: a -> Path -> IO ()
-  reply  :: a -> Path -> T.Text -> IO ()
+  delete _ _ = pure ()
-  act    :: a -> Path -> IO ()
+
+  reply :: a -> Path -> T.Text -> IO ()
+  reply _ _ _ = pure ()
+
+  act :: a -> Path -> IO ()
+  act _ _ = pure ()
 
 type ModuleConstructor a = (Node -> IO ()) -> (a -> IO ()) -> IO ()

src/Forest/TreeModule/ConstModule.hs

@@ -1,7 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Forest.TreeModule.ConstModule
-  ( constModule
+  ( ConstModule
+  , constModule
   , projectDescriptionNode
   ) where
 
@@ -11,10 +12,6 @@ import           Forest.TreeModule
 data ConstModule = ConstModule
 
 instance TreeModule ConstModule where
-  edit _ _ _ = pure ()
-  delete _ _ = pure ()
-  reply _ _ _ = pure ()
-  act _ _ = pure ()
 
 constModule :: Node -> ModuleConstructor ConstModule
 constModule node sendNode continue = do

src/Forest/TreeModule/ForkModule.hs

@@ -0,0 +1,77 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE KindSignatures            #-}
+{-# LANGUAGE RankNTypes                #-}
+
+module Forest.TreeModule.ForkModule
+  ( 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           Forest.TreeModule
+
+data Prong = forall a . TreeModule a => Prong a
+data ProngConstructor = forall a . TreeModule a => ProngConstructor (ModuleConstructor a)
+
+newtype ForkModule = ForkModule (Map.Map NodeId Prong)
+
+instance TreeModule ForkModule where
+  edit _ (Path []) _ = pure ()
+  edit (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of
+    Just (Prong a) -> edit a (Path xs) text
+    Nothing -> pure ()
+
+  delete _ (Path []) = pure ()
+  delete (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of
+    Just (Prong a) -> delete a (Path xs)
+    Nothing -> pure ()
+
+  reply _ (Path []) _ = pure ()
+  reply (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of
+    Just (Prong a) -> reply a (Path xs) text
+    Nothing -> pure ()
+
+  act _ (Path []) = pure ()
+  act (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of
+    Just (Prong a) -> act a (Path xs)
+    Nothing -> pure ()
+
+sendNodeFromProng
+  :: T.Text
+  -> MVar (Map.Map NodeId Node)
+  -> (Node -> IO ())
+  -> NodeId
+  -> Node
+  -> IO ()
+sendNodeFromProng text nodesVar sendNode nodeId node = do
+  nodes <- takeMVar nodesVar
+  let newNodes = Map.insert nodeId node nodes
+      newTopNode = Node text False False False False newNodes
+  sendNode newTopNode
+  putMVar nodesVar newNodes
+
+constructProngs
+  :: T.Text
+  -> MVar (Map.Map NodeId Node)
+  -> (Node -> IO ())
+  -> Map.Map NodeId ProngConstructor
+  -> Cont (IO ()) (Map.Map NodeId Prong)
+constructProngs text nodesVar sendNode =
+  Map.traverseWithKey constructProng
+  where
+    constructProng nodeId (ProngConstructor constructor) =
+      Prong <$> cont (constructor $ sendNodeFromProng text nodesVar sendNode nodeId)
+
+forkModule :: T.Text -> [ProngConstructor] -> ModuleConstructor ForkModule
+forkModule text prongs sendNode continue = do
+  nodesVar <- newMVar Map.empty
+  let digits = length $ show $ length prongs
+      numbers = map (T.justifyRight digits '0' . T.pack . show) [(0::Integer)..]
+      prongMap = Map.fromList $ zip numbers prongs
+  runCont (constructProngs text nodesVar sendNode prongMap) (continue . ForkModule)