Initial commit.

LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2015, Tweag I/O Limited
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Mathieu Boespflug nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

distributed-closure.cabal

@@ -0,0 +1,27 @@
+name:                distributed-closure
+version:             0.1.0.0
+synopsis:            Serializable closures for distributed programming.
+-- description:
+homepage:            github.com/tweag/distributed-closure
+license:             BSD3
+license-file:        LICENSE
+author:              Mathieu Boespflug
+maintainer:          m@tweag.io
+copyright:           © Tweag I/O Limited
+category:            Control
+build-type:          Simple
+-- extra-source-files:
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     Control.Distributed.Closure
+                       Control.Distributed.Closure.Internal
+                       Control.Distributed.Closure.TH
+  build-depends:       base >=4.8
+                     , binary >= 0.7
+                     , bytestring >= 0.10
+                     , constraints >= 0.4
+                     , semigroupoids >= 4
+                     , template-haskell >= 2.10
+  hs-source-dirs:      src
+  default-language:    Haskell2010

src/Control/Distributed/Closure.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | Serializable closures for distributed programming.
+
+{-# OPTIONS_GHC -funbox-strict-fields #-}
+
+module Control.Distributed.Closure
+  ( Serializable
+    -- * Closures
+  , Closure
+  , closure
+  , unclosure
+  , cpure
+  , cap
+    -- * Closure dictionaries
+  , Dict(..)
+  , ClosureDict(..)
+  ) where
+
+import           Control.Distributed.Closure.TH
+import           Control.Distributed.Closure.Internal
+import           Data.Constraint (Dict(..))

src/Control/Distributed/Closure/Internal.hs

@@ -0,0 +1,173 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE StaticPointers #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-# OPTIONS_GHC -funbox-strict-fields #-}
+
+module Control.Distributed.Closure.Internal where
+
+import           Data.Binary (Binary, decode, encode)
+import           Data.Constraint (Dict(..), (:-)(..), mapDict)
+import           Data.Typeable (Typeable)
+import qualified Data.ByteString.Lazy as BSL
+import           Data.ByteString.Lazy (ByteString)
+import           GHC.StaticPtr
+
+class (Binary a, Typeable a) => Serializable a
+instance (Binary a, Typeable a) => Serializable a
+
+-- | Type of serializable closures. Abstractly speaking, a closure is a code
+-- reference paired together with an environment. A serializable closure
+-- includes a /shareable/ code reference (i.e. a 'StaticPtr'). Closures can be
+-- serialized only if all expressions captured in the environment are
+-- serializable.
+data Closure a where
+  StaticPtr :: !(StaticPtr b) -> Closure b
+  Encoded :: !ByteString -> Closure ByteString
+  Ap :: !(Closure (b -> c)) -> !(Closure b) -> Closure c
+  Closure :: Closure a -> a -> Closure a
+
+-- | Lift a Static pointer to a closure with an empty environment.
+closure :: StaticPtr a -> Closure a
+closure = StaticPtr
+
+unstatic = undefined
+
+-- | Resolve a 'Closure' to the value that it represents.
+unclosure :: Closure a -> a
+unclosure (StaticPtr sptr) = unstatic sptr
+unclosure (Encoded x) = x
+unclosure (Ap cf cx) = (unstatic cf) (unstatic cx)
+unclosure (Closure cx x) = x
+
+decodeD :: Dict (Serializable a) -> ByteString -> a
+decodeD Dict = decode
+
+-- | A closure can be created from any serializable value. 'cpure' corresponds
+-- to "Control.Applicative"'s 'Control.Applicative.pure', but restricted to
+-- lifting serializable values only.
+cpure :: ClosureDict (Serializable a) => a -> Closure a
+cpure x =
+    StaticPtr (static decodeD) `cap`
+    closureDict `cap`
+    Encoded (encode x)
+
+-- | Closure application. Note that 'Closure' is not a functor, let alone an
+-- applicative functor, even if it too has a meaningful notion of application.
+cap :: Closure (a -> b) -> Closure a -> Closure b
+cap = Ap
+
+-- | Reify constraints as /static dictionaries/. That is, obtain
+-- a representation as a first class value of the implicit dictionary
+-- corresponding to type class constraints in function signatures. This value
+-- can be passed around and serialized, just like any other 'Closure'.
+class c => ClosureDict c where
+  -- | A static dictionary corresponding to the instance.
+  closureDict :: Closure (Dict c)
+
+instance ClosureDict () where
+  closureDict = closure (static Dict)
+
+instance (ClosureDict a, Typeable a, ClosureDict b, Typeable b)
+      => ClosureDict (a, b) where
+  closureDict =
+    closure (static (\Dict Dict -> Dict))
+      `cap` (closureDict :: Closure (Dict a))
+      `cap` (closureDict :: Closure (Dict b))
+
+instance ( ClosureDict a, Typeable a
+         , ClosureDict b, Typeable b
+         , ClosureDict c, Typeable c
+         ) => ClosureDict (a, b, c) where
+  closureDict =
+    closure (static (\Dict Dict Dict -> Dict))
+      `cap` (closureDict :: Closure (Dict a))
+      `cap` (closureDict :: Closure (Dict b))
+      `cap` (closureDict :: Closure (Dict c))
+
+instance ( ClosureDict a, Typeable a
+         , ClosureDict b, Typeable b
+         , ClosureDict c, Typeable c
+         , ClosureDict d, Typeable d
+         ) => ClosureDict (a, b, c, d) where
+  closureDict =
+    closure (static (\Dict Dict Dict Dict -> Dict))
+      `cap` (closureDict :: Closure (Dict a))
+      `cap` (closureDict :: Closure (Dict b))
+      `cap` (closureDict :: Closure (Dict c))
+      `cap` (closureDict :: Closure (Dict d))
+
+instance ( ClosureDict a, Typeable a
+         , ClosureDict b, Typeable b
+         , ClosureDict c, Typeable c
+         , ClosureDict d, Typeable d
+         , ClosureDict e, Typeable e
+         ) => ClosureDict (a, b, c, d, e) where
+  closureDict =
+    closure (static (\Dict Dict Dict Dict Dict -> Dict))
+      `cap` (closureDict :: Closure (Dict a))
+      `cap` (closureDict :: Closure (Dict b))
+      `cap` (closureDict :: Closure (Dict c))
+      `cap` (closureDict :: Closure (Dict d))
+      `cap` (closureDict :: Closure (Dict e))
+
+instance ( ClosureDict a, Typeable a
+         , ClosureDict b, Typeable b
+         , ClosureDict c, Typeable c
+         , ClosureDict d, Typeable d
+         , ClosureDict e, Typeable e
+         , ClosureDict f, Typeable f
+         ) => ClosureDict (a, b, c, d, e, f) where
+  closureDict =
+    closure (static (\Dict Dict Dict Dict Dict Dict -> Dict))
+      `cap` (closureDict :: Closure (Dict a))
+      `cap` (closureDict :: Closure (Dict b))
+      `cap` (closureDict :: Closure (Dict c))
+      `cap` (closureDict :: Closure (Dict d))
+      `cap` (closureDict :: Closure (Dict e))
+      `cap` (closureDict :: Closure (Dict f))
+
+instance ( ClosureDict a, Typeable a
+         , ClosureDict b, Typeable b
+         , ClosureDict c, Typeable c
+         , ClosureDict d, Typeable d
+         , ClosureDict e, Typeable e
+         , ClosureDict f, Typeable f
+         , ClosureDict g, Typeable g
+         ) => ClosureDict (a, b, c, d, e, f, g) where
+  closureDict =
+    closure (static (\Dict Dict Dict Dict Dict Dict Dict -> Dict))
+      `cap` (closureDict :: Closure (Dict a))
+      `cap` (closureDict :: Closure (Dict b))
+      `cap` (closureDict :: Closure (Dict c))
+      `cap` (closureDict :: Closure (Dict d))
+      `cap` (closureDict :: Closure (Dict e))
+      `cap` (closureDict :: Closure (Dict f))
+      `cap` (closureDict :: Closure (Dict g))
+
+instance ( ClosureDict a, Typeable a
+         , ClosureDict b, Typeable b
+         , ClosureDict c, Typeable c
+         , ClosureDict d, Typeable d
+         , ClosureDict e, Typeable e
+         , ClosureDict f, Typeable f
+         , ClosureDict g, Typeable g
+         , ClosureDict h, Typeable h
+         ) => ClosureDict (a, b, c, d, e, f, g, h) where
+  closureDict =
+    closure (static (\Dict Dict Dict Dict Dict Dict Dict Dict -> Dict))
+      `cap` (closureDict :: Closure (Dict a))
+      `cap` (closureDict :: Closure (Dict b))
+      `cap` (closureDict :: Closure (Dict c))
+      `cap` (closureDict :: Closure (Dict d))
+      `cap` (closureDict :: Closure (Dict e))
+      `cap` (closureDict :: Closure (Dict f))
+      `cap` (closureDict :: Closure (Dict g))
+      `cap` (closureDict :: Closure (Dict h))

src/Control/Distributed/Closure/TH.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE StaticPointers #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+-- | Utility Template Haskell functions.
+
+module Control.Distributed.Closure.TH where
+
+import           Data.Constraint (Dict(..), (:-)(..), mapDict)
+import           Control.Distributed.Closure.Internal
+import           GHC.StaticPtr
+import qualified Language.Haskell.TH as TH
+
+deriveClosureDict :: TH.TypeQ -> TH.DecsQ
+deriveClosureDict = (>>= go)
+  where
+    go (TH.ForallT _ cxt hd) = do
+        let constraintQ = return $ foldl TH.AppT (TH.TupleT (length cxt)) cxt
+            hdQ = return hd
+        [d| instance ClosureDict $constraintQ => ClosureDict $hdQ where
+              closureDict =
+                  closure (static (mapDict (Sub Dict)))
+                    `cap` (closureDict :: Closure (Dict $constraintQ)) |]
+    go hd@(TH.AppT _ _) = go (TH.ForallT [] [] hd)