diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,20 @@ +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/distributed-static.cabal b/distributed-static.cabal --- a/distributed-static.cabal +++ b/distributed-static.cabal @@ -1,5 +1,5 @@ Name: distributed-static -Version: 0.2.1.1 +Version: 0.3.0.0 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: @@ -14,24 +14,31 @@ '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 +Homepage: http://haskell-distributed.github.com License: BSD3 License-File: LICENSE Author: Edsko de Vries -Maintainer: edsko@well-typed.com +Maintainer: edsko@well-typed.com, watson.timothy@gmail.com +Bug-Reports: https://cloud-haskell.atlassian.net/browse/DS Copyright: Well-Typed LLP Category: Control Build-Type: Simple -Cabal-Version: >=1.8 +Cabal-Version: >=1.10 +extra-source-files: ChangeLog +Source-Repository head + Type: git + Location: https://github.com/haskell-distributed/distributed-static + Library Exposed-Modules: Control.Distributed.Static Build-Depends: base >= 4 && < 5, - rank1dynamic >= 0.1 && < 0.2, + rank1dynamic >= 0.1 && < 0.3, containers >= 0.4 && < 0.6, bytestring >= 0.9 && < 0.11, - binary >= 0.5 && < 0.7 + binary >= 0.5 && < 0.8 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,9 +1,9 @@ --- | /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. @@ -13,13 +13,13 @@ -- The paper stipulates that 'Static' values should have a free 'Binary' -- instance: -- --- > instance Binary (Static a) +-- > 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 +-- > f :: Static Int -> Static Bool +-- > f = decode . encode -- -- For this reason we work only with 'Typeable' terms in this module, and -- implement runtime checks @@ -34,7 +34,7 @@ -- -- 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 +-- use the implementation from "Data.Rank1Dynamic" so that we can store -- polymorphic dynamic values. -- -- [Compositionality] @@ -43,18 +43,18 @@ -- 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 +67,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 +76,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 +106,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 +118,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 +132,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 +157,7 @@ -- > sendDict BinaryDict = send -- -- Now 'sendDict' is a normal polymorphic value: --- +-- -- > sendDictStatic :: Static (BinaryDict a -> ProcessId -> a -> Process ()) -- > sendDictStatic = staticLabel "$sendDict" -- > @@ -165,20 +165,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 +186,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,8 +196,8 @@ -- > where -- > sdictSendPort :: forall a. SerializableDict a -> SerializableDict (SendPort a) -- > sdictSendPort SerializableDict = SerializableDict -module Control.Distributed.Static - ( -- * Static values +module Control.Distributed.Static + ( -- * Static values Static , staticLabel , staticApply @@ -215,15 +215,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 @@ -238,7 +238,7 @@ import Control.Applicative ((<$>), (<*>)) import Control.Arrow as Arrow ((***), app) import Data.Rank1Dynamic (Dynamic, toDynamic, fromDynamic, dynApply) -import Data.Rank1Typeable +import Data.Rank1Typeable ( Typeable , typeOf , ANY1 @@ -258,7 +258,7 @@ deriving (Typeable, Show) -- | A static value. Static is opaque; see 'staticLabel' and 'staticApply'. -newtype Static a = Static StaticLabel +newtype Static a = Static StaticLabel deriving (Typeable, Show) instance Typeable a => Binary (Static a) where @@ -272,9 +272,9 @@ -- 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 getStaticLabel :: Get StaticLabel @@ -283,14 +283,14 @@ case header of 0 -> StaticLabel <$> get 1 -> StaticApply <$> getStaticLabel <*> getStaticLabel - _ -> fail "StaticLabel.get: invalid" - + _ -> fail "StaticLabel.get: invalid" + -- | 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 -- | Apply two static values staticApply :: Static (a -> b) -> Static a -> Static b @@ -300,12 +300,12 @@ -- 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,23 +321,23 @@ -- 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 -- | 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 static) = do + dyn <- resolveStaticLabel rtable static fromDynamic dyn -------------------------------------------------------------------------------- --- Closures -- +-- Closures -- -------------------------------------------------------------------------------- -- | A closure is a static value and an encoded environment @@ -346,16 +346,16 @@ instance Typeable a => Binary (Closure a) where put (Closure static env) = put static >> put env - get = Closure <$> get <*> get + get = Closure <$> get <*> get 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 +unclosure rtable (Closure static env) = do f <- unstatic rtable static return (f env) @@ -368,18 +368,18 @@ -------------------------------------------------------------------------------- -- | Static version of ('Prelude..') -composeStatic :: (Typeable a, Typeable b, Typeable c) +composeStatic :: (Typeable a, Typeable b, Typeable c) => Static ((b -> c) -> (a -> b) -> a -> c) -composeStatic = staticLabel "$compose" +composeStatic = staticLabel "$compose" -- | Static version of 'const' constStatic :: (Typeable a, Typeable b) => Static (a -> b -> a) -constStatic = staticLabel "$const" +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 :: (Typeable a, Typeable a', Typeable b, Typeable b') + => Static ((a -> b) -> (a' -> b') -> (a, a') -> (b, b')) splitStatic = staticLabel "$split" -- | Static version of 'Arrow.app' @@ -390,31 +390,31 @@ -- | Static version of 'flip' flipStatic :: (Typeable a, Typeable b, Typeable c) => Static ((a -> b -> c) -> b -> a -> c) -flipStatic = staticLabel "$flip" +flipStatic = staticLabel "$flip" -------------------------------------------------------------------------------- -- Combinators on static values -- -------------------------------------------------------------------------------- --- | Static version of ('Prelude..') +-- | Static version of ('Prelude..') staticCompose :: (Typeable a, Typeable b, Typeable c) => 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') +staticSplit :: (Typeable a, Typeable a', Typeable b, Typeable b') => 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 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 f = flipStatic `staticApply` f -------------------------------------------------------------------------------- -- Combinators on Closures -- @@ -423,7 +423,7 @@ -- | 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 f (Closure decoder env) = closure (f `staticCompose` decoder) env decodeEnvPairStatic :: Static (ByteString -> (ByteString, ByteString)) @@ -432,15 +432,15 @@ -- | 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 (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) @@ -448,6 +448,6 @@ closureCompose g f = composeStatic `closureApplyStatic` g `closureApply` f -- | Closure version of ('Arrow.***') -closureSplit :: (Typeable a, Typeable a', Typeable b, Typeable b') +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 f g = splitStatic `closureApplyStatic` f `closureApply` g