[server] Add return value to tree modules

Now, tree modules can't just stop, they can Just stop. Sorry... But they can
return values now, with a tiny bit of type class trickery.

src/Forest/Server.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Forest.Server
@@ -29,8 +30,8 @@ sendUpdatesThread conn nodeChan nodeA = do
 
 {- Main server application that receives and processes client packets -}
 
-receivePackets :: TreeModule a => WS.Connection -> a -> IO ()
+receivePackets :: TreeModule a () => WS.Connection -> a () -> IO ()
-receivePackets conn treeModule = whileM $ do
+receivePackets conn treeModule = runUntilJustM $ do
   packet <- receivePacket conn
   case packet of
     ClientEdit path text -> do
@@ -47,7 +48,7 @@ receivePackets conn treeModule = whileM $ do
       act treeModule path
     ClientHello _ -> closeWithErrorMessage conn "Invalid packet: Hello can only be sent once"
 
-serverApp :: TreeModule a => Int -> ModuleConstructor a -> WS.ServerApp
+serverApp :: TreeModule a () => Int -> ModuleConstructor (a ()) -> WS.ServerApp
 serverApp pingDelay constructor pendingConnection = do
   conn <- WS.acceptRequest pendingConnection
   chan <- newChan

src/Forest/TreeModule.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+
 module Forest.TreeModule
   ( TreeModule(..)
   , ModuleConstructor
@@ -7,17 +9,17 @@ import qualified Data.Text   as T
 
 import           Forest.Node
 
-class TreeModule a where
+class TreeModule a r where
-  edit :: a -> Path -> T.Text -> IO Bool
+  edit :: a r -> Path -> T.Text -> IO (Maybe r)
-  edit _ _ _ = pure True
+  edit _ _ _ = pure Nothing
 
-  delete :: a -> Path -> IO Bool
+  delete :: a r -> Path -> IO (Maybe r)
-  delete _ _ = pure True
+  delete _ _ = pure Nothing
 
-  reply :: a -> Path -> T.Text -> IO Bool
+  reply :: a r -> Path -> T.Text -> IO (Maybe r)
-  reply _ _ _ = pure True
+  reply _ _ _ = pure Nothing
 
-  act :: a -> Path -> IO Bool
+  act :: a r -> Path -> IO (Maybe r)
-  act _ _ = pure True
+  act _ _ = pure Nothing
 
 type ModuleConstructor a = (Node -> IO ()) -> (a -> IO ()) -> IO ()

src/Forest/TreeModule/Animate.hs

@@ -1,21 +1,22 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
 
 module Forest.TreeModule.Animate
   ( AnimateModule
   , animateModule
   ) where
 
-import Control.Concurrent
+import           Control.Concurrent
 
-import           Forest.TreeModule
 import           Forest.Node
+import           Forest.TreeModule
 import           Forest.Util
 
-data AnimateModule = AnimateModule
+data AnimateModule r = AnimateModule
 
-instance TreeModule AnimateModule where
+instance TreeModule AnimateModule () where
 
-animateModule :: Int -> [Node] -> ModuleConstructor AnimateModule
+animateModule :: Int -> [Node] -> ModuleConstructor (AnimateModule ())
 animateModule delay frames sendNode continue =
   withThread (animateThread frames) $ continue AnimateModule
   where

src/Forest/TreeModule/Const.hs

@@ -1,4 +1,5 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
 
 module Forest.TreeModule.Const
   ( ConstModule
@@ -9,11 +10,11 @@ module Forest.TreeModule.Const
 import           Forest.Node
 import           Forest.TreeModule
 
-data ConstModule = ConstModule
+data ConstModule r = ConstModule
 
-instance TreeModule ConstModule where
+instance TreeModule ConstModule () where
 
-constModule :: Node -> ModuleConstructor ConstModule
+constModule :: Node -> ModuleConstructor (ConstModule ())
 constModule node sendNode continue = do
   sendNode node
   continue ConstModule

src/Forest/TreeModule/Fork.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE KindSignatures            #-}
+{-# LANGUAGE MultiParamTypeClasses     #-}
 {-# LANGUAGE RankNTypes                #-}
 
 module Forest.TreeModule.Fork
@@ -16,31 +17,32 @@ import qualified Data.Text                as T
 import           Forest.Node
 import           Forest.TreeModule
 
-data Prong = forall a . TreeModule a => Prong a
+data Prong = forall r a . TreeModule a r => Prong (a r)
-data ProngConstructor = forall a . TreeModule a => ProngConstructor (ModuleConstructor a)
+data ProngConstructor = forall r a . TreeModule a r =>
+  ProngConstructor (ModuleConstructor (a r))
 
-newtype ForkModule = ForkModule (Map.Map NodeId Prong)
+newtype ForkModule r = ForkModule (Map.Map NodeId Prong)
 
-instance TreeModule ForkModule where
+instance TreeModule ForkModule () where
-  edit _ (Path []) _ = pure True
+  edit _ (Path []) _ = pure Nothing
   edit (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of
-    Just (Prong a) -> edit a (Path xs) text
+    Just (Prong a) -> Just () <$ edit a (Path xs) text
-    Nothing -> pure True
+    Nothing -> pure Nothing
 
-  delete _ (Path []) = pure True
+  delete _ (Path []) = pure Nothing
   delete (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of
-    Just (Prong a) -> delete a (Path xs)
+    Just (Prong a) -> Just () <$ delete a (Path xs)
-    Nothing -> pure True
+    Nothing -> pure Nothing
 
-  reply _ (Path []) _ = pure True
+  reply _ (Path []) _ = pure Nothing
   reply (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of
-    Just (Prong a) -> reply a (Path xs) text
+    Just (Prong a) -> Just () <$ reply a (Path xs) text
-    Nothing -> pure True
+    Nothing -> pure Nothing
 
-  act _ (Path []) = pure True
+  act _ (Path []) = pure Nothing
   act (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of
-    Just (Prong a) -> act a (Path xs)
+    Just (Prong a) -> Just () <$ act a (Path xs)
-    Nothing -> pure True
+    Nothing -> pure Nothing
 
 sendNodeFromProng
   :: T.Text
@@ -68,7 +70,7 @@ constructProngs text nodesVar sendNode =
     constructProng nodeId (ProngConstructor constructor) =
       Prong <$> cont (constructor $ sendNodeFromProng text nodesVar sendNode nodeId)
 
-forkModule :: T.Text -> [ProngConstructor] -> ModuleConstructor ForkModule
+forkModule :: T.Text -> [ProngConstructor] -> ModuleConstructor (ForkModule ())
 forkModule text prongs sendNode continue = do
   nodesVar <- newMVar Map.empty
   let digits = length $ show $ length prongs

src/Forest/Util.hs

@@ -4,6 +4,7 @@ module Forest.Util
   ( findPrev
   , findNext
   , whileM
+  , runUntilJustM
   , withThread
   , sendPacket
   , closeWithErrorMessage
@@ -34,6 +35,14 @@ whileM f = do
     then whileM f
     else pure ()
 
+-- | Run a monadic action until it returns @Just a@ for the first time.
+runUntilJustM :: Monad m => m (Maybe a) -> m a
+runUntilJustM f = do
+  result <- f
+  case result of
+    Nothing -> runUntilJustM f
+    Just a  -> pure a
+
 sendPacket :: ToJSON a => WS.Connection -> a -> IO ()
 sendPacket conn packet = WS.sendTextData conn $ encode packet