distributed-static 0.2.1.1 → 0.3.11
raw patch · 4 files changed
Files
- ChangeLog +66/−0
- Setup.hs +0/−2
- distributed-static.cabal +33/−13
- src/Control/Distributed/Static.hs +167/−131
+ ChangeLog view
@@ -0,0 +1,66 @@+2024-09-03 Laurent P. René de Cotret <laurent.decotret@outlook.com> 0.3.11++* Bumped dependency bounds to support GHC 8.10.7 - GHC 9.10.1+* Updated links to point to Distributed Haskell monorepo++2024-03-25 David Simmons-Duffin <dsd@caltech.edu> 0.3.10++* Relax bytestring bounds to to build with ghc-9.8.++2019-05-12 Facundo Domínguez <facundo.dominguez@tweag.io> 0.3.9++* Relax bounds to to build with ghc-8.6.++2017-08-28 Facundo Domínguez <facundo.dominguez@tweag.io> 0.3.8++* Remove support for ghc-7.8 and lower+* Fix build errors with ghc-8.2.1++2017-08-22 Facundo Domínguez <facundo.dominguez@tweag.io> 0.3.7++* Make nominal the role of static++2017-08-22 Facundo Domínguez <facundo.dominguez@tweag.io> 0.3.6++* Move upper bound of rank1dynamic to support ghc-8.2.1.+* Remove dynamic type check in Static Binary instance.++2016-06-01 Facundo Domínguez <facundo.dominguez@tweag.io> 0.3.5.0++* Add compatibility with ghc-8.++2016-02-18 Facundo Domínguez <facundo.dominguez@tweag.io> 0.3.4.0++* Support static pointers.+* Update .travis.yml to drop ghc-7.4 and test ghc-7.10.+* Make Closure and Static strict data types.++2015-06-15 Facundo Domínguez <facundo.dominguez@tweag.io> 0.3.2.0++* Loosen rank1dynamic bounds.+* Add NFData instances.++2014-12-09 Tim Watson <watson.timothy@gmail.com> 0.3.1.0++* Eq and Ord instances for Closure and Static++2014-05-30 Tim Watson <watson.timothy@gmail.com> 0.3.0.0++* Bump binary dependency++2012-11-22 Edsko de Vries <edsko@well-typed.com> 0.2.1.1++* Relax package bounds to allow for Binary 0.6++2012-10-03 Edsko de Vries <edsko@well-typed.com> 0.2.1++* Add support for 'staticFlip'++2012-08-16 Edsko de Vries <edsko@well-typed.com> 0.2++* Hide the 'Closure' constructor and export 'closure' instead so that we are+free to change the internal representation++2012-08-10 Edsko de Vries <edsko@well-typed.com> 0.1++* Initial release
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
distributed-static.cabal view
@@ -1,6 +1,7 @@+cabal-version: 3.0 Name: distributed-static-Version: 0.2.1.1-Synopsis: Compositional, type-safe, polymorphic static values and closures +Version: 0.3.11+Synopsis: Compositional, type-safe, polymorphic static values and closures Description: /Towards Haskell in the Cloud/ (Epstein et al, Haskell Symposium 2011) introduces the concept of /static/ values: values that are known at compile time. In a distributed@@ -14,24 +15,43 @@ 'RemoteTable'). In this module we implement this mimickry and various extensions: type safety (including for polymorphic static values) and compositionality.-Homepage: http://www.github.com/haskell-distributed/distributed-process-License: BSD3+Homepage: http://haskell-distributed.github.com+License: BSD-3-Clause License-File: LICENSE Author: Edsko de Vries-Maintainer: edsko@well-typed.com+maintainer: The Distributed Haskell team+Bug-Reports: https://github.com/haskell-distributed/distributed-process/issues Copyright: Well-Typed LLP Category: Control Build-Type: Simple-Cabal-Version: >=1.8+extra-doc-files: ChangeLog+tested-with: GHC==8.10.7 GHC==9.0.2 GHC==9.2.8 GHC==9.4.5 GHC==9.6.4 GHC==9.8.2 GHC==9.10.1 +source-repository head+ Type: git+ Location: https://github.com/haskell-distributed/distributed-process+ SubDir: packages/distributed-static++common warnings+ ghc-options: -Wall+ -Wcompat+ -Widentities+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wredundant-constraints+ -fhide-source-paths+ -Wpartial-fields+ Library+ import: warnings Exposed-Modules: Control.Distributed.Static- Build-Depends: base >= 4 && < 5,- rank1dynamic >= 0.1 && < 0.2,- containers >= 0.4 && < 0.6,- bytestring >= 0.9 && < 0.11,- binary >= 0.5 && < 0.7 + Build-Depends: base >= 4.14 && < 5,+ rank1dynamic >= 0.1 && < 0.5,+ containers >= 0.6 && < 0.8,+ bytestring >= 0.10 && < 0.13,+ binary >= 0.8 && < 0.9,+ deepseq >= 1.4 && < 1.6 HS-Source-Dirs: src- Extensions: DeriveDataTypeable,+ Default-Language: Haskell2010+ Default-Extensions: DeriveDataTypeable ScopedTypeVariables- GHC-Options: -Wall
src/Control/Distributed/Static.hs view
@@ -1,60 +1,31 @@--- | /Towards Haskell in the Cloud/ (Epstein et al, Haskell Symposium 2011) +-- | /Towards Haskell in the Cloud/ (Epstein et al, Haskell Symposium 2011) -- introduces the concept of /static/ values: values that are known at compile--- time. In a distributed setting where all nodes are running the same +-- time. In a distributed setting where all nodes are running the same -- executable, static values can be serialized simply by transmitting a code -- pointer to the value. This however requires special compiler support, which--- is not yet available in ghc. We can mimick the behaviour by keeping an +-- is not yet available in ghc. We can mimick the behaviour by keeping an -- explicit mapping ('RemoteTable') from labels to values (and making sure that -- all distributed nodes are using the same 'RemoteTable'). In this module -- we implement this mimickry and various extensions. ----- [Dynamic type checking]------ The paper stipulates that 'Static' values should have a free 'Binary'--- instance:------ > instance Binary (Static a) ------ This however is not (runtime) type safe: for instance, what would be the--- behaviour of------ > f :: Static Int -> Static Bool --- > f = decode . encode ------ For this reason we work only with 'Typeable' terms in this module, and--- implement runtime checks------ > instance Typeable a => Binary (Static a)------ The above function 'f' typechecks but throws an exception if executed. The--- type representation we use, however, is not the standard--- 'Data.Typeable.TypeRep' from "Data.Typeable" but--- 'Data.Rank1Typeable.TypeRep' from "Data.Rank1Typeable". This means that we--- can represent polymorphic static values (see below for an example).------ Since the runtime mapping ('RemoteTable') contains values of different types,--- it maps labels ('String's) to 'Data.Rank1Dynamic.Dynamic' values. Again, we--- use the implementation from "Data.Rank1Dynamic" so that we can store --- polymorphic dynamic values.--- -- [Compositionality] -- -- Static values as described in the paper are not compositional: there is no -- way to combine two static values and get a static value out of it. This -- makes sense when interpreting static strictly as /known at compile time/, -- but it severely limits expressiveness. However, the main motivation for--- 'static' is not that they are known at compile time but rather that +-- 'static' is not that they are known at compile time but rather that -- /they provide a free/ 'Binary' /instance/. We therefore provide two basic -- constructors for 'Static' values: -- -- > staticLabel :: String -> Static a -- > staticApply :: Static (a -> b) -> Static a -> Static b ----- The first constructor refers to a label in a 'RemoteTable'. The second +-- The first constructor refers to a label in a 'RemoteTable'. The second -- allows to apply a static function to a static argument, and makes 'Static' -- compositional: once we have 'staticApply' we can implement numerous derived -- combinators on 'Static' values (we define a few in this module; see--- 'staticCompose', 'staticSplit', and 'staticConst'). +-- 'staticCompose', 'staticSplit', and 'staticConst'). -- -- [Closures] --@@ -67,7 +38,7 @@ -- -- See /Towards Haskell in the Cloud/ for the rationale behind representing -- the function closure environment in serialized ('ByteString') form. Any--- static value can trivially be turned into a 'Closure' ('staticClosure'). +-- static value can trivially be turned into a 'Closure' ('staticClosure'). -- Moreover, since 'Static' is now compositional, we can also define derived -- operators on 'Closure' values ('closureApplyStatic', 'closureApply', -- 'closureCompose', 'closureSplit').@@ -76,9 +47,9 @@ -- -- Suppose we are working in the context of some distributed environment, with -- a monadic type 'Process' representing processes, 'NodeId' representing node--- addresses and 'ProcessId' representing process addresses. Suppose further --- that we have a primitive --- +-- addresses and 'ProcessId' representing process addresses. Suppose further+-- that we have a primitive+-- -- > sendInt :: ProcessId -> Int -> Process () -- -- We might want to define@@ -106,7 +77,7 @@ -- > sendIntClosure :: ProcessId -> Closure (Int -> Process ()) -- > sendIntClosure pid = closure decoder (encode pid) -- > where--- > decoder :: Static (ByteString -> Int -> Process ()) +-- > decoder :: Static (ByteString -> Int -> Process ()) -- > decoder = sendIntStatic `staticCompose` decodeProcessIdStatic -- -- [Polymorphic example]@@ -118,8 +89,8 @@ -- which turns a process that computes an integer into a process that computes -- the integer and then sends it someplace else. ----- We can define --- +-- We can define+-- -- > bindStatic :: (Typeable a, Typeable b) => Static (Process a -> (a -> Process b) -> Process b) -- > bindStatic = staticLabel "$bind" --@@ -132,7 +103,7 @@ -- -- (Note that we are using the special 'Data.Rank1Typeable.ANY1' and -- 'Data.Rank1Typeable.ANY2' types from "Data.Rank1Typeable" to represent this--- polymorphic value.) Once we have a static bind we can define +-- polymorphic value.) Once we have a static bind we can define -- -- > sendIntResult :: ProcessId -> Closure (Process Int) -> Closure (Process ()) -- > sendIntResult pid cl = bindStatic `closureApplyStatic` cl `closureApply` sendIntClosure pid@@ -157,7 +128,7 @@ -- > sendDict BinaryDict = send -- -- Now 'sendDict' is a normal polymorphic value:--- +-- -- > sendDictStatic :: Static (BinaryDict a -> ProcessId -> a -> Process ()) -- > sendDictStatic = staticLabel "$sendDict" -- >@@ -165,20 +136,20 @@ -- > rtable = ... -- > . registerStatic "$sendDict" (sendDict :: BinaryDict ANY -> ProcessId -> ANY -> Process ()) -- > $ initRemoteTable--- +-- -- so that we can define -- -- > sendClosure :: Static (BinaryDict a) -> Process a -> Closure (a -> Process ()) -- > sendClosure dict pid = closure decoder (encode pid) -- > where -- > decoder :: Static (ByteString -> a -> Process ())--- > decoder = (sendDictStatic `staticApply` dict) `staticCompose` decodeProcessIdStatic +-- > decoder = (sendDictStatic `staticApply` dict) `staticCompose` decodeProcessIdStatic -- -- [Word of Caution] -- -- You should not /define/ functions on 'ANY' and co. For example, the following -- definition of 'rtable' is incorrect:--- +-- -- > rtable :: RemoteTable -- > rtable = registerStatic "$sdictSendPort" sdictSendPort -- > $ initRemoteTable@@ -186,7 +157,7 @@ -- > sdictSendPort :: SerializableDict ANY -> SerializableDict (SendPort ANY) -- > sdictSendPort SerializableDict = SerializableDict ----- This definition of 'sdictSendPort' ignores its argument completely, and +-- This definition of 'sdictSendPort' ignores its argument completely, and -- constructs a 'SerializableDict' for the /monomorphic/ type @SendPort ANY@, -- which isn't what you want. Instead, you should do --@@ -196,11 +167,15 @@ -- > where -- > sdictSendPort :: forall a. SerializableDict a -> SerializableDict (SendPort a) -- > sdictSendPort SerializableDict = SerializableDict-module Control.Distributed.Static - ( -- * Static values +{-# LANGUAGE StaticPointers #-}+{-# LANGUAGE RoleAnnotations #-}+module Control.Distributed.Static+ ( -- * Static values Static , staticLabel , staticApply+ , staticPtr+ , staticApplyPtr -- * Derived static combinators , staticCompose , staticSplit@@ -215,15 +190,15 @@ , closureApply , closureCompose , closureSplit- -- * Resolution + -- * Resolution , RemoteTable , initRemoteTable , registerStatic- , unstatic - , unclosure + , unstatic+ , unclosure ) where -import Data.Binary +import Data.Binary ( Binary(get, put) , Put , Get@@ -235,47 +210,90 @@ import Data.ByteString.Lazy (ByteString, empty) import Data.Map (Map) import qualified Data.Map as Map (lookup, empty, insert)-import Control.Applicative ((<$>), (<*>)) import Control.Arrow as Arrow ((***), app)+import Control.DeepSeq (NFData(rnf), force) import Data.Rank1Dynamic (Dynamic, toDynamic, fromDynamic, dynApply)-import Data.Rank1Typeable +import Data.Rank1Typeable ( Typeable- , typeOf , ANY1 , ANY2 , ANY3 , ANY4- , isInstanceOf+ , TypeRep+ , typeOf ) +-- Imports necessary to support StaticPtr+import qualified GHC.Exts as GHC (Any)+import GHC.StaticPtr+import GHC.Fingerprint.Type (Fingerprint(..))+import System.IO.Unsafe (unsafePerformIO)+import Data.Rank1Dynamic (unsafeToDynamic)+import Unsafe.Coerce (unsafeCoerce)+ -------------------------------------------------------------------------------- -- Introducing static values -- -------------------------------------------------------------------------------- +-- | Static dynamic values+--+-- In the new proposal for static, the SPT contains these 'TypeRep's.+-- In the current implemnentation however they do not, so we need to carry+-- them ourselves. This is the TypeRep of @a@, /NOT/ of @StaticPtr a@.+data SDynamic = SDynamic TypeRep (StaticPtr GHC.Any)+ deriving (Typeable)++instance Show SDynamic where+ show (SDynamic typ ptr) =+ let spi = staticPtrInfo ptr+ (line, col) = spInfoSrcLoc spi+ in concat [ "<<static ", spInfoModuleName spi, ":", show line, ":"+ , show col, " :: ", show typ, ">>"+ ]++instance Eq SDynamic where+ SDynamic _ ptr1 == SDynamic _ ptr2 =+ staticKey ptr1 == staticKey ptr2++instance Ord SDynamic where+ SDynamic _ ptr1 `compare` SDynamic _ ptr2 =+ staticKey ptr1 `compare` staticKey ptr2+ data StaticLabel = StaticLabel String- | StaticApply StaticLabel StaticLabel- deriving (Typeable, Show)+ | StaticApply !StaticLabel !StaticLabel+ | StaticPtr SDynamic+ deriving (Eq, Ord, Typeable, Show) +instance NFData StaticLabel where+ rnf (StaticLabel s) = rnf s+ rnf (StaticApply a b) = rnf a `seq` rnf b+ -- There are no NFData instances for TypeRep or for StaticPtr :/+ rnf (StaticPtr (SDynamic _a _b)) = ()+ -- | A static value. Static is opaque; see 'staticLabel' and 'staticApply'.-newtype Static a = Static StaticLabel - deriving (Typeable, Show)+newtype Static a = Static StaticLabel+ deriving (Eq, Ord, Typeable, Show) -instance Typeable a => Binary (Static a) where- put (Static label) = putStaticLabel label >> put (typeOf (undefined :: a))- get = do- label <- getStaticLabel- typeRep <- get- case typeOf (undefined :: a) `isInstanceOf` typeRep of- Left err -> fail $ "Static.get: type error: " ++ err- Right () -> return (Static label)+-- Trying to 'coerce' static values will lead to unification errors+type role Static nominal +instance NFData (Static a) where+ rnf (Static s) = rnf s++instance Binary (Static a) where+ put (Static label) = putStaticLabel label+ get = Static <$> getStaticLabel+ -- We don't want StaticLabel to be its own Binary instance putStaticLabel :: StaticLabel -> Put-putStaticLabel (StaticLabel string) = - putWord8 0 >> put string -putStaticLabel (StaticApply label1 label2) = +putStaticLabel (StaticLabel string) =+ putWord8 0 >> put string+putStaticLabel (StaticApply label1 label2) = putWord8 1 >> putStaticLabel label1 >> putStaticLabel label2+putStaticLabel (StaticPtr (SDynamic typ ptr)) =+ let Fingerprint hi lo = staticKey ptr+ in putWord8 2 >> put typ >> put hi >> put lo getStaticLabel :: Get StaticLabel getStaticLabel = do@@ -283,29 +301,55 @@ case header of 0 -> StaticLabel <$> get 1 -> StaticApply <$> getStaticLabel <*> getStaticLabel- _ -> fail "StaticLabel.get: invalid" - + 2 -> do typ <- get+ hi <- get+ lo <- get+ let key = Fingerprint hi lo+ case unsaferLookupStaticPtr key of+ Nothing -> fail "StaticLabel.get: invalid pointer"+ Just ptr -> return $ StaticPtr (SDynamic typ ptr)+ _ -> fail "StaticLabel.get: invalid"++-- | We need to be able to lookup keys outside of the IO monad so that we+-- can provide a 'Get' instance.+unsaferLookupStaticPtr :: StaticKey -> Maybe (StaticPtr a)+unsaferLookupStaticPtr = unsafePerformIO . unsafeLookupStaticPtr+ -- | Create a primitive static value.--- +-- -- It is the responsibility of the client code to make sure the corresponding -- entry in the 'RemoteTable' has the appropriate type. staticLabel :: String -> Static a-staticLabel = Static . StaticLabel +staticLabel = Static . StaticLabel . force -- | Apply two static values staticApply :: Static (a -> b) -> Static a -> Static b staticApply (Static f) (Static x) = Static (StaticApply f x) +-- | Construct a static value from a static pointer+--+-- Since 0.3.4.0.+staticPtr :: forall a. Typeable a => StaticPtr a -> Static a+staticPtr x = Static . StaticPtr+ $ SDynamic (typeOf (undefined :: a)) (unsafeCoerce x)++-- | Apply a static pointer to a static value+--+-- Since 0.3.4.0.+staticApplyPtr :: (Typeable a, Typeable b)+ => StaticPtr (a -> b) -> Static a -> Static b+staticApplyPtr = staticApply . staticPtr+ -------------------------------------------------------------------------------- -- Eliminating static values -- -------------------------------------------------------------------------------- --- | Runtime dictionary for 'unstatic' lookups +-- | Runtime dictionary for 'unstatic' lookups newtype RemoteTable = RemoteTable (Map String Dynamic) -- | Initial remote table initRemoteTable :: RemoteTable-initRemoteTable = +initRemoteTable = registerStatic "$compose" (toDynamic ((.) :: (ANY2 -> ANY3) -> (ANY1 -> ANY2) -> ANY1 -> ANY3)) . registerStatic "$const" (toDynamic (const :: ANY1 -> ANY2 -> ANY1)) . registerStatic "$split" (toDynamic ((***) :: (ANY1 -> ANY3) -> (ANY2 -> ANY4) -> (ANY1, ANY2) -> (ANY3, ANY4)))@@ -321,133 +365,125 @@ -- Pseudo-type: RemoteTable -> Static a -> a resolveStaticLabel :: RemoteTable -> StaticLabel -> Either String Dynamic-resolveStaticLabel (RemoteTable rtable) (StaticLabel label) = +resolveStaticLabel (RemoteTable rtable) (StaticLabel label) = case Map.lookup label rtable of Nothing -> Left $ "Invalid static label '" ++ label ++ "'" Just d -> Right d resolveStaticLabel rtable (StaticApply label1 label2) = do- f <- resolveStaticLabel rtable label1 + f <- resolveStaticLabel rtable label1 x <- resolveStaticLabel rtable label2 f `dynApply` x+resolveStaticLabel _ (StaticPtr (SDynamic typ ptr)) =+ return $ unsafeToDynamic typ (deRefStaticPtr ptr) -- | Resolve a static value unstatic :: Typeable a => RemoteTable -> Static a -> Either String a-unstatic rtable (Static static) = do - dyn <- resolveStaticLabel rtable static +unstatic rtable (Static label) = do+ dyn <- resolveStaticLabel rtable label fromDynamic dyn ----------------------------------------------------------------------------------- Closures -- +-- Closures -- -------------------------------------------------------------------------------- -- | A closure is a static value and an encoded environment-data Closure a = Closure (Static (ByteString -> a)) ByteString- deriving (Typeable, Show)+data Closure a = Closure !(Static (ByteString -> a)) !ByteString+ deriving (Eq, Ord, Typeable, Show) -instance Typeable a => Binary (Closure a) where- put (Closure static env) = put static >> put env- get = Closure <$> get <*> get +instance Binary (Closure a) where+ put (Closure st env) = put st >> put env+ get = Closure <$> get <*> get +instance NFData (Closure a) where rnf (Closure f b) = rnf f `seq` rnf b+ closure :: Static (ByteString -> a) -- ^ Decoder -> ByteString -- ^ Encoded closure environment -> Closure a-closure = Closure +closure = Closure -- | Resolve a closure unclosure :: Typeable a => RemoteTable -> Closure a -> Either String a-unclosure rtable (Closure static env) = do - f <- unstatic rtable static+unclosure rtable (Closure dec env) = do+ f <- unstatic rtable dec return (f env) -- | Convert a static value into a closure.-staticClosure :: Typeable a => Static a -> Closure a-staticClosure static = closure (staticConst static) empty+staticClosure :: Static a -> Closure a+staticClosure dec = closure (staticConst dec) empty -------------------------------------------------------------------------------- -- Predefined static values -- -------------------------------------------------------------------------------- -- | Static version of ('Prelude..')-composeStatic :: (Typeable a, Typeable b, Typeable c) - => Static ((b -> c) -> (a -> b) -> a -> c)-composeStatic = staticLabel "$compose" +composeStatic :: Static ((b -> c) -> (a -> b) -> a -> c)+composeStatic = staticLabel "$compose" -- | Static version of 'const'-constStatic :: (Typeable a, Typeable b)- => Static (a -> b -> a)-constStatic = staticLabel "$const" +constStatic :: Static (a -> b -> a)+constStatic = staticLabel "$const" -- | Static version of ('Arrow.***')-splitStatic :: (Typeable a, Typeable a', Typeable b, Typeable b') - => Static ((a -> b) -> (a' -> b') -> (a, a') -> (b, b')) +splitStatic :: Static ((a -> b) -> (a' -> b') -> (a, a') -> (b, b')) splitStatic = staticLabel "$split" -- | Static version of 'Arrow.app'-appStatic :: (Typeable a, Typeable b)- => Static ((a -> b, a) -> b)+appStatic :: Static ((a -> b, a) -> b) appStatic = staticLabel "$app" -- | Static version of 'flip'-flipStatic :: (Typeable a, Typeable b, Typeable c)- => Static ((a -> b -> c) -> b -> a -> c)-flipStatic = staticLabel "$flip" +flipStatic :: Static ((a -> b -> c) -> b -> a -> c)+flipStatic = staticLabel "$flip" -------------------------------------------------------------------------------- -- Combinators on static values -- -------------------------------------------------------------------------------- --- | Static version of ('Prelude..') -staticCompose :: (Typeable a, Typeable b, Typeable c)- => Static (b -> c) -> Static (a -> b) -> Static (a -> c)+-- | Static version of ('Prelude..')+staticCompose :: Static (b -> c) -> Static (a -> b) -> Static (a -> c) staticCompose g f = composeStatic `staticApply` g `staticApply` f -- | Static version of ('Control.Arrow.***')-staticSplit :: (Typeable a, Typeable a', Typeable b, Typeable b') - => Static (a -> b) -> Static (a' -> b') -> Static ((a, a') -> (b, b'))+staticSplit :: Static (a -> b) -> Static (a' -> b') -> Static ((a, a') -> (b, b')) staticSplit f g = splitStatic `staticApply` f `staticApply` g -- | Static version of 'Prelude.const'-staticConst :: (Typeable a, Typeable b)- => Static a -> Static (b -> a)-staticConst x = constStatic `staticApply` x +staticConst :: Static a -> Static (b -> a)+staticConst x = constStatic `staticApply` x -- | Static version of 'Prelude.flip'-staticFlip :: (Typeable a, Typeable b, Typeable c)- => Static (a -> b -> c) -> Static (b -> a -> c)-staticFlip f = flipStatic `staticApply` f +staticFlip :: Static (a -> b -> c) -> Static (b -> a -> c)+staticFlip f = flipStatic `staticApply` f -------------------------------------------------------------------------------- -- Combinators on Closures -- -------------------------------------------------------------------------------- -- | Apply a static function to a closure-closureApplyStatic :: (Typeable a, Typeable b)- => Static (a -> b) -> Closure a -> Closure b-closureApplyStatic f (Closure decoder env) = +closureApplyStatic :: Static (a -> b) -> Closure a -> Closure b+closureApplyStatic f (Closure decoder env) = closure (f `staticCompose` decoder) env decodeEnvPairStatic :: Static (ByteString -> (ByteString, ByteString)) decodeEnvPairStatic = staticLabel "$decodeEnvPair" -- | Closure application-closureApply :: forall a b. (Typeable a, Typeable b)- => Closure (a -> b) -> Closure a -> Closure b-closureApply (Closure fdec fenv) (Closure xdec xenv) = +closureApply :: forall a b .+ Closure (a -> b) -> Closure a -> Closure b+closureApply (Closure fdec fenv) (Closure xdec xenv) = closure decoder (encode (fenv, xenv)) where decoder :: Static (ByteString -> b)- decoder = appStatic + decoder = appStatic `staticCompose` (fdec `staticSplit` xdec) `staticCompose`- decodeEnvPairStatic + decodeEnvPairStatic -- | Closure composition-closureCompose :: (Typeable a, Typeable b, Typeable c)- => Closure (b -> c) -> Closure (a -> b) -> Closure (a -> c)+closureCompose :: Closure (b -> c) -> Closure (a -> b) -> Closure (a -> c) closureCompose g f = composeStatic `closureApplyStatic` g `closureApply` f -- | Closure version of ('Arrow.***')-closureSplit :: (Typeable a, Typeable a', Typeable b, Typeable b') - => Closure (a -> b) -> Closure (a' -> b') -> Closure ((a, a') -> (b, b'))-closureSplit f g = splitStatic `closureApplyStatic` f `closureApply` g +closureSplit :: Closure (a -> b) -> Closure (a' -> b') -> Closure ((a, a') -> (b, b'))+closureSplit f g = splitStatic `closureApplyStatic` f `closureApply` g