packages feed

distributed-closure (empty) → 0.1.0.0

raw patch · 8 files changed

+322/−0 lines, 8 filesdep +QuickCheckdep +basedep +binarysetup-changed

Dependencies added: QuickCheck, base, binary, bytestring, constraints, distributed-closure, hspec, template-haskell

Files

+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,6 @@+# distributed-closure++[![Build Status](https://travis-ci.org/tweag/distributed-closure.svg)](https://travis-ci.org/tweag/distributed-closure)++Leverage the `-XStaticPointers` extension from GHC 7.10 onwards for+distributed programming using lightweight serializable closures.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ distributed-closure.cabal view
@@ -0,0 +1,43 @@+name:                distributed-closure+version:             0.1.0.0+synopsis:            Serializable closures for distributed programming.+description:         See README.+homepage:            https://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:  README.md+cabal-version:       >=1.10++source-repository head+  type:     git+  location: https://github.com/tweag/distributed-closure++library+  exposed-modules:     Control.Distributed.Closure+                       Control.Distributed.Closure.Internal+                       Control.Distributed.Closure.TH+  build-depends:       base >=4.8 && <5+                     , binary >= 0.7.6+                     , bytestring >= 0.10+                     , constraints >= 0.4+                     , template-haskell >= 2.10+  hs-source-dirs:      src+  default-language:    Haskell2010+  ghc-options:         -Wall++test-suite tests+  type:             exitcode-stdio-1.0+  default-language: Haskell2010+  hs-source-dirs:   tests+  main-is:          test.hs+  ghc-options:      -Wall+  Build-Depends:    base >= 4.8,+                    binary >= 0.7,+                    distributed-closure,+                    hspec >= 2.1,+                    QuickCheck >= 2.8
+ src/Control/Distributed/Closure.hs view
@@ -0,0 +1,29 @@+-- | Serializable closures for distributed programming.++{-# OPTIONS_GHC -funbox-strict-fields #-}++module Control.Distributed.Closure+  ( Serializable+    -- * Closures+  , Closure+  , closure+  , unclosure+  , cpure+  , cap+  , cmap+    -- * Closure dictionaries+    -- $serializable-dicts+  , Dict(..)+  ) where++import Control.Distributed.Closure.Internal+import Data.Constraint (Dict(..))++-- $serializable-dicts+--+-- A 'Dict' reifies a constraint in the form of a first class value. The 'Dict'+-- type is not serializable: how do you serialize the constraint that values of+-- this type carry? However, for any constraint @c@, a value of type @'Closure'+-- ('Dict' c)@ /can/ be serialized and sent over the wire, just like any+-- 'Closure'. A /serializable dictionary/ for some constraint @c@ is a value of+-- type @'Closure' ('Dict' c)@.
+ src/Control/Distributed/Closure/Internal.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StaticPointers #-}++-- | Private internals. You should not use this module unless you are determined+-- to monkey with the internals. This module comes with no API stability+-- guarantees whatsoever. Use at your own risks.++{-# OPTIONS_GHC -funbox-strict-fields #-}++module Control.Distributed.Closure.Internal+  ( Serializable+  , Closure(..)+  , closure+  , unclosure+  , cpure+  , cap+  , cmap+  ) where++import Data.Binary (Binary(..), Get, Put, decode, encode)+import Data.Binary.Put (putWord8)+import Data.Binary.Get (getWord8)+import Data.Constraint (Dict(..))+import Data.Typeable (Typeable)+import Data.ByteString.Lazy (ByteString)+import GHC.Base (Any)+import GHC.StaticPtr+import Unsafe.Coerce (unsafeCoerce) -- for dynClosureApply+import System.IO.Unsafe (unsafePerformIO)++-- | Values that can be sent across the network.+type Serializable a = (Binary a, Typeable 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 a) -> Closure a+  Encoded :: !ByteString -> Closure ByteString+  Ap :: !(Closure (a -> b)) -> !(Closure a) -> Closure b+  -- | Cache the value a closure resolves to.+  Closure :: a -> !(Closure a) -> Closure a++-- Will be obsoleted by https://ghc.haskell.org/trac/ghc/wiki/Typeable. We use+-- our own datatype instead of Dynamic in order to support dynClosureApply.+newtype DynClosure = DynClosure Any -- invariant: only values of type Closure.++-- | Until GHC.StaticPtr can give us a proper TypeRep upon decoding, we have to+-- pretend that this function doesn't need a 'Typeable' constraint to be safe.+toDynClosure :: Closure a -> DynClosure+toDynClosure = DynClosure . unsafeCoerce++fromDynClosure :: Typeable a => DynClosure -> Closure a+fromDynClosure (DynClosure x) = unsafeCoerce x++dynClosureApply :: DynClosure -> DynClosure -> DynClosure+dynClosureApply (DynClosure x1) (DynClosure x2) =+    case unsafeCoerce x1 of+      (clos1 :: Closure (a -> b)) -> case unsafeCoerce x2 of+        (clos2 :: Closure a) -> DynClosure $ unsafeCoerce $ Ap clos1 clos2++-- | Until GHC.StaticPtr can give us a proper TypeRep upon decoding, we have to+-- pretend that serializing/deserializing a @'Closure' a@ without a @'Typeable'+-- a@ constraint, i.e. for /any/ @a@, is safe.+putClosure :: Closure a -> Put+putClosure (StaticPtr sptr) = putWord8 0 >> put (staticKey sptr)+putClosure (Encoded bs) = putWord8 1 >> put bs+putClosure (Ap clos1 clos2) = putWord8 2 >> putClosure clos1 >> putClosure clos2+putClosure (Closure _ clos) = putClosure clos++getDynClosure :: Get DynClosure+getDynClosure = getWord8 >>= \case+    0 -> get >>= \key -> case unsafePerformIO (unsafeLookupStaticPtr key) of+           Just sptr -> return $ toDynClosure $ StaticPtr sptr+           Nothing -> fail $ "Static pointer lookup failed: " ++ show key+    1 -> toDynClosure . Encoded <$> get+    2 -> dynClosureApply <$> getDynClosure <*> getDynClosure+    _ -> fail "Binary.get(Closure): unrecognized tag."++instance Typeable a => Binary (Closure a) where+  put = putClosure+  get = do+      clos <- fromDynClosure <$> getDynClosure+      return $ Closure (unclosure clos) clos++-- | Lift a Static pointer to a closure with an empty environment.+closure :: StaticPtr a -> Closure a+closure sptr = Closure (deRefStaticPtr sptr) (StaticPtr sptr)++-- | Resolve a 'Closure' to the value that it represents. Calling 'unclosure'+-- multiple times on the same closure is efficient: for most argument values the+-- result is memoized.+unclosure :: Closure a -> a+unclosure (StaticPtr sptr) = deRefStaticPtr sptr+unclosure (Encoded x) = x+unclosure (Ap cf cx) = (unclosure cf) (unclosure cx)+unclosure (Closure 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 :: Closure (Dict (Serializable a)) -> a -> Closure a+cpure cdict x | Dict <- unclosure cdict =+    Closure x $+    StaticPtr (static decodeD) `cap`+    cdict `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 :: Typeable a          -- XXX 'Typeable' constraint only for forward compat.+    => Closure (a -> b)+    -> Closure a+    -> Closure b+cap (Closure f closf) (Closure x closx) = Closure (f x) (Ap closf closx)+cap closf closx = Ap closf closx++-- | 'Closure' is not a 'Functor', in that we cannot map arbitrary functions+-- over it. That is, we cannot define 'fmap'. However, we can map a static+-- pointer to a function over a 'Closure'.+cmap :: Typeable a => StaticPtr (a -> b) -> Closure a -> Closure b+cmap sptr = cap (Closure (deRefStaticPtr sptr) (StaticPtr sptr))
+ src/Control/Distributed/Closure/TH.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE StaticPointers #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Utility Template Haskell functions.++module Control.Distributed.Closure.TH where++import           Control.Monad (replicateM)+import           Control.Distributed.Closure.Internal+import           Data.Constraint (Dict(..))+import qualified Language.Haskell.TH as TH+import           Numeric.Natural++cdict :: TH.ExpQ+cdict = cdictFrom 0++cdictFrom :: Natural -> TH.ExpQ+cdictFrom n0 = apply abstract [| closure (static $(staticFun n0)) |] n0+  where+    staticFun 0 = [| Dict |]+    staticFun n = [| \Dict -> $(staticFun (n - 1)) |]+    apply k f n = do+        names <- replicateM (fromIntegral n) (TH.newName "x")+        k names (foldl (\acc x -> [| $acc `cap` $(TH.varE x) |]) f names)+    abstract [] expr = expr+    abstract (nm:names) expr = [| \ $(TH.varP nm) -> $(abstract names expr) |]
+ tests/test.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StaticPointers #-}+{-# LANGUAGE TemplateHaskell #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main where++import Control.Distributed.Closure+import Control.Distributed.Closure.TH+import Data.Binary+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck++instance Arbitrary (Closure Int) where+  arbitrary = cpure $cdict <$> elements [0..4]++instance Arbitrary (Closure (Int -> Int)) where+  arbitrary =+      elements [ closure (static id)+               , closure (static pred)+               , closure (static succ)+               ]++instance Show (Closure a) where+  show _ = "<closure>"++main :: IO ()+main = hspec $ do+    describe "unclosure" $ do+      prop "is inverse to cpure" $ \x y z ->+        (unclosure . cpure $cdict) x == (x :: Int) &&+        (unclosure . cpure $cdict) y == (y :: Bool) &&+        (unclosure . cpure $cdict) z == (z :: Maybe Int)+      it "is inverse to closure" $ do+        (unclosure . closure) (static id) 0 `shouldBe` (0 :: Int)++    describe "laws" $ do+      prop "identity" $ \(v :: Closure Int) ->+        unclosure (closure (static id) `cap` v) == id (unclosure v)+      prop "composition" $ \(u :: Closure (Int -> Int))+                            (v :: Closure (Int -> Int))+                            (w :: Closure Int) ->+        unclosure (closure (static (.)) `cap` u `cap` v `cap` w) ==+        unclosure (u `cap` (v `cap` w))+      prop "homomorphism" $ \(f :: Closure (Int -> Int)) x ->+        unclosure (f `cap` x) == (unclosure f) (unclosure x)++    describe "serialization" $ do+      prop "equal closures have equal serializations" $ \x y ->+          (unclosure x :: Int) == (unclosure y :: Int) ==> encode x == encode y++      prop "decode is left inverse to encode" $ \v ->+          unclosure ((decode . encode) v) == unclosure (v :: Closure Int)