Code beautification, combined query packet and applicative packet log…

…ic, added query example

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
+

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

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)

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