diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,66 @@ +2024-09-03 Laurent P. René de Cotret 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 0.3.10 + +* Relax bytestring bounds to to build with ghc-9.8. + +2019-05-12 Facundo Domínguez 0.3.9 + +* Relax bounds to to build with ghc-8.6. + +2017-08-28 Facundo Domínguez 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 0.3.7 + +* Make nominal the role of static + +2017-08-22 Facundo Domínguez 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 0.3.5.0 + +* Add compatibility with ghc-8. + +2016-02-18 Facundo Domínguez 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 0.3.2.0 + +* Loosen rank1dynamic bounds. +* Add NFData instances. + +2014-12-09 Tim Watson 0.3.1.0 + +* Eq and Ord instances for Closure and Static + +2014-05-30 Tim Watson 0.3.0.0 + +* Bump binary dependency + +2012-11-22 Edsko de Vries 0.2.1.1 + +* Relax package bounds to allow for Binary 0.6 + +2012-10-03 Edsko de Vries 0.2.1 + +* Add support for 'staticFlip' + +2012-08-16 Edsko de Vries 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 0.1 + +* Initial release diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/distributed-static.cabal b/distributed-static.cabal --- a/distributed-static.cabal +++ b/distributed-static.cabal @@ -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 diff --git a/src/Control/Distributed/Static.hs b/src/Control/Distributed/Static.hs --- a/src/Control/Distributed/Static.hs +++ b/src/Control/Distributed/Static.hs @@ -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 [ "<>" + ] + +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