diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, Edsko de Vries + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Edsko de Vries nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/distributed-static.cabal b/distributed-static.cabal new file mode 100644 --- /dev/null +++ b/distributed-static.cabal @@ -0,0 +1,37 @@ +Name: distributed-static +Version: 0.1.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: + values that are known at compile 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 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: type safety (including for + polymorphic static values) and compositionality. +Homepage: http://www.github.com/haskell-distributed/distributed-process +License: BSD3 +License-File: LICENSE +Author: Edsko de Vries +Maintainer: edsko@well-typed.com +Copyright: Well-Typed LLP +Category: Control +Build-Type: Simple +Cabal-Version: >=1.8 + +Library + Exposed-Modules: Control.Distributed.Static + Build-Depends: base >= 4 && < 5, + rank1dynamic >= 0.1 && < 0.2, + containers >= 0.4 && < 0.5, + bytestring >= 0.9 && < 0.11, + binary >= 0.5 && < 0.6 + HS-Source-Dirs: src + Extensions: DeriveDataTypeable, + ScopedTypeVariables + GHC-Options: -Wall diff --git a/src/Control/Distributed/Static.hs b/src/Control/Distributed/Static.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Static.hs @@ -0,0 +1,435 @@ +-- | /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 +-- 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 +-- 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 +-- /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 +-- 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'). +-- +-- [Closures] +-- +-- Closures in functional programming arise when we partially apply a function. +-- A closure is a code pointer together with a runtime data structure that +-- represents the value of the free variables of the function. A 'Closure' +-- represents these closures explicitly so that they can be serialized: +-- +-- > data Closure a = Closure (Static (ByteString -> a)) ByteString +-- +-- 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'). +-- Moreover, since 'Static' is now compositional, we can also define derived +-- operators on 'Closure' values ('closureApplyStatic', 'closureApply', +-- 'closureCompose', 'closureSplit'). +-- +-- [Monomorphic example] +-- +-- 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 +-- +-- > sendInt :: ProcessId -> Int -> Process () +-- +-- We might want to define +-- +-- > sendIntClosure :: ProcessId -> Closure (Int -> Process ()) +-- +-- In order to do that, we need a static version of 'send', and a static +-- decoder for 'ProcessId': +-- +-- > sendIntStatic :: Static (ProcessId -> Int -> Process ()) +-- > sendIntStatic = staticLabel "$send" +-- +-- > decodeProcessIdStatic :: Static (ByteString -> Int) +-- > decodeProcessIdStatic = staticLabel "$decodeProcessId" +-- +-- where of course we have to make sure to use an appropriate 'RemoteTable': +-- +-- > rtable :: RemoteTable +-- > rtable = registerStatic "$send" (toDynamic sendInt) +-- > . registerStatic "$decodeProcessId" (toDynamic (decode :: ByteString -> Int)) +-- > $ initRemoteTable +-- +-- We can now define 'sendIntClosure': +-- +-- > sendIntClosure :: ProcessId -> Closure (Int -> Process ()) +-- > sendIntClosure pid = Closure decoder (encode pid) +-- > where +-- > decoder :: Static (ByteString -> Int -> Process ()) +-- > decoder = sendIntStatic `staticCompose` decodeProcessIdStatic +-- +-- [Polymorphic example] +-- +-- Suppose we wanted to define a primitive +-- +-- > sendIntResult :: ProcessId -> Closure (Process Int) -> Closure (Process ()) +-- +-- which turns a process that computes an integer into a process that computes +-- the integer and then sends it someplace else. +-- +-- We can define +-- +-- > bindStatic :: (Typeable a, Typeable b) => Static (Process a -> (a -> Process b) -> Process b) +-- > bindStatic = staticLabel "$bind" +-- +-- provided that we register this label: +-- +-- > rtable :: RemoteTable +-- > rtable = ... +-- > . registerStatic "$bind" ((>>=) :: Process ANY1 -> (ANY1 -> Process ANY2) -> Process ANY2) +-- > $ initRemoteTable +-- +-- (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 +-- +-- > sendIntResult :: ProcessId -> Closure (Process Int) -> Closure (Process ()) +-- > sendIntResult pid cl = bindStatic `closureApplyStatic` cl `closureApply` sendIntClosure pid +-- +-- [Dealing with qualified types] +-- +-- In the above we were careful to avoid qualified types. Suppose that we have +-- instead +-- +-- > send :: Binary a => ProcessId -> a -> Process () +-- +-- If we now want to define 'sendClosure', analogous to 'sendIntClosure' above, +-- we somehow need to include the 'Binary' instance in the closure -- after +-- all, we can ship this closure someplace else, where it needs to accept an +-- 'a', /then encode it/, and send it off. In order to do this, we need to turn +-- the Binary instance into an explicit dictionary: +-- +-- > data BinaryDict a where +-- > BinaryDict :: Binary a => BinaryDict a +-- > +-- > sendDict :: BinaryDict a -> ProcessId -> a -> Process () +-- > sendDict BinaryDict = send +-- +-- Now 'sendDict' is a normal polymorphic value: +-- +-- > sendDictStatic :: Static (BinaryDict a -> ProcessId -> a -> Process ()) +-- > sendDictStatic = staticLabel "$sendDict" +-- > +-- > rtable :: RemoteTable +-- > 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 +-- +-- [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 +-- > where +-- > sdictSendPort :: SerializableDict ANY -> SerializableDict (SendPort ANY) +-- > sdictSendPort SerializableDict = SerializableDict +-- +-- 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 +-- +-- > rtable :: RemoteTable +-- > rtable = registerStatic "$sdictSendPort" (sdictSendPort :: SerializableDict ANY -> SerializableDict (SendPort ANY)) +-- > $ initRemoteTable +-- > where +-- > sdictSendPort :: forall a. SerializableDict a -> SerializableDict (SendPort a) +-- > sdictSendPort SerializableDict = SerializableDict +module Control.Distributed.Static + ( -- * Static values + Static + , staticLabel + , staticApply + -- * Derived static combinators + , staticCompose + , staticSplit + , staticConst + -- * Closures + , Closure(Closure) + -- * Derived closure combinators + , staticClosure + , closureApplyStatic + , closureApply + , closureCompose + , closureSplit + -- * Resolution + , RemoteTable + , initRemoteTable + , registerStatic + , unstatic + , unclosure + ) where + +import Data.Binary + ( Binary(get, put) + , Put + , Get + , putWord8 + , getWord8 + , encode + , decode + ) +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 Data.Rank1Dynamic (Dynamic, toDynamic, fromDynamic, dynApply) +import Data.Rank1Typeable + ( Typeable + , typeOf + , ANY1 + , ANY2 + , ANY3 + , ANY4 + , isInstanceOf + ) + +-------------------------------------------------------------------------------- +-- Introducing static values -- +-------------------------------------------------------------------------------- + +data StaticLabel = + StaticLabel String + | StaticApply StaticLabel StaticLabel + deriving (Typeable, Show) + +-- | A static value. Static is opaque; see 'staticLabel' and 'staticApply'. +newtype Static a = Static StaticLabel + deriving (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) + +-- 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) = + putWord8 1 >> putStaticLabel label1 >> putStaticLabel label2 + +getStaticLabel :: Get StaticLabel +getStaticLabel = do + header <- getWord8 + case header of + 0 -> StaticLabel <$> get + 1 -> StaticApply <$> getStaticLabel <*> getStaticLabel + _ -> 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 + +-- | Apply two static values +staticApply :: Static (a -> b) -> Static a -> Static b +staticApply (Static f) (Static x) = Static (StaticApply f x) + +-------------------------------------------------------------------------------- +-- Eliminating static values -- +-------------------------------------------------------------------------------- + +-- | Runtime dictionary for 'unstatic' lookups +newtype RemoteTable = RemoteTable (Map String Dynamic) + +-- | Initial remote table +initRemoteTable :: RemoteTable +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))) + . registerStatic "$app" (toDynamic (app :: (ANY1 -> ANY2, ANY1) -> ANY2)) + . registerStatic "$decodeEnvPair" (toDynamic (decode :: ByteString -> (ByteString, ByteString))) + $ RemoteTable Map.empty + +-- | Register a static label +registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable +registerStatic label dyn (RemoteTable rtable) + = RemoteTable (Map.insert label dyn rtable) + +-- Pseudo-type: RemoteTable -> Static a -> a +resolveStaticLabel :: RemoteTable -> StaticLabel -> Either String Dynamic +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 + 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 + fromDynamic dyn + +-------------------------------------------------------------------------------- +-- Closures -- +-------------------------------------------------------------------------------- + +-- | A closure is a static value and an encoded environment +data Closure a = Closure (Static (ByteString -> a)) ByteString + deriving (Typeable, Show) + +instance Typeable a => Binary (Closure a) where + put (Closure static env) = put static >> put env + get = Closure <$> get <*> get + +-- | Resolve a closure +unclosure :: Typeable a => RemoteTable -> Closure a -> Either String a +unclosure rtable (Closure static env) = do + f <- unstatic rtable static + return (f env) + +-- | Convert a static value into a closure. +staticClosure :: Typeable a => Static a -> Closure a +staticClosure static = Closure (staticConst static) 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" + +-- | Static version of 'const' +constStatic :: (Typeable a, Typeable b) + => 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 = staticLabel "$split" + +-- | Static version of 'Arrow.app' +appStatic :: (Typeable a, Typeable b) + => Static ((a -> b, a) -> b) +appStatic = staticLabel "$app" + +-------------------------------------------------------------------------------- +-- Combinators on static values -- +-------------------------------------------------------------------------------- + +-- | 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') + => 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 + +-------------------------------------------------------------------------------- +-- 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) = + 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) = + Closure decoder (encode (fenv, xenv)) + where + decoder :: Static (ByteString -> b) + decoder = appStatic + `staticCompose` + (fdec `staticSplit` xdec) + `staticCompose` + decodeEnvPairStatic + +-- | Closure composition +closureCompose :: (Typeable a, Typeable b, Typeable c) + => 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