From c79273b1c8446d3603654ab549e0c22e202ec8a4 Mon Sep 17 00:00:00 2001 From: Justin Dawson Date: Thu, 6 Apr 2017 14:20:54 -0500 Subject: [PATCH] Code beautification, combined query packet and applicative packet logic, added query example --- examples/{ => async}/Main.hs | 0 examples/query/Main.hs | 188 +++++++++++++++ remote-monad.cabal | 15 +- .../Remote/WithoutAsync/Applicative.hs | 74 +++--- .../Remote/WithoutAsync/Applicative/Types.hs | 24 +- src/Control/Remote/WithoutAsync/Monad.hs | 227 +++++++----------- .../Remote/WithoutAsync/Monad/Types.hs | 28 +-- src/Control/Remote/WithoutAsync/Packet.hs | 14 +- .../Remote/WithoutAsync/Packet/Alternative.hs | 26 +- .../Remote/WithoutAsync/Packet/Applicative.hs | 14 +- .../Remote/WithoutAsync/Packet/Weak.hs | 14 +- 11 files changed, 386 insertions(+), 238 deletions(-) rename examples/{ => async}/Main.hs (100%) create mode 100644 examples/query/Main.hs diff --git a/examples/Main.hs b/examples/async/Main.hs similarity index 100% rename from examples/Main.hs rename to examples/async/Main.hs diff --git a/examples/query/Main.hs b/examples/query/Main.hs new file mode 100644 index 0000000..b53faf2 --- /dev/null +++ b/examples/query/Main.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} + +module Main where + +import Control.Natural +import Control.Remote.WithoutAsync.Monad +import Control.Remote.WithoutAsync.Packet.Weak as WP +import Control.Remote.WithoutAsync.Packet.Applicative as AP +import Control.Remote.WithoutAsync.Packet.Query as Q +import Control.Remote.WithoutAsync.Packet.Alternative as Alt +import Control.Applicative +import Control.Monad.Catch +import Control.Exception hiding (catch) + +data Query :: * -> * where + Temperature :: Query Int + Say :: String -> Query () + +say :: String -> RemoteMonad Query () +say s = query (Say s) + +temperature :: RemoteMonad Query Int +temperature = query Temperature + + +--Server Side Functions +--------------------------------------------------------- +runWP :: WeakPacket Query a -> IO a +runWP (WP.Query (Say s)) = print s +runWP (WP.Query Temperature) = do + putStrLn "Temp Call" + return 42 +---------------------------------------------------------- +runAP :: ApplicativePacket Query a -> IO a +runAP (AP.Query (Say s)) = print s +runAP (AP.Query Temperature) = do + putStrLn "Temp Call" + return 42 +runAP (AP.Zip f g h) = do + f <$> runAP g <*> runAP h +runAP (AP.Pure a) = do + putStrLn "Pure" + return a +--------------------------------------------------------- +runQ :: QueryPacket Query a -> IO a +runQ (QueryPacket pkt) = runAP pkt +--------------------------------------------------------- +runAlt :: AlternativePacket Query a -> IO a +runAlt (Alt.Query (Say s)) = print s +runAlt (Alt.Query Temperature) = do + putStrLn "Temp Call" + return 42 +runAlt (Alt.Zip f g h) = f <$> runAlt g <*> runAlt h +runAlt (Alt.Pure a) = return a +runAlt (Alt g h) = do + putStrLn "Alternative" + a <-(runAlt g) <|> (runAlt h) + putStrLn "End Alternative" + return a +runAlt (Alt.Empty) = empty +----------------------------------------------------------- +sendWeak :: RemoteMonad Query a -> IO a +sendWeak = unwrapNT $ runMonad $ wrapNT (\pkt -> do putStrLn "-----"; runWP pkt) + +sendApp :: RemoteMonad Query a -> IO a +sendApp = unwrapNT $ runMonad $ wrapNT (\pkt -> do putStrLn "-----"; runAP pkt) + +sendQ :: RemoteMonad Query a -> IO a +sendQ = unwrapNT $ runMonad $ wrapNT (\pkt -> do putStrLn "-----"; runQ pkt) + +sendAlt :: RemoteMonad Query a -> IO a +sendAlt = unwrapNT $ runMonad $ wrapNT (\pkt -> do putStrLn "-----"; runAlt pkt) +--------------------------------------------------------- + +main :: IO () +main = do + + putStrLn "WeakSend\n" + runTest $ wrapNT sendWeak + + putStrLn "\nAppSend\n" + runTest $ wrapNT sendApp + + putStrLn "\nQuerySend\n" + runTest $ wrapNT sendQ + + putStrLn "\nAltSend\n" + runTest $ wrapNT sendAlt + +--Run Test Suite +runTest :: (RemoteMonad Query :~> IO)-> IO() +runTest (NT f) = do + f test + f testBind + f testApp + f testAlt + (f testAltException) + `catch` (\e -> case e ::RemoteMonadException of + RemoteEmptyException -> putStrLn "Empty Exception Thrown" + ) + (f $ testThrowM) + `catch` (\e -> case e :: ArithException of + DivideByZero -> putStrLn "Should have sent \"hi\", then given this exception" + _ -> throw e + ) + + (f $ testThrowM2) + `catch` (\e -> case e :: ArithException of + Underflow -> putStrLn "Should have sent temp, then given this exception" + _ -> throw e + ) + + f testCatch + f testCatch2 + +-- Original test case +test :: RemoteMonad Query () +test = do + say "Howdy doodly do" + say "How about a muffin?" + t <- temperature + say (show t ++ "F") + +-- Test bind +testBind :: RemoteMonad Query () +testBind = say "one" >> say "two" >> temperature >>= say . ("Temperature: " ++) .show + +-- test alt +testAlt :: RemoteMonad Query () +testAlt = do + say "three" <|> say "ERROR" + _ <- say "test1" >> say "test2" >> say "test3" >> temperature <|> temperature + (say "test1" >> say "test2" >> empty >> say "test3") <|> say "fail" + say "four" <|> empty + empty <|> say "five" + say "six" >> empty <|> say "seven" + r <- (do temperature >>= \a -> if a /= 42 then return a else (say "HA" >> empty)) <|> pure 32 + say "Should be 32:" + say (show r) + + +--test alt withe empty on both sides +testAltException :: RemoteMonad Query () +testAltException = do + say "finished tests, now testing exception thrown" + (do say "eight"; _ <- empty; say "shouldn't See me") --expected exception + <|> (do say "nine"; _ <- empty; say "AHAHA") + + +--test throw +testThrowM :: RemoteMonad Query () +testThrowM = say "hi" >> throwM DivideByZero + +-- test throw in an AP +testThrowM2 :: RemoteMonad Query () +testThrowM2 = do + r <- (+) <$> temperature <*> throwM Underflow + say (show r) + + +--test catch random throwM +testCatch :: RemoteMonad Query () +testCatch = do (say "going to throw" >> throwM DivideByZero) + `catch` (\e -> case e :: ArithException of + DivideByZero -> say "Divided by Zero" + _ -> say "Oops!" + ) +-- test catching Empty exception +testCatch2 :: RemoteMonad Query () +testCatch2 =do + r <- (do temperature >>= \a -> if a /= 42 then return a else (say "HA" >> empty)) <|> pure 32 + `catch` (\e -> case e :: RemoteMonadException of + RemoteEmptyException -> do + say "Caught Exception in Send" + temperature + ) + say (show r) + +testApp :: RemoteMonad Query () +testApp = do + r<- add <$> temperature<*>temperature <*> temperature + say (show r) + where + add :: Int -> Int -> Int -> Int + add x y z= x + y + z + diff --git a/remote-monad.cabal b/remote-monad.cabal index 0c2d409..c0caf23 100644 --- a/remote-monad.cabal +++ b/remote-monad.cabal @@ -95,17 +95,28 @@ library default-language: Haskell2010 -test-suite remote-monad-example +test-suite remote-monad-async-example type: exitcode-stdio-1.0 main-is: Main.hs build-depends: base >= 4.7 && < 5 , exceptions >= 0.8 && < 0.9 , natural-transformation >= 0.4 && < 0.5 , remote-monad == 0.4 - hs-source-dirs: examples + hs-source-dirs: examples/async default-language: Haskell2010 ghc-options: -Wall +test-suite remote-monad-query-example + type: exitcode-stdio-1.0 + main-is: Main.hs + build-depends: base >= 4.7 && < 5 + , exceptions >= 0.8 && < 0.9 + , natural-transformation >= 0.4 && < 0.5 + , remote-monad == 0.4 + hs-source-dirs: examples/query + default-language: Haskell2010 + ghc-options: -Wall + test-suite remote-monad-properties type: exitcode-stdio-1.0 main-is: Test.hs diff --git a/src/Control/Remote/WithoutAsync/Applicative.hs b/src/Control/Remote/WithoutAsync/Applicative.hs index 26f0345..4445806 100644 --- a/src/Control/Remote/WithoutAsync/Applicative.hs +++ b/src/Control/Remote/WithoutAsync/Applicative.hs @@ -45,15 +45,15 @@ import Control.Monad.Catch import Control.Monad.Trans.Maybe -- | promote a command into the applicative -procedure :: p a -> RemoteApplicative p a -procedure p = T.Procedure p +procedure :: q a -> RemoteApplicative q a +procedure q = T.Query q -- | 'RunApplicative' is the overloading for choosing the appropriate bundling strategy for applicative. class RunApplicative f where -- | This overloaded function chooses the appropriate bundling strategy -- based on the type of the handler your provide. - runApplicative :: (MonadThrow m) => (f p :~> m) -> (RemoteApplicative p:~> m) + runApplicative :: (MonadThrow m) => (f q :~> m) -> (RemoteApplicative q:~> m) instance RunApplicative WeakPacket where runApplicative = runWeakApplicative @@ -68,61 +68,61 @@ instance RunApplicative QueryPacket where runApplicative = runQueryApplicative -- | The weak remote applicative, that sends commands and procedures piecemeal. -runWeakApplicative :: forall m p . (MonadThrow m) => (WeakPacket p :~> m) -> (RemoteApplicative p :~> m) +runWeakApplicative :: forall m q . (MonadThrow m) => (WeakPacket q :~> m) -> (RemoteApplicative q :~> m) runWeakApplicative (NT rf) = wrapNT $ go where - go :: forall a . RemoteApplicative p a -> m a - go p = do r <- runMaybeT (go2 p) + go :: forall a . RemoteApplicative q a -> m a + go q = do r <- runMaybeT (go2 q) case r of Nothing -> throwM RemoteEmptyException Just a -> return a - go2 :: forall a . RemoteApplicative p a -> MaybeT m a - go2 (T.Procedure p) = lift $ rf (Weak.Procedure p) - go2 (T.Ap g h) = go2 g <*> go2 h - go2 (T.Pure a) = pure a - go2 T.Empty = empty - go2 (T.Alt g h) = (go2 g <|> go2 h) + go2 :: forall a . RemoteApplicative q a -> MaybeT m a + go2 (T.Query q) = lift $ rf (Weak.Query q) + go2 (T.Ap g h) = go2 g <*> go2 h + go2 (T.Pure a) = pure a + go2 T.Empty = empty + go2 (T.Alt g h) = (go2 g <|> go2 h) -- | The applicative remote applicative, that is the identity function. -runApplicativeApplicative :: forall m p . (MonadThrow m) => (ApplicativePacket p :~> m) -> (RemoteApplicative p :~> m) +runApplicativeApplicative :: forall m q . (MonadThrow m) => (ApplicativePacket q :~> m) -> (RemoteApplicative q :~> m) runApplicativeApplicative (NT rf) = wrapNT (go4 . go3) where - go3 :: forall a . RemoteApplicative p a -> Wrapper (ApplicativePacket p) a - go3 (T.Empty) = empty --uses Throw' - go3 (T.Pure a) = pure a - go3 (T.Procedure p) = Value (A.Procedure p) - go3 (T.Ap g h) = (go3 g) <*> (go3 h) - go3 (T.Alt g h) = (go3 g) <|> (go3 h) - - go4 :: forall a . Wrapper (ApplicativePacket p) a -> m a + go3 :: forall a . RemoteApplicative q a -> Wrapper (ApplicativePacket q) a + go3 (T.Empty) = empty --uses Throw' + go3 (T.Pure a) = pure a + go3 (T.Query q) = Value (A.Query q) + go3 (T.Ap g h) = (go3 g) <*> (go3 h) + go3 (T.Alt g h) = (go3 g) <|> (go3 h) + + go4 :: forall a . Wrapper (ApplicativePacket q) a -> m a go4 (Value pkt) = rf pkt go4 (Throw' pkt) = do () <- rf pkt throwM RemoteEmptyException -- | The applicative remote applicative, that is the identity function. -runQueryApplicative :: forall m p . (MonadThrow m) => (QueryPacket p :~> m) -> (RemoteApplicative p :~> m) +runQueryApplicative :: forall m q . (MonadThrow m) => (QueryPacket q :~> m) -> (RemoteApplicative q :~> m) runQueryApplicative (NT rf) = wrapNT (go4 . go3) where - go3 :: forall a . RemoteApplicative p a -> Wrapper (QueryPacket p) a - go3 (T.Empty) = empty --uses Throw' - go3 (T.Pure a) = pure a - go3 (T.Procedure p) = Value (QueryPacket (A.Procedure p)) - go3 (T.Ap g h) = (go3 g) <*> (go3 h) - go3 (T.Alt g h) = (go3 g) <|> (go3 h) - - go4 :: forall a . Wrapper (QueryPacket p) a -> m a + go3 :: forall a . RemoteApplicative q a -> Wrapper (QueryPacket q) a + go3 (T.Empty) = empty --uses Throw' + go3 (T.Pure a) = pure a + go3 (T.Query q) = Value (QueryPacket (A.Query q)) + go3 (T.Ap g h) = (go3 g) <*> (go3 h) + go3 (T.Alt g h) = (go3 g) <|> (go3 h) + + go4 :: forall a . Wrapper (QueryPacket q) a -> m a go4 (Value pkt) = rf pkt go4 (Throw' pkt) = do () <- rf pkt throwM RemoteEmptyException -runAlternativeApplicative :: forall m p . (MonadThrow m) => (AlternativePacket p :~> m) -> (RemoteApplicative p :~> m) +runAlternativeApplicative :: forall m q . (MonadThrow m) => (AlternativePacket q :~> m) -> (RemoteApplicative q :~> m) runAlternativeApplicative (NT rf) = wrapNT $ \p -> rf $ go p where - go :: forall a . RemoteApplicative p a -> AlternativePacket p a - go (T.Empty) = Alt.Empty - go (T.Pure a) = pure a - go (T.Procedure p) = Alt.Procedure p - go (T.Ap g h) = (go g) <*> (go h) - go (T.Alt g h) = (go g) <|> (go h) + go :: forall a . RemoteApplicative q a -> AlternativePacket q a + go (T.Empty) = Alt.Empty + go (T.Pure a) = pure a + go (T.Query q) = Alt.Query q + go (T.Ap g h) = (go g) <*> (go h) + go (T.Alt g h) = (go g) <|> (go h) diff --git a/src/Control/Remote/WithoutAsync/Applicative/Types.hs b/src/Control/Remote/WithoutAsync/Applicative/Types.hs index f60e46c..e9c11cc 100644 --- a/src/Control/Remote/WithoutAsync/Applicative/Types.hs +++ b/src/Control/Remote/WithoutAsync/Applicative/Types.hs @@ -25,23 +25,23 @@ import Data.Typeable import Control.Monad.Trans.Class -- | 'RemoteApplicative' is our applicative that can be executed in a remote location. -data RemoteApplicative (proc:: * -> *) a where - Procedure :: proc a -> RemoteApplicative proc a - Alt :: RemoteApplicative proc a - -> RemoteApplicative proc a -> RemoteApplicative proc a - Ap :: RemoteApplicative proc (a -> b) - -> RemoteApplicative proc a -> RemoteApplicative proc b - Pure :: a -> RemoteApplicative proc a - Empty :: RemoteApplicative proc a +data RemoteApplicative (q :: * -> *) a where + Query :: q a -> RemoteApplicative q a + Alt :: RemoteApplicative q a + -> RemoteApplicative q a -> RemoteApplicative q a + Ap :: RemoteApplicative q (a -> b) + -> RemoteApplicative q a -> RemoteApplicative q b + Pure :: a -> RemoteApplicative q a + Empty :: RemoteApplicative q a -instance Functor (RemoteApplicative proc) where +instance Functor (RemoteApplicative q) where fmap f g = pure f <*> g -instance Applicative (RemoteApplicative proc) where -- may need m to be restricted to Monad here +instance Applicative (RemoteApplicative q) where -- may need m to be restricted to Monad here pure a = Pure a (<*>) = Ap -instance Alternative (RemoteApplicative proc) where +instance Alternative (RemoteApplicative q) where empty = Empty - Empty <|> p = p + Empty <|> q = q m1 <|> m2 = Alt m1 m2 diff --git a/src/Control/Remote/WithoutAsync/Monad.hs b/src/Control/Remote/WithoutAsync/Monad.hs index 0f8ea42..7c374c4 100644 --- a/src/Control/Remote/WithoutAsync/Monad.hs +++ b/src/Control/Remote/WithoutAsync/Monad.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE KindSignatures #-} {-| Module: Control.Remote.Monad.Packet.Weak @@ -34,7 +35,7 @@ import Control.Monad.Trans.State.Strict import qualified Control.Remote.WithoutAsync.Applicative as A import Control.Remote.WithoutAsync.Packet.Applicative as A import qualified Control.Remote.WithoutAsync.Packet.Alternative as Alt -import qualified Control.Remote.WithoutAsync.Packet.Query as Q +import Control.Remote.WithoutAsync.Packet.Query as Q import Control.Remote.WithoutAsync.Packet.Weak as Weak import Control.Remote.WithoutAsync.Monad.Types as T import Control.Remote.WithoutAsync.Applicative.Types as T @@ -47,21 +48,26 @@ import Control.Monad.Trans.Maybe -- | promote a procedure into the remote monad -query :: p a -> RemoteMonad p a +query :: q a -> RemoteMonad q a query = Appl . A.procedure -loop :: forall a p l . (a-> Bool) -> RemoteMonad p a -> RemoteMonad p a +loop :: forall a q l . (a-> Bool) -> RemoteMonad q a -> RemoteMonad q a loop f m = do res <- m if f res then loop f m else return res +data X (f :: (* -> *) -> * -> *) q a where + Pure' :: a -> X f q a + Pkt :: (a -> b) -> f q a -> X f q b + + -- | 'RunMonad' is the overloading for choosing the appropriate bundling strategy for a monad. class RunMonad f where -- | This overloaded function chooses the appropriate bundling strategy -- based on the type of the handler your provide. - runMonad :: (MonadCatch m) => (f p :~> m) -> (RemoteMonad p :~> m) + runMonad :: (MonadCatch m) => (f q :~> m) -> (RemoteMonad q :~> m) instance RunMonad WeakPacket where runMonad = runWeakMonad @@ -69,6 +75,9 @@ instance RunMonad WeakPacket where instance RunMonad ApplicativePacket where runMonad = runApplicativeMonad +instance RunMonad QueryPacket where + runMonad = runQueryMonad + instance RunMonad Alt.AlternativePacket where runMonad = runAlternativeMonad @@ -78,11 +87,11 @@ instance RunMonad Alt.AlternativePacket where -- Every '>>=' will generate a call to the 'RemoteApplicative' -- handler; as well as one terminating call. -- Using 'runBindeeMonad' with a 'runWeakApplicative' gives the weakest remote monad. -runMonadSkeleton :: (MonadCatch m) => (RemoteApplicative p :~> m) -> (RemoteMonad p :~> m) +runMonadSkeleton :: (MonadCatch m) => (RemoteApplicative q :~> m) -> (RemoteMonad q :~> m) runMonadSkeleton f = wrapNT $ \ case - Appl g -> unwrapNT f g - Bind g k -> (runMonadSkeleton f # g) >>= \ a -> runMonadSkeleton f # (k a) - Ap' g h -> (runMonadSkeleton f # g) <*> (runMonadSkeleton f # h) + Appl g -> unwrapNT f g + Bind g k -> (runMonadSkeleton f # g) >>= \ a -> runMonadSkeleton f # (k a) + Ap' g h -> (runMonadSkeleton f # g) <*> (runMonadSkeleton f # h) Alt' m1 m2 -> (runMonadSkeleton f # m1) `catch`(\ e-> case e :: RemoteMonadException of RemoteEmptyException -> runMonadSkeleton f # m2 @@ -93,15 +102,16 @@ runMonadSkeleton f = wrapNT $ \ case -- | This is the classic weak remote monad, or technically the -- weak remote applicative weak remote monad. -runWeakMonad :: (MonadCatch m) => (WeakPacket p :~> m) -> (RemoteMonad p :~> m) +runWeakMonad :: (MonadCatch m) => (WeakPacket q :~> m) -> (RemoteMonad q :~> m) runWeakMonad = runMonadSkeleton . A.runWeakApplicative --- | The is the strong applicative strong remote monad. It bundles --- packets (of type 'RemoteApplicative') as large as possible, --- including over some monadic binds. -runApplicativeMonad :: forall m p . (MonadCatch m) => (A.ApplicativePacket p :~> m) -> (RemoteMonad p :~> m) -runApplicativeMonad (NT rf) = wrapNT $ \ p -> do - (r,h) <- runStateT (runMaybeT (go2 p)) (pure ()) + +type PreProcessor q = RemoteMonad q :~> RemoteMonad q + +runApplicative :: forall f m q . (MonadCatch m) => (f q :~> m) + -> (RemoteApplicative q :~> X f q) -> PreProcessor q -> (RemoteMonad q :~> m) +runApplicative (NT rf) (NT pk) (NT reWrite) = wrapNT $ \ q -> do + (r,h) <- runStateT (runMaybeT (go2 (reWrite q))) (pure ()) case pk h of -- should we stub out the call with only 'Pure'? Pure' a -> return a Pkt f b -> do res <- rf $ b @@ -110,7 +120,7 @@ runApplicativeMonad (NT rf) = wrapNT $ \ p -> do Nothing -> throwM RemoteEmptyException Just v -> return v where - go2 :: forall a . RemoteMonad p a -> MaybeT (StateT (RemoteApplicative p ()) m) a + go2 :: forall a . RemoteMonad q a -> MaybeT (StateT (RemoteApplicative q ()) m) a go2 (Appl app) = lift $ unwrap $ go app go2 (Bind app k) = go2 app >>= \ a -> go2 (k a) go2 (Ap' g h) = go2 g <*> go2 h @@ -121,15 +131,15 @@ runApplicativeMonad (NT rf) = wrapNT $ \ p -> do throwM e go2 (Catch m h) = catch (go2 m) (go2 . h) - go :: forall a . T.RemoteApplicative p a -> Wrapper (RemoteApplicative p) a - go (T.Empty) = empty - go (T.Pure a) = pure a - go (T.Procedure p) = Value (T.Procedure p) - go (T.Ap g h) = (go g) <*> (go h) - go (T.Alt g h) = (go g) <|> (go h) + go :: forall a . T.RemoteApplicative q a -> Wrapper (RemoteApplicative q) a + go (T.Empty) = empty + go (T.Pure a) = pure a + go (T.Query q) = Value (T.Query q) + go (T.Ap g h) = (go g) <*> (go h) + go (T.Alt g h) = (go g) <|> (go h) -- g is a function that will take the current state as input - discharge :: forall a f . Applicative f => (f () ->RemoteApplicative p a )-> StateT (f ()) m a + discharge :: forall a f . Applicative f => (f () ->RemoteApplicative q a )-> StateT (f ()) m a discharge g = do ap' <- get put (pure ()) -- clear state @@ -139,7 +149,7 @@ runApplicativeMonad (NT rf) = wrapNT $ \ p -> do res <- lift $ rf pkt return $ f res -- Given a wrapped applicative discharge via local monad - unwrap :: forall a . Wrapper(RemoteApplicative p) a -> StateT (RemoteApplicative p ()) m a + unwrap :: forall a . Wrapper(RemoteApplicative q) a -> StateT (RemoteApplicative q ()) m a unwrap (Value ap) = case superApplicative ap of Nothing ->do discharge $ \ap' -> (ap' *> ap) @@ -152,100 +162,46 @@ runApplicativeMonad (NT rf) = wrapNT $ \ p -> do throwM RemoteEmptyException -- Do we know the answer? Nothing = we need to get it - superApplicative :: RemoteApplicative p a -> Maybe a - superApplicative (T.Pure a) = pure a - superApplicative (T.Procedure p) = Nothing - superApplicative (T.Ap g h) = (superApplicative g) <*> (superApplicative h) - superApplicative (T.Alt g h) = Nothing - superApplicative (T.Empty) = Nothing - - -- Either A or a Packet to return A - pk :: RemoteApplicative p a -> ApplicativeX p a - pk (T.Pure a) = Pure' a - pk (T.Procedure p) = Pkt id $ A.Procedure p - pk (T.Ap g h) = case (pk g, pk h) of - (Pure' a, Pure' b) -> Pure' (a b) - (Pure' a, Pkt f b) -> Pkt (\b' -> a (f b')) b - (Pkt f a, Pure' b) -> Pkt (\a' -> f a' b) a - (Pkt f a, Pkt g b) -> Pkt id $ A.Zip (\ a' b' -> f a' (g b')) a b -data ApplicativeX p a where - Pure' :: a -> ApplicativeX p a - Pkt :: (a -> b) -> ApplicativePacket p a -> ApplicativeX p b - + superApplicative :: RemoteApplicative q a -> Maybe a + superApplicative (T.Pure a) = pure a + superApplicative (T.Query _q) = Nothing + superApplicative (T.Ap g h) = (superApplicative g) <*> (superApplicative h) + superApplicative (T.Alt _g _h) = Nothing + superApplicative (T.Empty) = Nothing -- | The is the strong applicative strong remote monad. It bundles -- packets (of type 'RemoteApplicative') as large as possible, -- including over some monadic binds. -runQueryMonad :: forall m p . (MonadCatch m) => (Q.QueryPacket p :~> m) -> (RemoteMonad p :~> m) -runQueryMonad (NT rf) = wrapNT $ \ p -> do - (r,h) <- runStateT (runMaybeT (go2 (helper p))) (pure ()) - case pk h of -- should we stub out the call with only 'Pure'? - PureQ a -> return a - PktQ f b -> do res <- rf $ b - return $ f res - case r of - Nothing -> throwM RemoteEmptyException - Just v -> return v +runApplicativeMonad :: forall m q . (MonadCatch m) => (A.ApplicativePacket q :~> m) -> (RemoteMonad q :~> m) +runApplicativeMonad f = runApplicative f (wrapNT pk) (wrapNT id) where - go2 :: forall a . RemoteMonad p a -> MaybeT (StateT (RemoteApplicative p ()) m) a - go2 (Appl app) = lift $ unwrap $ go app - go2 (Bind app k) = go2 app >>= \ a -> go2 (k a) - go2 (Ap' g h) = go2 g <*> go2 h - go2 (Alt' m1 m2) = go2 m1 <|> go2 m2 - go2 Empty' = empty - go2 (Throw e) = lift $ do - ()<-discharge id - throwM e - go2 (Catch m h) = catch (go2 m) (go2 . h) - - go :: forall a . T.RemoteApplicative p a -> Wrapper (RemoteApplicative p) a - go (T.Empty) = empty - go (T.Pure a) = pure a - go (T.Procedure p) = Value (T.Procedure p) - go (T.Ap g h) = (go g) <*> (go h) - go (T.Alt g h) = (go g) <|> (go h) - - -- g is a function that will take the current state as input - discharge :: forall a f . Applicative f => (f () ->RemoteApplicative p a )-> StateT (f ()) m a - discharge g = do - ap' <- get - put (pure ()) -- clear state - case pk $ g ap' of - PureQ a -> return a - PktQ f pkt -> do - res <- lift $ rf pkt - return $ f res - -- Given a wrapped applicative discharge via local monad - unwrap :: forall a . Wrapper(RemoteApplicative p) a -> StateT (RemoteApplicative p ()) m a - unwrap (Value ap) = case superApplicative ap of - Nothing ->do - discharge $ \ap' -> (ap' *> ap) - Just a ->do - modify (\ap' -> ap' <* ap) - return a - - unwrap (Throw' ap) = do - discharge $ \ap' -> (ap' <* ap) - throwM RemoteEmptyException - - -- Do we know the answer? Nothing = we need to get it - superApplicative :: RemoteApplicative p a -> Maybe a - superApplicative (T.Pure a) = pure a - superApplicative (T.Procedure p) = Nothing - superApplicative (T.Ap g h) = (superApplicative g) <*> (superApplicative h) - superApplicative (T.Alt g h) = Nothing - superApplicative (T.Empty) = Nothing + -- Either A or a Packet to return A + pk :: RemoteApplicative q a -> X ApplicativePacket q a + pk (T.Pure a) = Pure' a + pk (T.Query q) = Pkt id $ A.Query q + pk (T.Ap g h) = case (pk g, pk h) of + (Pure' a, Pure' b) -> Pure' (a b) + (Pure' a, Pkt f b) -> Pkt (\b' -> a (f b')) b + (Pkt f a, Pure' b) -> Pkt (\a' -> f a' b) a + (Pkt f a, Pkt g b) -> Pkt id $ A.Zip (\ a' b' -> f a' (g b')) a b +-- | The is the strong applicative strong remote monad. It bundles +-- packets (of type 'RemoteApplicative') as large as possible, +-- including over some monadic binds. +runQueryMonad :: forall m q . (MonadCatch m) => (Q.QueryPacket q :~> m) -> (RemoteMonad q :~> m) +runQueryMonad f = runApplicative f (wrapNT pk) (wrapNT helper) + where -- Either A or a Packet to return A - pk :: RemoteApplicative p a -> QueryX p a - pk (T.Pure a) = PureQ a - pk (T.Procedure p) = PktQ id $ Q.QueryPacket $ A.Procedure p - pk (T.Ap g h) = case (pk g, pk h) of - (PureQ a, PureQ b) -> PureQ (a b) - (PureQ a, PktQ f b) -> PktQ (\b' -> a (f b')) b - (PktQ f a, PureQ b) -> PktQ (\a' -> f a' b) a - (PktQ f (Q.QueryPacket a), PktQ g (Q.QueryPacket b)) -> PktQ id $ Q.QueryPacket $ A.Zip (\ a' b' -> f a' (g b')) a b + pk :: RemoteApplicative q a -> X QueryPacket q a + pk (T.Pure a) = Pure' a + pk (T.Query p) = Pkt id $ QueryPacket $ A.Query p + pk (T.Ap g h) = case (pk g, pk h) of + (Pure' a, Pure' b) -> Pure' (a b) + (Pure' a, Pkt f b) -> Pkt (\b' -> a (f b')) b + (Pkt f a, Pure' b) -> Pkt (\a' -> f a' b) a + (Pkt f (QueryPacket a), Pkt g (QueryPacket b)) -> Pkt id $ QueryPacket $ A.Zip (\ a' b' -> f a' (g b')) a b + helper:: RemoteMonad q a -> RemoteMonad q a helper (Ap' x@(Ap' _ _) y@(Ap' _ _)) = helper x <*> helper y helper (Ap' (Bind m1 k1) (Bind m2 k2) ) = liftA2 (,) (helper m1) (helper m2) >>= @@ -258,20 +214,16 @@ runQueryMonad (NT rf) = wrapNT $ \ p -> do helper (Bind m k) = (helper m) >>= \ x -> helper (k x) helper x = x -data QueryX p a where - PureQ :: a -> QueryX p a - PktQ :: (a -> b) -> Q.QueryPacket p a -> QueryX p b - -runAlternativeMonad :: forall m p . (MonadCatch m) => (Alt.AlternativePacket p :~> m) -> (RemoteMonad p :~> m) -runAlternativeMonad (NT rf) = wrapNT $ \ p -> do - (r,h) <- runStateT (runMaybeT (go2 p)) (pure ()) +runAlternativeMonad :: forall m q . (MonadCatch m) => (Alt.AlternativePacket q :~> m) -> (RemoteMonad q :~> m) +runAlternativeMonad (NT rf) = wrapNT $ \ q -> do + (r,h) <- runStateT (runMaybeT (go2 q)) (pure ()) () <- rf $ pk h case r of Nothing -> throwM RemoteEmptyException Just v -> return v where - go2 :: forall a . RemoteMonad p a -> MaybeT (StateT (RemoteApplicative p ()) m) a + go2 :: forall a . RemoteMonad q a -> MaybeT (StateT (RemoteApplicative q ()) m) a go2 (Appl app) = lift $ go app go2 (Bind app k) = go2 app >>= \ a -> go2 (k a) go2 (Ap' g h) = go2 g <*> go2 h @@ -282,7 +234,7 @@ runAlternativeMonad (NT rf) = wrapNT $ \ p -> do throwM e go2 (Catch m h) = catch (go2 m) (go2 . h) - go :: RemoteApplicative p a -> StateT (RemoteApplicative p ()) m a + go :: RemoteApplicative q a -> StateT (RemoteApplicative q ()) m a go ap = case superApplicative ap of Nothing -> do discharge $ \ ap' -> ap' *> ap @@ -290,26 +242,23 @@ runAlternativeMonad (NT rf) = wrapNT $ \ p -> do modify (\ap' -> ap' <* ap) return a - pk :: forall a . RemoteApplicative p a -> Alt.AlternativePacket p a - pk (T.Empty) = empty - pk (T.Pure a) = pure a - pk (T.Procedure p) = (Alt.Procedure p) - pk (T.Ap g h) = (pk g) <*> (pk h) - pk (T.Alt g h) = (pk g) <|> (pk h) + pk :: forall a . RemoteApplicative q a -> Alt.AlternativePacket q a + pk (T.Empty) = empty + pk (T.Pure a) = pure a + pk (T.Query q) = (Alt.Query q) + pk (T.Ap g h) = (pk g) <*> (pk h) + pk (T.Alt g h) = (pk g) <|> (pk h) -- g is a function that will take the current state as input - discharge :: forall a f . Applicative f => (f () ->RemoteApplicative p a )-> StateT (f ()) m a + discharge :: forall a f . Applicative f => (f () ->RemoteApplicative q a )-> StateT (f ()) m a discharge g = do ap' <- get put (pure ()) -- clear state lift $ rf $ pk $ g ap' - superApplicative :: RemoteApplicative p a -> Maybe a - superApplicative (T.Empty) = Nothing - superApplicative (T.Pure a) = pure a - superApplicative (T.Procedure p) = Nothing - superApplicative (T.Ap g h) = (superApplicative g) <*> (superApplicative h) - superApplicative (T.Alt g h) = (superApplicative g) <|> (superApplicative h) - - - + superApplicative :: RemoteApplicative q a -> Maybe a + superApplicative (T.Empty) = Nothing + superApplicative (T.Pure a) = pure a + superApplicative (T.Query _q) = Nothing + superApplicative (T.Ap g h) = (superApplicative g) <*> (superApplicative h) + superApplicative (T.Alt g h) = (superApplicative g) <|> (superApplicative h) diff --git a/src/Control/Remote/WithoutAsync/Monad/Types.hs b/src/Control/Remote/WithoutAsync/Monad/Types.hs index d7132d7..3d80792 100644 --- a/src/Control/Remote/WithoutAsync/Monad/Types.hs +++ b/src/Control/Remote/WithoutAsync/Monad/Types.hs @@ -27,36 +27,36 @@ import Control.Monad.Trans.Class import Control.Remote.WithoutAsync.Applicative.Types -- | 'RemoteMonad' is our monad that can be executed in a remote location. -data RemoteMonad (proc:: * -> *) a where - Appl :: RemoteApplicative proc a -> RemoteMonad proc a - Bind :: RemoteMonad proc a -> (a -> RemoteMonad proc b) -> RemoteMonad proc b - Ap' :: RemoteMonad proc (a -> b) -> RemoteMonad proc a -> RemoteMonad proc b - Alt' :: RemoteMonad proc a -> RemoteMonad proc a -> RemoteMonad proc a - Empty' :: RemoteMonad proc a - Throw :: Exception e => e -> RemoteMonad proc a - Catch :: Exception e => RemoteMonad proc a -> (e -> RemoteMonad proc a)-> RemoteMonad proc a +data RemoteMonad (q:: * -> *) a where + Appl :: RemoteApplicative q a -> RemoteMonad q a + Bind :: RemoteMonad q a -> (a -> RemoteMonad q b) -> RemoteMonad q b + Ap' :: RemoteMonad q (a -> b) -> RemoteMonad q a -> RemoteMonad q b + Alt' :: RemoteMonad q a -> RemoteMonad q a -> RemoteMonad q a + Empty' :: RemoteMonad q a + Throw :: Exception e => e -> RemoteMonad q a + Catch :: Exception e => RemoteMonad q a -> (e -> RemoteMonad q a)-> RemoteMonad q a -instance Functor (RemoteMonad proc) where +instance Functor (RemoteMonad q) where fmap f m = pure f <*> m -instance Applicative (RemoteMonad proc) where +instance Applicative (RemoteMonad q) where pure a = Appl (pure a) Appl f <*> Appl g = Appl (f <*> g) f <*> g = Ap' f g -instance Monad (RemoteMonad proc) where +instance Monad (RemoteMonad q) where return = pure m >>= k = Bind m k Empty' >> m2 = Empty' m1 >> m2 = m1 *> m2 -- This improves our bundling opportunities -instance MonadThrow (RemoteMonad proc) where +instance MonadThrow (RemoteMonad q) where throwM e = Throw e -instance MonadCatch (RemoteMonad proc) where +instance MonadCatch (RemoteMonad q) where catch m f = Catch m f -instance Alternative (RemoteMonad proc) where +instance Alternative (RemoteMonad q) where empty = Empty' Empty' <|> p = p Appl g <|> Appl h = Appl (g <|> h) diff --git a/src/Control/Remote/WithoutAsync/Packet.hs b/src/Control/Remote/WithoutAsync/Packet.hs index d52c589..a9cc8a4 100644 --- a/src/Control/Remote/WithoutAsync/Packet.hs +++ b/src/Control/Remote/WithoutAsync/Packet.hs @@ -24,29 +24,29 @@ import Control.Natural import Control.Applicative class Promote f where - promote :: (Applicative m) => (Weak.WeakPacket p :~> m) -> (f p :~> m) + promote :: (Applicative m) => (Weak.WeakPacket q :~> m) -> (f q :~> m) instance Promote A.ApplicativePacket where promote f = promoteToApplicative f -- | promotes a function that can work over WeakPackets to a function that can work over Alternative Packets -promoteToAlternative :: forall p m . (Alternative m) => (Weak.WeakPacket p :~> m) -> (Alt.AlternativePacket p :~> m) +promoteToAlternative :: forall q m . (Alternative m) => (Weak.WeakPacket q :~> m) -> (Alt.AlternativePacket q :~> m) promoteToAlternative (NT f) = NT $ alternativeFunc where - alternativeFunc :: (Alternative m) => (Alt.AlternativePacket p a -> m a) - alternativeFunc (Alt.Procedure p) = f (Weak.Procedure p) + alternativeFunc :: (Alternative m) => (Alt.AlternativePacket q a -> m a) + alternativeFunc (Alt.Query q) = f (Weak.Query q) alternativeFunc (Alt.Zip f1 a b) = f1 <$> alternativeFunc a <*> alternativeFunc b alternativeFunc (Alt.Alt a b) = alternativeFunc a <|> alternativeFunc b alternativeFunc (Alt.Pure a) = pure a -- | promotes a function that can work over WeakPackets to a function that can work over Applicative Packets -promoteToApplicative :: forall p m . (Applicative m) => (Weak.WeakPacket p :~> m) -> (A.ApplicativePacket p :~> m) +promoteToApplicative :: forall q m . (Applicative m) => (Weak.WeakPacket q :~> m) -> (A.ApplicativePacket q :~> m) promoteToApplicative (NT f) = NT $ applicativeFunc where - applicativeFunc :: (Applicative m) => (A.ApplicativePacket p a -> m a) - applicativeFunc (A.Procedure p) = f (Weak.Procedure p) + applicativeFunc :: (Applicative m) => (A.ApplicativePacket q a -> m a) + applicativeFunc (A.Query p) = f (Weak.Query p) applicativeFunc (A.Zip f1 a b) = f1 <$> applicativeFunc a <*> applicativeFunc b applicativeFunc (A.Pure a) = pure a diff --git a/src/Control/Remote/WithoutAsync/Packet/Alternative.hs b/src/Control/Remote/WithoutAsync/Packet/Alternative.hs index 0210253..7e8df8e 100644 --- a/src/Control/Remote/WithoutAsync/Packet/Alternative.hs +++ b/src/Control/Remote/WithoutAsync/Packet/Alternative.hs @@ -29,24 +29,24 @@ import Control.Natural -- | A Remote Applicative, that can encode both commands and procedures, bundled together. -data AlternativePacket (p :: * -> *) (a :: *) where - Procedure :: p a -> AlternativePacket p a - Zip :: (x -> y -> z) - -> AlternativePacket p x - -> AlternativePacket p y -> AlternativePacket p z - Pure :: a -> AlternativePacket p a - Alt :: AlternativePacket p a - -> AlternativePacket p a -> AlternativePacket p a - Empty :: AlternativePacket p a - -instance Functor (AlternativePacket p) where +data AlternativePacket (q :: * -> *) (a :: *) where + Query :: q a -> AlternativePacket q a + Zip :: (x -> y -> z) + -> AlternativePacket q x + -> AlternativePacket q y -> AlternativePacket q z + Pure :: a -> AlternativePacket q a + Alt :: AlternativePacket q a + -> AlternativePacket q a -> AlternativePacket q a + Empty :: AlternativePacket q a + +instance Functor (AlternativePacket q) where fmap f g = pure f <*> g -instance Applicative (AlternativePacket p) where +instance Applicative (AlternativePacket q) where pure a = Pure a g <*> h = Zip ($) g h -instance Alternative (AlternativePacket p) where +instance Alternative (AlternativePacket q) where g <|> h = g `Alt` h empty = Empty diff --git a/src/Control/Remote/WithoutAsync/Packet/Applicative.hs b/src/Control/Remote/WithoutAsync/Packet/Applicative.hs index 7d83121..dda94cf 100644 --- a/src/Control/Remote/WithoutAsync/Packet/Applicative.hs +++ b/src/Control/Remote/WithoutAsync/Packet/Applicative.hs @@ -26,16 +26,16 @@ import Control.Natural -- | A Remote Applicative, that can encode both commands and procedures, bundled together. -data ApplicativePacket (p :: * -> *) (a :: *) where - Procedure :: p a -> ApplicativePacket p a +data ApplicativePacket (q :: * -> *) (a :: *) where + Query :: q a -> ApplicativePacket q a Zip :: (x -> y -> z) - -> ApplicativePacket p x - -> ApplicativePacket p y -> ApplicativePacket p z - Pure :: a -> ApplicativePacket p a + -> ApplicativePacket q x + -> ApplicativePacket q y -> ApplicativePacket q z + Pure :: a -> ApplicativePacket q a -instance Functor (ApplicativePacket p) where +instance Functor (ApplicativePacket q) where fmap f g = pure f <*> g -instance Applicative (ApplicativePacket p) where +instance Applicative (ApplicativePacket q) where pure a = Pure a g <*> h = Zip ($) g h diff --git a/src/Control/Remote/WithoutAsync/Packet/Weak.hs b/src/Control/Remote/WithoutAsync/Packet/Weak.hs index 73c24bf..e3feaad 100644 --- a/src/Control/Remote/WithoutAsync/Packet/Weak.hs +++ b/src/Control/Remote/WithoutAsync/Packet/Weak.hs @@ -19,14 +19,14 @@ import Control.Remote.WithoutAsync.Packet.Transport -- | A Weak Packet, that can encode a command or a procedure. -data WeakPacket (p :: * -> *) (a :: *) where - Procedure :: p a -> WeakPacket p a +data WeakPacket (q :: * -> *) (a :: *) where + Query :: q a -> WeakPacket q a -deriving instance Show (p a) => Show (WeakPacket p a) +deriving instance Show (q a) => Show (WeakPacket q a) -instance Read (Transport p) => Read (Transport (WeakPacket p)) where +instance Read (Transport q) => Read (Transport (WeakPacket q)) where readsPrec d = readParen (d > 10) $ \ r0 -> - [ (Transport $ Procedure p,r2) - | ("Procedure",r1) <- lex r0 - , (Transport p,r2) <- readsPrec 11 r1 + [ (Transport $ Query q,r2) + | ("Query",r1) <- lex r0 + , (Transport q,r2) <- readsPrec 11 r1 ]