From 2a2b14804608d566a39d1d1970cca89dd05c9b6f Mon Sep 17 00:00:00 2001 From: Joscha Date: Thu, 13 Feb 2020 23:38:26 +0000 Subject: [PATCH] [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 | 7 ++++--- src/Forest/TreeModule.hs | 20 ++++++++++-------- src/Forest/TreeModule/Animate.hs | 13 ++++++------ src/Forest/TreeModule/Const.hs | 9 ++++---- src/Forest/TreeModule/Fork.hs | 36 +++++++++++++++++--------------- src/Forest/Util.hs | 9 ++++++++ 6 files changed, 55 insertions(+), 39 deletions(-) diff --git a/src/Forest/Server.hs b/src/Forest/Server.hs index 04c2171..228c1fa 100644 --- a/src/Forest/Server.hs +++ b/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 conn treeModule = whileM $ do +receivePackets :: TreeModule a () => WS.Connection -> a () -> IO () +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 diff --git a/src/Forest/TreeModule.hs b/src/Forest/TreeModule.hs index a7425f4..bcd7036 100644 --- a/src/Forest/TreeModule.hs +++ b/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 - edit :: a -> Path -> T.Text -> IO Bool - edit _ _ _ = pure True +class TreeModule a r where + edit :: a r -> Path -> T.Text -> IO (Maybe r) + edit _ _ _ = pure Nothing - delete :: a -> Path -> IO Bool - delete _ _ = pure True + delete :: a r -> Path -> IO (Maybe r) + delete _ _ = pure Nothing - reply :: a -> Path -> T.Text -> IO Bool - reply _ _ _ = pure True + reply :: a r -> Path -> T.Text -> IO (Maybe r) + reply _ _ _ = pure Nothing - act :: a -> Path -> IO Bool - act _ _ = pure True + act :: a r -> Path -> IO (Maybe r) + act _ _ = pure Nothing type ModuleConstructor a = (Node -> IO ()) -> (a -> IO ()) -> IO () diff --git a/src/Forest/TreeModule/Animate.hs b/src/Forest/TreeModule/Animate.hs index 79bd5ab..7a5b32c 100644 --- a/src/Forest/TreeModule/Animate.hs +++ b/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 diff --git a/src/Forest/TreeModule/Const.hs b/src/Forest/TreeModule/Const.hs index 4c3b2fd..25ac72b 100644 --- a/src/Forest/TreeModule/Const.hs +++ b/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 diff --git a/src/Forest/TreeModule/Fork.hs b/src/Forest/TreeModule/Fork.hs index 14740f3..3384eb4 100644 --- a/src/Forest/TreeModule/Fork.hs +++ b/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 ProngConstructor = forall a . TreeModule a => ProngConstructor (ModuleConstructor a) +data Prong = forall r a . TreeModule a r => Prong (a r) +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 - edit _ (Path []) _ = pure True +instance TreeModule ForkModule () where + edit _ (Path []) _ = pure Nothing edit (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of - Just (Prong a) -> edit a (Path xs) text - Nothing -> pure True + Just (Prong a) -> Just () <$ edit a (Path xs) text + 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) - Nothing -> pure True + Just (Prong a) -> Just () <$ delete a (Path xs) + 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 - Nothing -> pure True + Just (Prong a) -> Just () <$ reply a (Path xs) text + 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) - Nothing -> pure True + Just (Prong a) -> Just () <$ act a (Path xs) + 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 diff --git a/src/Forest/Util.hs b/src/Forest/Util.hs index 8a2a30f..b92ca77 100644 --- a/src/Forest/Util.hs +++ b/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