diff --git a/distributed-closure.cabal b/distributed-closure.cabal --- a/distributed-closure.cabal +++ b/distributed-closure.cabal @@ -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 diff --git a/src/Control/Applicative/Static.hs b/src/Control/Applicative/Static.hs new file mode 100644 --- /dev/null +++ b/src/Control/Applicative/Static.hs @@ -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 diff --git a/src/Control/Comonad/Static.hs b/src/Control/Comonad/Static.hs new file mode 100644 --- /dev/null +++ b/src/Control/Comonad/Static.hs @@ -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 diff --git a/src/Control/Distributed/Closure.hs b/src/Control/Distributed/Closure.hs --- a/src/Control/Distributed/Closure.hs +++ b/src/Control/Distributed/Closure.hs @@ -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 diff --git a/src/Control/Distributed/Closure/Internal.hs b/src/Control/Distributed/Closure/Internal.hs --- a/src/Control/Distributed/Closure/Internal.hs +++ b/src/Control/Distributed/Closure/Internal.hs @@ -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." #-} diff --git a/src/Control/Distributed/Closure/TH.hs b/src/Control/Distributed/Closure/TH.hs --- a/src/Control/Distributed/Closure/TH.hs +++ b/src/Control/Distributed/Closure/TH.hs @@ -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 diff --git a/src/Control/Monad/Static.hs b/src/Control/Monad/Static.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Static.hs @@ -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) diff --git a/src/Data/Functor/Static.hs b/src/Data/Functor/Static.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Static.hs @@ -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 diff --git a/src/Data/Profunctor/Choice/Static.hs b/src/Data/Profunctor/Choice/Static.hs new file mode 100644 --- /dev/null +++ b/src/Data/Profunctor/Choice/Static.hs @@ -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 diff --git a/src/Data/Profunctor/Static.hs b/src/Data/Profunctor/Static.hs new file mode 100644 --- /dev/null +++ b/src/Data/Profunctor/Static.hs @@ -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) diff --git a/src/Data/Profunctor/Strong/Static.hs b/src/Data/Profunctor/Strong/Static.hs new file mode 100644 --- /dev/null +++ b/src/Data/Profunctor/Strong/Static.hs @@ -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 diff --git a/tests/test.hs b/tests/test.hs --- a/tests/test.hs +++ b/tests/test.hs @@ -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 _ = "" +instance Show (StaticPtr a) where + show _ = "" + +-- | 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)