[server] Adjust TreeModule structure

This commit prepares a slighly more powerful TreeModule structure: Now,
TreeModules can finish their execution, which should make some kinds of menus
and transitions possible.

src/Forest/Server.hs

@@ -6,7 +6,6 @@ module Forest.Server
   ) where
 
 import           Control.Concurrent.Chan
-import           Control.Monad
 import qualified Network.WebSockets      as WS
 
 import           Forest.Api
@@ -31,7 +30,7 @@ sendUpdatesThread conn nodeChan nodeA = do
 {- Main server application that receives and processes client packets -}
 
 receivePackets :: TreeModule a => WS.Connection -> a -> IO ()
-receivePackets conn treeModule = forever $ do
+receivePackets conn treeModule = whileM $ do
   packet <- receivePacket conn
   case packet of
     ClientEdit path text -> do

src/Forest/TreeModule.hs

@@ -8,16 +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 Bool
-  edit _ _ _ = pure ()
+  edit _ _ _ = pure True
 
-  delete :: a -> Path -> IO ()
+  delete :: a -> Path -> IO Bool
-  delete _ _ = pure ()
+  delete _ _ = pure True
 
-  reply :: a -> Path -> T.Text -> IO ()
+  reply :: a -> Path -> T.Text -> IO Bool
-  reply _ _ _ = pure ()
+  reply _ _ _ = pure True
 
-  act :: a -> Path -> IO ()
+  act :: a -> Path -> IO Bool
-  act _ _ = pure ()
+  act _ _ = pure True
 
 type ModuleConstructor a = (Node -> IO ()) -> (a -> IO ()) -> IO ()

src/Forest/TreeModule/Fork.hs

@@ -22,25 +22,25 @@ data ProngConstructor = forall a . TreeModule a => ProngConstructor (ModuleConst
 newtype ForkModule = ForkModule (Map.Map NodeId Prong)
 
 instance TreeModule ForkModule where
-  edit _ (Path []) _ = pure ()
+  edit _ (Path []) _ = pure True
   edit (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of
     Just (Prong a) -> edit a (Path xs) text
-    Nothing -> pure ()
+    Nothing -> pure True
 
-  delete _ (Path []) = pure ()
+  delete _ (Path []) = pure True
   delete (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of
     Just (Prong a) -> delete a (Path xs)
-    Nothing -> pure ()
+    Nothing -> pure True
 
-  reply _ (Path []) _ = pure ()
+  reply _ (Path []) _ = pure True
   reply (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of
     Just (Prong a) -> reply a (Path xs) text
-    Nothing -> pure ()
+    Nothing -> pure True
 
-  act _ (Path []) = pure ()
+  act _ (Path []) = pure True
   act (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of
     Just (Prong a) -> act a (Path xs)
-    Nothing -> pure ()
+    Nothing -> pure True
 
 sendNodeFromProng
   :: T.Text

src/Forest/Util.hs

@@ -3,6 +3,7 @@
 module Forest.Util
   ( findPrev
   , findNext
+  , whileM
   , withThread
   , sendPacket
   , closeWithErrorMessage
@@ -25,6 +26,14 @@ 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
+  continue <- f
+  if continue
+    then whileM f
+    else pure ()
+
 sendPacket :: ToJSON a => WS.Connection -> a -> IO ()
 sendPacket conn packet = WS.sendTextData conn $ encode packet