diff --git a/server/Main.hs b/server/Main.hs index 3c04c82..c7f6d06 100644 --- a/server/Main.hs +++ b/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.TreeModule.ConstModule +import Forest.Server +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 + ] diff --git a/src/Forest/TreeModule.hs b/src/Forest/TreeModule.hs index 1621d47..d9e12ce 100644 --- a/src/Forest/TreeModule.hs +++ b/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 () - act :: a -> Path -> IO () + delete _ _ = pure () + + reply :: a -> Path -> T.Text -> IO () + reply _ _ _ = pure () + + act :: a -> Path -> IO () + act _ _ = pure () type ModuleConstructor a = (Node -> IO ()) -> (a -> IO ()) -> IO () diff --git a/src/Forest/TreeModule/ConstModule.hs b/src/Forest/TreeModule/ConstModule.hs index 84bb0fe..49c50f7 100644 --- a/src/Forest/TreeModule/ConstModule.hs +++ b/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 diff --git a/src/Forest/TreeModule/ForkModule.hs b/src/Forest/TreeModule/ForkModule.hs new file mode 100644 index 0000000..e3f79b9 --- /dev/null +++ b/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)