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 +9/−2
- src/Control/Applicative/Static.hs +26/−0
- src/Control/Comonad/Static.hs +33/−0
- src/Control/Distributed/Closure.hs +16/−0
- src/Control/Distributed/Closure/Internal.hs +20/−1
- src/Control/Distributed/Closure/TH.hs +12/−3
- src/Control/Monad/Static.hs +43/−0
- src/Data/Functor/Static.hs +32/−0
- src/Data/Profunctor/Choice/Static.hs +22/−0
- src/Data/Profunctor/Static.hs +41/−0
- src/Data/Profunctor/Strong/Static.hs +21/−0
- tests/test.hs +208/−16
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)