packages feed

distributed-closure 0.3.4.0 → 0.3.5

raw patch · 12 files changed

+483/−22 lines, 12 filesnew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

+ Control.Applicative.Static: class StaticApply f => StaticApplicative f
+ Control.Applicative.Static: class StaticFunctor f => StaticApply f
+ Control.Applicative.Static: instance Control.Applicative.Static.StaticApply Control.Distributed.Closure.Internal.Closure
+ Control.Applicative.Static: staticApply :: (StaticApply f, Typeable a, Typeable b) => f (a -> b) -> f a -> f b
+ Control.Applicative.Static: staticPure :: (StaticApplicative f, Typeable a) => a -> f a
+ Control.Comonad.Static: class StaticExtend w => StaticComonad w
+ Control.Comonad.Static: class StaticFunctor w => StaticExtend w
+ Control.Comonad.Static: instance Control.Comonad.Static.StaticComonad Control.Distributed.Closure.Internal.Closure
+ Control.Comonad.Static: instance Control.Comonad.Static.StaticExtend Control.Distributed.Closure.Internal.Closure
+ Control.Comonad.Static: staticDuplicate :: (StaticExtend w, Typeable a) => w a -> w (w a)
+ Control.Comonad.Static: staticExtend :: (StaticExtend w, Typeable a, Typeable b) => Closure (w a -> b) -> w a -> w b
+ Control.Comonad.Static: staticExtract :: (StaticComonad w, Typeable a) => w a -> a
+ Control.Distributed.Closure: WrapArrowClosure :: Closure (a -> b) -> WrappedArrowClosure a b
+ Control.Distributed.Closure: [unwrapClosureArrow] :: WrappedArrowClosure a b -> Closure (a -> b)
+ Control.Distributed.Closure: cduplicate :: Closure a -> Closure (Closure a)
+ Control.Distributed.Closure: instance (Data.Typeable.Internal.Typeable b, Data.Typeable.Internal.Typeable a) => Data.Binary.Class.Binary (Control.Distributed.Closure.WrappedArrowClosure a b)
+ Control.Distributed.Closure: newtype WrappedArrowClosure a b
+ Control.Distributed.Closure: type /-> = WrappedArrowClosure
+ Control.Distributed.Closure.Internal: [Duplicate] :: Closure a -> Closure (Closure a)
+ Control.Distributed.Closure.Internal: capDup :: Typeable a => Closure (Closure a -> b) -> Closure a -> Closure b
+ Control.Distributed.Closure.Internal: cduplicate :: Closure a -> Closure (Closure a)
+ Control.Monad.Static: class StaticApply m => StaticBind m
+ Control.Monad.Static: class (StaticApplicative m, StaticBind m) => StaticMonad m
+ Control.Monad.Static: instance (Control.Applicative.Static.StaticApplicative m, Control.Monad.Static.StaticBind m) => Control.Monad.Static.StaticMonad m
+ Control.Monad.Static: instance Control.Monad.Static.StaticBind Control.Distributed.Closure.Internal.Closure
+ Control.Monad.Static: staticBind :: (StaticBind m, Typeable a, Typeable b) => m a -> Closure (a -> m b) -> m b
+ Control.Monad.Static: staticJoin :: (StaticBind m, Typeable a) => m (m a) -> m a
+ Control.Monad.Static: staticReturn :: (StaticApplicative m, Typeable a) => a -> m a
+ Data.Functor.Static: class Typeable f => StaticFunctor f
+ Data.Functor.Static: instance Data.Functor.Static.StaticFunctor Control.Distributed.Closure.Internal.Closure
+ Data.Functor.Static: staticMap :: (StaticFunctor f, Typeable a, Typeable b) => Closure (a -> b) -> f a -> f b
+ Data.Profunctor.Choice.Static: class StaticProfunctor p => StaticChoice p
+ Data.Profunctor.Choice.Static: instance Data.Profunctor.Choice.Static.StaticChoice Control.Distributed.Closure.WrappedArrowClosure
+ Data.Profunctor.Choice.Static: staticLeft' :: (StaticChoice p, Typeable a, Typeable b, Typeable c) => p a b -> p (Either a c) (Either b c)
+ Data.Profunctor.Choice.Static: staticRight' :: (StaticChoice p, Typeable a, Typeable b, Typeable c) => p a b -> p (Either c a) (Either c b)
+ Data.Profunctor.Static: class Typeable p => StaticProfunctor p
+ Data.Profunctor.Static: instance Data.Profunctor.Static.StaticProfunctor Control.Distributed.Closure.WrappedArrowClosure
+ Data.Profunctor.Static: staticDimap :: (StaticProfunctor p, Typeable a, Typeable b, Typeable c, Typeable d) => Closure (a -> b) -> Closure (c -> d) -> p b c -> p a d
+ Data.Profunctor.Static: staticLmap :: (StaticProfunctor p, Typeable a, Typeable b, Typeable c) => Closure (a -> b) -> p b c -> p a c
+ Data.Profunctor.Static: staticRmap :: (StaticProfunctor p, Typeable a, Typeable c, Typeable d) => Closure (c -> d) -> p a c -> p a d
+ Data.Profunctor.Strong.Static: class StaticProfunctor p => StaticStrong p
+ Data.Profunctor.Strong.Static: instance Data.Profunctor.Strong.Static.StaticStrong Control.Distributed.Closure.WrappedArrowClosure
+ Data.Profunctor.Strong.Static: staticFirst' :: (StaticStrong p, Typeable a, Typeable b, Typeable c) => p a b -> p (a, c) (b, c)
+ Data.Profunctor.Strong.Static: staticSecond' :: (StaticStrong p, Typeable a, Typeable b, Typeable c) => p a b -> p (c, a) (c, b)
- Control.Distributed.Closure: data Dict (a :: Constraint) :: Constraint -> *
+ Control.Distributed.Closure: data Dict a :: Constraint -> *

Files

distributed-closure.cabal view
@@ -1,5 +1,5 @@ name:                distributed-closure-version:             0.3.4.0+version:             0.3.5 synopsis:            Serializable closures for distributed programming. description:         See README. homepage:            https://github.com/tweag/distributed-closure@@ -18,9 +18,16 @@   location: https://github.com/tweag/distributed-closure  library-  exposed-modules:     Control.Distributed.Closure+  exposed-modules:     Control.Applicative.Static+                       Control.Comonad.Static+                       Control.Distributed.Closure                        Control.Distributed.Closure.Internal                        Control.Distributed.Closure.TH+                       Control.Monad.Static+                       Data.Profunctor.Static+                       Data.Profunctor.Choice.Static+                       Data.Profunctor.Strong.Static+                       Data.Functor.Static   build-depends:       base >=4.8 && <5                      , binary >= 0.7.5                      , bytestring >= 0.10
+ src/Control/Applicative/Static.hs view
@@ -0,0 +1,26 @@+module Control.Applicative.Static where++import Data.Functor.Static+import Control.Distributed.Closure+import Data.Typeable (Typeable)++-- | Instances of 'StaticApply' should satisfy the following laws (writing+-- 'staticMap', 'staticApply' as infix @('<$>')@, @('<*>')@, respectively):+--+-- @+-- static (.) '<$>' u '<*>' v '<*>' w = u '<*>' (v '<*>' w)+-- x '<*>' (f '<$>' y) = (static (flip (.)) ``cap`` f) '<$>' x '<*>' y+-- f '<$>' (x '<*>' y) = (static (.) ``cap`` f) '<$>' x '<*>' y+-- @+class StaticFunctor f => StaticApply f where+  staticApply+    :: (Typeable a, Typeable b)+    => f (a -> b)+    -> f a+    -> f b++class StaticApply f => StaticApplicative f where+  staticPure :: Typeable a => a -> f a++instance StaticApply Closure where+  staticApply = cap
+ src/Control/Comonad/Static.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE StaticPointers #-}++module Control.Comonad.Static where++import Control.Distributed.Closure+import Data.Functor.Static+import Data.Typeable (Typeable)++-- | Instances of 'StaticExtend' should satisfy the following laws:+--+-- @+-- 'staticExtend' f = 'staticMap' f . 'staticDuplicate'+-- 'staticDuplicate' = 'staticExtend' (static 'id')+-- 'staticExtend' f . 'staticExtend' g = 'staticExtend' (static (.) `cap` f `cap` 'staticExtend' g)+-- 'staticDuplicate' . 'staticDuplicate' = 'staticMap' (static 'staticDuplicate') . 'staticDuplicate'+-- @+class StaticFunctor w => StaticExtend w where+  staticDuplicate :: Typeable a => w a -> w (w a)+  staticDuplicate = staticExtend (static id)++  staticExtend :: (Typeable a, Typeable b) => Closure (w a -> b) -> w a -> w b+  staticExtend sf = staticMap sf . staticDuplicate++  {-# MINIMAL staticDuplicate | staticExtend #-}++class StaticExtend w => StaticComonad w where+  staticExtract :: Typeable a => w a -> a++instance StaticExtend Closure where+  staticDuplicate = cduplicate++instance StaticComonad Closure where+  staticExtract = unclosure
src/Control/Distributed/Closure.hs view
@@ -7,7 +7,9 @@  {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}@@ -24,6 +26,10 @@   , cpure   , cap   , cmap+  , cduplicate+    -- * Special closures+  , WrappedArrowClosure(..)+  , type (/->)     -- * Closure dictionaries     -- $static-dicts   , Dict(..)@@ -31,6 +37,7 @@   ) where  import Control.Distributed.Closure.Internal+import Data.Binary (Binary) import Data.Constraint (Dict(..))  -- $static-dicts@@ -51,3 +58,12 @@ -- 'Control.Distributed.Closure.TH.withStatic' if it becomes too tedious. class c => Static c where   closureDict :: Closure (Dict c)++-- | A newtype-wrapper useful for defining instances of classes indexed by+-- higher-kinded types.+newtype WrappedArrowClosure a b = WrapArrowClosure+  { unwrapClosureArrow :: Closure (a -> b)+  } deriving (Binary)++infixr 0 /->+type (/->) = WrappedArrowClosure
src/Control/Distributed/Closure/Internal.hs view
@@ -23,7 +23,9 @@   , unclosure   , cpure   , cap+  , capDup   , cmap+  , cduplicate   ) where  import Data.Binary (Binary(..), Get, Put, decode, encode)@@ -53,6 +55,7 @@   StaticPtr :: !(StaticPtr a) -> Closure a   Encoded :: !ByteString -> Closure ByteString   Ap :: !(Closure (a -> b)) -> !(Closure a) -> Closure b+  Duplicate :: Closure a -> Closure (Closure a)   -- Cache the value a closure resolves to.   Closure :: a -> !(Closure a) -> Closure a @@ -79,6 +82,10 @@       (clos1 :: Closure (a -> b)) -> case unsafeCoerce x2 of         (clos2 :: Closure a) -> DynClosure $ unsafeCoerce $ Ap clos1 clos2 +dynClosureDuplicate :: DynClosure -> DynClosure+dynClosureDuplicate (DynClosure x) =+    DynClosure $ unsafeCoerce $ Duplicate $ unsafeCoerce x+ -- | 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.@@ -87,6 +94,7 @@ putClosure (Encoded bs) = putWord8 1 >> put bs putClosure (Ap clos1 clos2) = putWord8 2 >> putClosure clos1 >> putClosure clos2 putClosure (Closure _ clos) = putClosure clos+putClosure (Duplicate clos) = putWord8 3 >> putClosure clos  getDynClosure :: Get DynClosure getDynClosure = getWord8 >>= \case@@ -95,6 +103,7 @@            Nothing -> fail $ "Static pointer lookup failed: " ++ show key     1 -> toDynClosure . Encoded <$> get     2 -> dynClosureApply <$> getDynClosure <*> getDynClosure+    3 -> dynClosureDuplicate <$> getDynClosure     _ -> fail "Binary.get(Closure): unrecognized tag."  #if !MIN_VERSION_binary(0,7,6)@@ -127,7 +136,12 @@ unclosure (Encoded x) = x unclosure (Ap cf cx) = (unclosure cf) (unclosure cx) unclosure (Closure x _) = x+unclosure (Duplicate x) = x +-- | Turn a closure into a closure of a closure.+cduplicate :: Closure a -> Closure (Closure a)+cduplicate = Duplicate+ decodeD :: Dict (Serializable a) -> ByteString -> a decodeD Dict = decode @@ -150,8 +164,13 @@ cap (Closure f closf) (Closure x closx) = Closure (f x) (Ap closf closx) cap closf closx = Ap closf closx +-- | Nested closure application.+capDup :: Typeable a => Closure (Closure a -> b) -> Closure a -> Closure b+capDup cf = cap cf . cduplicate+ -- | '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))+cmap sf = cap (closure sf)+{-# DEPRECATED cmap "Use staticMap instead." #-}
src/Control/Distributed/Closure/TH.hs view
@@ -18,6 +18,7 @@ import           Data.Generics (everything, mkQ) import           Data.List (nub) import           Data.Typeable (Typeable)+import           GHC.StaticPtr import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as TH import           Numeric.Natural@@ -89,6 +90,9 @@ -- instance (Static (Show a), Typeable a) => Static (Show (T a)) where --   closureDict = closure (static (Dict -> Dict)) `cap` closureDict -- @+--+-- You will probably want to enable @FlexibleContexts@ and @ScopedTypeVariables@+-- in modules that use 'withStatic'. withStatic :: TH.DecsQ -> TH.DecsQ withStatic = (>>= go)   where@@ -109,11 +113,16 @@         methods <- (:[]) <$>           TH.valD             (TH.varP 'closureDict)-            (TH.normalB (caps (cstatic f : replicate n [| closureDict |])))+            (TH.normalB (caps ( [| closure (static $(TH.varE f) :: StaticPtr $(return tyf)) |]+                              : replicate n [| closureDict |]+                              )))             []         staticcxt <- (++) <$>-          mapM (\c -> [t| Static $(return c) |]) cxt <*>-          mapM (\var -> [t| Typeable $(TH.varT var) |]) (fvT tyf)+          sequence [ [t| Typeable $(return d) |]+                   | d <- retsig : dictsigs+                   , not (null (fvT d))+                   ] <*>+          mapM (\c -> [t| Static   $(return c) |]) cxt         statichd <- [t| Static $(return hd) |] #if MIN_VERSION_template_haskell(2,11,0)         let staticins = TH.InstanceD overlap staticcxt statichd methods
+ src/Control/Monad/Static.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StaticPointers #-}+{-# LANGUAGE UndecidableInstances #-}++module Control.Monad.Static where++import Control.Applicative.Static+import Control.Distributed.Closure+import Data.Functor.Static+import Data.Typeable (Typeable)++-- | Instances of 'StaticBind' should satisfy the following laws (writing+-- 'staticMap', 'staticApply', 'staticBind' as infix @('<$>')@, @('<*>')@, @(>>=)@,+-- respectively):+--+-- @+-- (m >>= f) >>= g = m >>= static (.) ``cap`` (staticFlippedBind g) `cap` f+-- 'staticJoin' . 'staticJoin' = 'staticJoin' . 'staticMap' (static 'staticJoin')+-- @+--+-- where+--+-- @+-- staticFlippedBind :: Closure (b -> m c) -> Closure (m b -> m c)+-- staticFlippedBind = capDup (static (flip staticBind))+-- @+class StaticApply m => StaticBind m where+  staticBind :: (Typeable a, Typeable b) => m a -> Closure (a -> m b) -> m b+  staticBind m k = staticJoin (staticMap k m)++  staticJoin :: Typeable a => m (m a) -> m a+  staticJoin m = m `staticBind` static id++  {-# MINIMAL staticBind | staticJoin #-}++class (StaticApplicative m, StaticBind m) => StaticMonad m+instance (StaticApplicative m, StaticBind m) => StaticMonad m++staticReturn :: (StaticApplicative m, Typeable a) => a -> m a+staticReturn = staticPure++instance StaticBind Closure where+  staticBind m k = unclosure k (unclosure m)
+ src/Data/Functor/Static.hs view
@@ -0,0 +1,32 @@+-- | 'Closure' is not a functor, since we cannot map arbitrary functions over+-- it. But it sure looks like one, and an applicative one at that. What we can+-- do is map /static pointers to/ arbitrary functions over it (or in general,+-- closures). 'Closure' is not just an applicative functor, it's also a monad,+-- as well as a comonad, if again we limit the function space to those functions+-- that can be statically pointed to.+--+-- In fact an entire hierarchy of classes mirroring the standard classes can be+-- defined, where nearly the only difference lies in the fact that higher-order+-- arguments must be a proof of /static/-ness (i.e. a 'Closure'). The other+-- difference is that composing static values requires a proof of typeability,+-- so we carry those around ('Typeable' constraints).+--+-- This module and others define just such a class hierarchy in the category of+-- static functions (aka values of type @'Closure' (a -> b)@).++module Data.Functor.Static where++import Control.Distributed.Closure+import Data.Typeable (Typeable)++-- | Instances of 'StaticFunctor' should satisfy the following laws:+--+-- @+-- 'staticMap' (static 'id') = 'id'+-- 'staticMap' (static (.) ``cap`` f ``cap`` g) = 'staticMap' f . 'staticMap' g+-- @+class Typeable f => StaticFunctor f where+  staticMap :: (Typeable a, Typeable b) => Closure (a -> b) -> f a -> f b++instance StaticFunctor Closure where+  staticMap = cap
+ src/Data/Profunctor/Choice/Static.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE StaticPointers #-}++module Data.Profunctor.Choice.Static where++import Control.Distributed.Closure+import Data.Bifunctor (bimap)+import Data.Profunctor.Static+import Data.Typeable (Typeable)++class StaticProfunctor p => StaticChoice p where+  staticLeft'+    :: (Typeable a, Typeable b, Typeable c)+    => p a b -> p (Either a c) (Either b c)+  staticRight'+    :: (Typeable a, Typeable b, Typeable c)+    => p a b -> p (Either c a) (Either c b)++instance StaticChoice WrappedArrowClosure where+  staticLeft' (WrapArrowClosure sf) =+    WrapArrowClosure $ static (\f -> bimap f id) `cap` sf+  staticRight' (WrapArrowClosure sg) =+    WrapArrowClosure $ static (\g -> bimap id g) `cap` sg
+ src/Data/Profunctor/Static.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE StaticPointers #-}++module Data.Profunctor.Static (StaticProfunctor(..)) where++import Control.Distributed.Closure+import Data.Typeable (Typeable)++-- | Instances of 'StaticProfunctor' should satisfy the following laws:+--+-- @+-- 'staticDimap' (static id) (static id) = static id+-- 'staticLmap' (static id) = static id+-- 'staticRmap' (static id) = static id+-- 'staticDimap' f g = staticLmap f . staticRmap g+-- @+class Typeable p => StaticProfunctor p where+  staticDimap+    :: (Typeable a, Typeable b, Typeable c, Typeable d)+    => Closure (a -> b) -> Closure (c -> d) -> p b c -> p a d+  staticDimap sf sg = staticLmap sf . staticRmap sg++  staticLmap+    :: (Typeable a, Typeable b, Typeable c)+    => Closure (a -> b) -> p b c -> p a c+  staticLmap sf = staticDimap sf (static id)++  staticRmap+    :: (Typeable a, Typeable c, Typeable d)+    => Closure (c -> d) -> p a c -> p a d+  staticRmap sg = staticDimap (static id) sg++  {-# MINIMAL staticDimap | staticLmap, staticRmap #-}++staticCompose+  :: (Typeable a, Typeable b, Typeable c)+  => Closure (b -> c) -> Closure (a -> b) -> Closure (a -> c)+staticCompose f g = static (.) `cap` f `cap` g++instance StaticProfunctor WrappedArrowClosure where+  staticDimap sf sg (WrapArrowClosure sk) =+    WrapArrowClosure (sg `staticCompose` sk `staticCompose` sf)
+ src/Data/Profunctor/Strong/Static.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE StaticPointers #-}++module Data.Profunctor.Strong.Static where++import Control.Distributed.Closure+import Data.Profunctor.Static+import Data.Typeable (Typeable)++class StaticProfunctor p => StaticStrong p where+  staticFirst'+    :: (Typeable a, Typeable b, Typeable c)+    => p a b -> p (a, c) (b, c)+  staticSecond'+    :: (Typeable a, Typeable b, Typeable c)+    => p a b -> p (c, a) (c, b)++instance StaticStrong WrappedArrowClosure where+  staticFirst' (WrapArrowClosure sf) =+    WrapArrowClosure $ static (\f (x, y) -> (f x, y)) `cap` sf+  staticSecond' (WrapArrowClosure sf) =+    WrapArrowClosure $ static (\f (x, y) -> (x, f y)) `cap` sf
tests/test.hs view
@@ -1,8 +1,10 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StaticPointers #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}  {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -11,6 +13,9 @@ import Control.Distributed.Closure import Control.Distributed.Closure.TH import Data.Binary+import Data.Bool (bool)+import Data.Typeable+import GHC.StaticPtr import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck@@ -23,19 +28,205 @@   instance (Eq a, Show a) => Eq (T a) where (==) = undefined   |] +-- * Basic generators (parameterized by size)++-- | Generates a basic closure using @cpure@+genPure :: forall a. (Static (Serializable a), Arbitrary a) => Int -> Gen (Closure a)+genPure i =+    cpure (closureDict :: Closure (Dict (Serializable a))) <$>+      resize (max 0 (i-1)) arbitrary++-- | Generates a basic closure using @closure@+genStatic :: Arbitrary (StaticPtr a) => Int -> Gen (Closure a)+-- static pointers are considered to contribute 0 to the size, hence ignore the+-- size parameter.+genStatic _i = closure <$> 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).+data Type a where+  TInt :: Type Int+  TBool :: Type Bool++instance Static (Serializable Int) where+  closureDict = static Dict++instance Static (Serializable 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+  arbitrary =+      elements [ AType TInt, AType TBool ]++-- | Composed types. Very few choices because of the combinatorics.+data Sig a where+  Zero :: Type a -> Sig a+  One :: Type a -> Type b -> Sig (a->b)+  Two :: Type a -> Type b -> Type c -> Sig (a->b->c)++-- | Extend a type with an extra parameter. May fail since functions in 'Sig'+-- have a maximum of two arguments.+push :: Type a -> Sig b -> Maybe (Sig (a -> b))+push a (Zero b) = Just $ One a b+push a (One b c) = Just $ Two a b c+push _ (Two _ _ _) = Nothing++-- | Non-recursive generator of atomic values for each type.+genSimple :: Sig a -> Int -> Gen (Closure a)+genSimple (Zero TInt) = genPure+genSimple (Zero TBool) = genPure+genSimple (One TInt TInt) = genStatic+genSimple (One TBool TInt) = genStatic+genSimple (One TInt TBool) = genStatic `gap` genPure @Int+genSimple (One TBool TBool) = genStatic+genSimple (Two TInt TInt TInt) = genStatic+genSimple (Two TBool TInt TInt) = gflip genStatic+genSimple (Two TInt TBool TInt) = genStatic+genSimple (Two TBool TBool TInt) = genStatic+genSimple (Two TInt TInt TBool) = genStatic+genSimple (Two TBool TInt TBool) = genStatic+genSimple (Two TInt TBool TBool) = gflip genStatic+genSimple (Two TBool TBool TBool) = genStatic++gflip+  :: (Typeable a, Typeable b, Typeable c)+  => (Int -> Gen (Closure (a->b->c))) -> Int -> 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)+gap gf gx i = do+  f <- gf i+  x <- gx i+  return $ f `cap` x++-- | 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)+genClosure sig size | size < 10 =+    genSimple sig size+genClosure sig size = do+    stop <- 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+      case push pivot sig of+        Nothing -> genSimple sig size+        Just sig' -> do+          -- if the @size@ is big enough, then 1/3 of the time, if we can extend+          -- the signature, build a closure with @cap@+          function <- genClosure sig' upper+          argument <- genClosure (Zero pivot) lower+          return $ function `cap` argument++-- * Generating static pointers+--+-- Must be from explicit lists since static pointers are, well, static. The+-- combinatorics is unpleasant.++instance Arbitrary (StaticPtr (Int -> Int)) where+  arbitrary =+      elements+        [ static id+        , static pred+        , static succ+        , static (3*)+        ]++instance Arbitrary (StaticPtr (Bool -> Int)) where+  arbitrary =+      elements+       [ static (bool 0 1)+       , static (bool 57 42)]++instance Arbitrary (StaticPtr (Bool -> Bool)) where+  arbitrary =+    elements+      [ static id+      , static not ]++instance Arbitrary (StaticPtr (Int -> Int -> Int)) where+  arbitrary =+      elements+        [ static const+        , static (+)+        , static (*)+        , static (-)+        , static (\x y -> 2*x + y)+        ]++instance Arbitrary (StaticPtr (Int -> Bool -> Int)) where+  arbitrary =+    elements+      [ static const+      , static (\n b -> if b then n else -n)+      , static (bool 0)+      ]++instance Arbitrary (StaticPtr (Bool -> Bool -> Int)) where+  arbitrary =+    elements+      [ static (\x y -> bool 0 1 (x&&y))+      , static (\x y -> bool 57 42 (x||y))+      ]++instance Arbitrary (StaticPtr (Int -> Int -> Bool)) where+  arbitrary =+    elements+      [ static (==)+      , static (>=)+      , static (<=)+      , static (<)+      , static (>)+      ]++instance Arbitrary (StaticPtr (Bool -> Int -> Bool)) where+  arbitrary =+    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+  arbitrary =+    elements+      [ static (&&)+      , static (||)]++-- * Instances+ instance Arbitrary (Closure Int) where-  arbitrary = cpure $cdict <$> elements [0..4]+  arbitrary = sized $ genClosure (Zero TInt)  instance Arbitrary (Closure (Int -> Int)) where-  arbitrary =-      elements [ closure (static id)-               , closure (static pred)-               , closure (static succ)-               ]+  arbitrary = sized $ genClosure (One TInt TInt)  instance Show (Closure a) where   show _ = "<closure>" +instance Show (StaticPtr a) where+  show _ = "<static>"++-- | Extensional equality on closures (/i.e./ closures are equal if they+-- represent equal values)+instance Eq a => Eq (Closure a) where+  cl1 == cl2 =+    unclosure cl1 == unclosure cl2++-- * Tests+ main :: IO () main = hspec $ do     describe "unclosure" $ do@@ -43,23 +234,24 @@         (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)-+      prop "is inverse to cduplicate" $ \x ->+        (unclosure . cduplicate) x == (x :: Closure Int)+      prop "is inverse to closure of id" $ \(x :: Int) ->+        (unclosure . closure) (static id) x == x+      prop "is inverse to closure" $ \(f :: StaticPtr (Int -> Int))+                                      (x :: Int) ->+        (unclosure . closure) f x == deRefStaticPtr f x     describe "laws" $ do       prop "identity" $ \(v :: Closure Int) ->-        unclosure (closure (static id) `cap` v) == id (unclosure v)+        unclosure (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))+        closure (static (.)) `cap` u `cap` v `cap` w ==+        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)+          (decode . encode) v == (v :: Closure Int)