distributed-closure 0.4.0 → 0.4.1

raw patch · 6 files changed

+191/−45 lines, 6 filesdep +asyncdep ~basedep ~binarynew-component:exe:example-client-serverPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: async

Dependency ranges changed: base, binary

API changes (from Hackage documentation)

Files

• README.md +5/−0
• distributed-closure.cabal +12/−1
• examples/ClientServer.hs +115/−0
• src/Control/Distributed/Closure.hs +9/−0
• src/Control/Distributed/Closure/TH.hs +8/−2
• tests/test.hs +42/−42

@@ -35,6 +35,11 @@   spawn "someAddress" (static hello `cap` name) ``` +An example of sending static pointers and closures+through a communication channel is provided under+[examples/ClientServer.hs](examples/ClientServer.hs)+in the source repository.+ `distributed-closure` does not implement sending/receiving/spawning closures - that's left for higher-level frameworks. Only closure creation, composition and (de)serialization.

@@ -1,5 +1,5 @@ name:                distributed-closure-version:             0.4.0+version:             0.4.1 synopsis:            Serializable closures for distributed programming. description:         See README. homepage:            https://github.com/tweag/distributed-closure@@ -49,3 +49,14 @@                     distributed-closure,                     hspec >= 2.1,                     QuickCheck >= 2.8++executable example-client-server+  main-is:          ClientServer.hs+  hs-source-dirs:   examples+  default-language: Haskell2010+  ghc-options:      -Wall+  build-depends:    base >= 4.8+                  , async >= 2.1+                  , binary >= 0.7+                  , bytestring >= 0.10+                  , distributed-closure

@@ -0,0 +1,115 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StaticPointers #-}+{-# LANGUAGE TemplateHaskell #-}++import Control.Concurrent.Async+import Control.Concurrent.Chan+import Control.Distributed.Closure+import Control.Distributed.Closure.TH+import Control.Monad (forever)+import Data.Binary+import qualified Data.ByteString.Lazy as BSL+import Data.Functor.Static+import Data.Typeable (Typeable)+import GHC.Generics+import GHC.StaticPtr++-- | An instruction to the server.+data Instruction+  = CallStatic StaticKey Int+    -- ^ @CallStatic skFun arg@+    --+    -- Apply the function behind the 'StaticKey' @skFun@ to @arg@.+  | CallClosure (Closure (Int -> Int)) Int+    -- ^ @CallClosure cl arg@+    --+    -- Apply the closure @cl@ to @arg@.+  deriving Generic+instance Binary Instruction++-- | Handle an instruction by the client.+--+-- This is where we resolve a 'StaticKey'+-- by looking up the 'StaticPtr' and dereferencing it.+--+-- This is also where we resolve a 'Closure'.+handleInstruction :: Instruction -> IO (Maybe Int)+handleInstruction (CallStatic skey input) = do+  mbSPtr <- unsafeLookupStaticPtr skey+  return $ case mbSPtr of+    Nothing -> Nothing+    Just sptr ->+      let fun = deRefStaticPtr sptr in+      Just $ fun input+handleInstruction (CallClosure cl input) =+  let fun = unclosure cl in+  return $ Just $ fun input++-- | Channel to which a client will send its request.+type ServerChan = Chan (BSL.ByteString, ResponseChan)++-- | Channel to which the server will send its response.+type ResponseChan = Chan BSL.ByteString++-- | Execute an action with a concurrent server thread.+--+-- This mocks a network connection between a client and a server process.+-- For simplicity, the client and server run within the same process+-- and communicate through 'Chan's instead of sockets.+--+-- The server listens on a channel for requests.+-- The client sends requests on that channel together with a response channel.+-- The server handles the request and sends the result on the response channel.+withServer :: (ServerChan -> IO ()) -> IO ()+withServer action = do+  serverChan <- newChan+  let server = forever $ do+        (body, responseChan) <- readChan serverChan+        result <- case decodeOrFail body of+          Left _ -> return Nothing+          Right (_, _, instruction) -> handleInstruction instruction+        writeChan responseChan (encode result)+  withAsync server (\_ -> action serverChan)++-- | A global function that can be packed into a 'CallStatic' instruction.+double :: Int -> Int+double = (*2)++-- | A wrapper around 'Int' used to fulfill the 'Serializable' constraint,+-- so that it can be packed into a 'Closure'.+newtype SerializableInt = SI Int deriving (Generic, Typeable)+withStatic [d|+  instance Binary SerializableInt+  instance Typeable SerializableInt+  |]++-- | Demonstration of client server interactions.+main :: IO ()+main = withServer $ \serverChan -> do+  do+    clientChan <- newChan+    -- Obtain the 'StaticPtr' to the global function 'double'+    -- using the 'static' keyword, enabled by the 'StaticPointers' extension.+    -- Convert the 'StaticPtr' into a 'StaticKey' using 'staticKey',+    -- so that it can be sent across the wire.+    let fun = staticKey $ static double+        request = encode $ CallStatic fun 4+    writeChan serverChan (request, clientChan)+    result <- decode <$> readChan clientChan+    putStrLn $ "double 4 = " ++ show (result :: Maybe Int)+  do+    clientChan <- newChan+    -- Construct a 'Closure' that effectively captures a value+    -- and represents a partially applied function.+    -- The 'static' keyword is used to convert a lambda,+    -- that doesn't capture any free variables, into a 'StaticPtr'.+    -- Then we use 'staticMap' to partially apply the lambda within the closure.+    let three = SI 3+        c = static (\(SI a) b -> a + b)+          `staticMap` cpure closureDict three+        request = encode $ CallClosure c 4+    writeChan serverChan (request, clientChan)+    result <- decode <$> readChan clientChan+    putStrLn $ "3 + 4 = " ++ show (result :: Maybe Int)

@@ -11,6 +11,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StaticPointers #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 800@@ -39,6 +40,7 @@ import Control.Distributed.Closure.Internal import Data.Binary (Binary) import Data.Constraint (Dict(..))+import Data.Typeable (Typeable)  -- $static-dicts --@@ -58,6 +60,13 @@ -- 'Control.Distributed.Closure.TH.withStatic' if it becomes too tedious. class c => Static c where   closureDict :: Closure (Dict c)++instance (Static c1, Static c2, Typeable c1, Typeable c2, (c1, c2)) => Static (c1, c2) where+  closureDict = static pairDict `cap` closureDict `cap` closureDict++-- Needs to be defined at top-level for GHC <8.4 compat.+pairDict :: Dict c1 -> Dict c2 -> Dict (c1, c2)+pairDict Dict Dict = Dict  -- | A newtype-wrapper useful for defining instances of classes indexed by -- higher-kinded types.

@@ -92,7 +92,9 @@ -- @ -- -- You will probably want to enable @FlexibleContexts@ and @ScopedTypeVariables@--- in modules that use 'withStatic'.+-- in modules that use 'withStatic'. 'withStatic' can also handle non-user+-- generated instances like 'Typeable' instances: just write @instance Typeable+-- T@. withStatic :: TH.DecsQ -> TH.DecsQ withStatic = (>>= go)   where@@ -140,5 +142,9 @@         let staticins = TH.InstanceD staticcxt statichd methods #endif         decls' <- go decls-        return (ins : sigf : declf : staticins : decls')+        case hd of+          TH.AppT (TH.ConT nm) _ | nm == ''Typeable ->+            return (sigf : declf : staticins : decls')+          _ ->+            return (ins : sigf : declf : staticins : decls')     go (decl:decls) = (decl:) <$> go decls

@@ -19,7 +19,7 @@ import GHC.StaticPtr import Test.Hspec import Test.Hspec.QuickCheck-import Test.QuickCheck+import qualified Test.QuickCheck as QC  data T a = T a data T1 a b = T1 a b@@ -38,16 +38,16 @@ -- * Basic generators (parameterized by size)  -- | Generates a basic closure using @cpure@-genPure :: forall a. (Static (Serializable a), Arbitrary a) => Int -> Gen (Closure a)+genPure :: forall a. (Static (Serializable a), QC.Arbitrary a) => Int -> QC.Gen (Closure a) genPure i =     cpure (closureDict :: Closure (Dict (Serializable a))) <$>-      resize (max 0 (i-1)) arbitrary+      QC.resize (max 0 (i-1)) QC.arbitrary  -- | Generates a basic closure using @closure@-genStatic :: Arbitrary (StaticPtr a) => Int -> Gen (Closure a)+genStatic :: QC.Arbitrary (StaticPtr a) => Int -> QC.Gen (Closure a) -- static pointers are considered to contribute 0 to the size, hence ignore the -- size parameter.-genStatic _i = closure <$> arbitrary+genStatic _i = closure <$> QC.arbitrary  -- | Reifies basic datatypes (they must be @Serializable@ types). Only two types -- here because we already have to enumerate a lot of cases manually (see below).@@ -55,18 +55,18 @@   TInt :: Type Int   TBool :: Type Bool -instance Static (Serializable Int) where-  closureDict = static Dict+instance Static (Binary Int) where closureDict = static Dict+instance Static (Typeable Int) where closureDict = static Dict -instance Static (Serializable Bool) where-  closureDict = static Dict+instance Static (Binary Bool) where closureDict = static Dict+instance Static (Typeable Bool) where closureDict = static Dict  -- | Existentially quantified version of 'Type'. So that they can be generated. data AType where AType :: Typeable a => Type a -> AType -instance Arbitrary (AType) where+instance QC.Arbitrary (AType) where   arbitrary =-      elements [ AType TInt, AType TBool ]+      QC.elements [ AType TInt, AType TBool ]  -- | Composed types. Very few choices because of the combinatorics. data Sig a where@@ -82,7 +82,7 @@ push _ (Two _ _ _) = Nothing  -- | Non-recursive generator of atomic values for each type.-genSimple :: Sig a -> Int -> Gen (Closure a)+genSimple :: Sig a -> Int -> QC.Gen (Closure a) genSimple (Zero TInt) = genPure genSimple (Zero TBool) = genPure genSimple (One TInt TInt) = genStatic@@ -100,14 +100,14 @@  gflip   :: (Typeable a, Typeable b, Typeable c)-  => (Int -> Gen (Closure (a->b->c))) -> Int -> Gen (Closure (b->a->c))+  => (Int -> QC.Gen (Closure (a->b->c))) -> Int -> QC.Gen (Closure (b->a->c)) gflip g i = (cap (static flip)) <$> g i  gap   :: Typeable a-  => (Int -> Gen (Closure (a->b)))-  -> (Int -> Gen (Closure a))-  -> Int -> Gen (Closure b)+  => (Int -> QC.Gen (Closure (a->b)))+  -> (Int -> QC.Gen (Closure a))+  -> Int -> QC.Gen (Closure b) gap gf gx i = do   f <- gf i   x <- gx i@@ -115,18 +115,18 @@  -- | Generate closures of a given type by randomly choosing to make the closure -- a 'cap'. Stays within the boundaries of 'Sig' so that the type of the--- function is also 'Arbitrary'.-genClosure :: Sig a -> Int -> Gen (Closure a)+-- function is also 'QC.Arbitrary'.+genClosure :: Sig a -> Int -> QC.Gen (Closure a) genClosure sig size | size < 10 =     genSimple sig size genClosure sig size = do-    stop <- frequency [(2, return True), (1, return False)]+    stop <- QC.frequency [(2, return True), (1, return False)]     if stop then       genSimple sig size     else do       let upper = div size 3           lower = max 0 (size - 1 - upper)-      AType pivot <- arbitrary+      AType pivot <- QC.arbitrary       case push pivot sig of         Nothing -> genSimple sig size         Just sig' -> do@@ -141,30 +141,30 @@ -- Must be from explicit lists since static pointers are, well, static. The -- combinatorics is unpleasant. -instance Arbitrary (StaticPtr (Int -> Int)) where+instance QC.Arbitrary (StaticPtr (Int -> Int)) where   arbitrary =-      elements+      QC.elements         [ static id         , static pred         , static succ         , static (3*)         ] -instance Arbitrary (StaticPtr (Bool -> Int)) where+instance QC.Arbitrary (StaticPtr (Bool -> Int)) where   arbitrary =-      elements+      QC.elements        [ static (bool 0 1)        , static (bool 57 42)] -instance Arbitrary (StaticPtr (Bool -> Bool)) where+instance QC.Arbitrary (StaticPtr (Bool -> Bool)) where   arbitrary =-    elements+    QC.elements       [ static id       , static not ] -instance Arbitrary (StaticPtr (Int -> Int -> Int)) where+instance QC.Arbitrary (StaticPtr (Int -> Int -> Int)) where   arbitrary =-      elements+      QC.elements         [ static const         , static (+)         , static (*)@@ -172,24 +172,24 @@         , static (\x y -> 2*x + y)         ] -instance Arbitrary (StaticPtr (Int -> Bool -> Int)) where+instance QC.Arbitrary (StaticPtr (Int -> Bool -> Int)) where   arbitrary =-    elements+    QC.elements       [ static const       , static (\n b -> if b then n else -n)       , static (bool 0)       ] -instance Arbitrary (StaticPtr (Bool -> Bool -> Int)) where+instance QC.Arbitrary (StaticPtr (Bool -> Bool -> Int)) where   arbitrary =-    elements+    QC.elements       [ static (\x y -> bool 0 1 (x&&y))       , static (\x y -> bool 57 42 (x||y))       ] -instance Arbitrary (StaticPtr (Int -> Int -> Bool)) where+instance QC.Arbitrary (StaticPtr (Int -> Int -> Bool)) where   arbitrary =-    elements+    QC.elements       [ static (==)       , static (>=)       , static (<=)@@ -197,28 +197,28 @@       , static (>)       ] -instance Arbitrary (StaticPtr (Bool -> Int -> Bool)) where+instance QC.Arbitrary (StaticPtr (Bool -> Int -> Bool)) where   arbitrary =-    elements+    QC.elements       [ static const       , static (\b n -> b && (n >= 0))       , static (\b n -> b || (n < 0))       , static (\b n -> if b then n >=0 else n < 0)       ] -instance Arbitrary (StaticPtr (Bool -> Bool -> Bool)) where+instance QC.Arbitrary (StaticPtr (Bool -> Bool -> Bool)) where   arbitrary =-    elements+    QC.elements       [ static (&&)       , static (||)]  -- * Instances -instance Arbitrary (Closure Int) where-  arbitrary = sized $ genClosure (Zero TInt)+instance QC.Arbitrary (Closure Int) where+  arbitrary = QC.sized $ genClosure (Zero TInt) -instance Arbitrary (Closure (Int -> Int)) where-  arbitrary = sized $ genClosure (One TInt TInt)+instance QC.Arbitrary (Closure (Int -> Int)) where+  arbitrary = QC.sized $ genClosure (One TInt TInt)  instance Show (Closure a) where   show _ = "<closure>"