Skip to content

Commit bcc7a80

Browse files
edskoedsko
committed
Bumb version 0.2.3/Serializable Static
1 parent 13ac8e7 commit bcc7a80

File tree

9 files changed

+55
-36
lines changed

9 files changed

+55
-36
lines changed

‎distributed-process-azure/src/Control/Distributed/Process/Backend/Azure.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -79,7 +79,7 @@ encodeToStdout = liftIO . BSL.putStr . encode
7979
encodeToStdoutDict :: SerializableDict a -> a -> Process ()
8080
encodeToStdoutDict SerializableDict = encodeToStdout
8181

82-
remotable ['encodeToStdoutDict]
82+
remotable ['encodeToStdout]
8383

8484
-- | Azure backend
8585
data Backend = Backend {

‎distributed-process/ChangeLog

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,8 @@
1-
2012-08-02 Edsko de Vries <edsko@well-typed.com> 0.2.2.1
1+
2012-08-02 Edsko de Vries <edsko@well-typed.com> 0.2.3.0
22

33
* Expose the constructors of Closure
4+
* Add instance (Typeable a => Serializable (Static a)) and make sure we only
5+
use the internal representation of Static where really necessary
46
* Improved docs
57

68
2012-07-31 Edsko de Vries <edsko@well-typed.com> 0.2.2.0

‎distributed-process/src/Control/Distributed/Process.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -115,7 +115,7 @@ import Control.Distributed.Process.Internal.Types
115115
, ProcessId(..)
116116
, Process(..)
117117
, Closure(..)
118-
, Static(..)
118+
, Static
119119
, MonitorRef(..)
120120
, ProcessMonitorNotification(..)
121121
, NodeMonitorNotification(..)

‎distributed-process/src/Control/Distributed/Process/Internal/Closure/CP.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -117,9 +117,9 @@ sdictComp = SerializableDict
117117

118118
-- | Resolve a closure
119119
unClosure :: Static a -> ByteString -> Process Dynamic
120-
unClosure (Static label) env = do
120+
unClosure static env = do
121121
rtable <- remoteTable . processNode <$> ask
122-
case resolveClosure rtable label env of
122+
case resolveClosure rtable static env of
123123
Nothing -> fail "Derived.unClosure: resolveClosure failed"
124124
Just dyn -> return dyn
125125

‎distributed-process/src/Control/Distributed/Process/Internal/Closure/Resolution.hs

Lines changed: 7 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -17,18 +17,18 @@ import Control.Distributed.Process.Internal.Dynamic
1717
)
1818
import Control.Distributed.Process.Internal.TypeRep () -- Binary instances
1919

20-
resolveStatic :: RemoteTable -> StaticLabel -> Maybe Dynamic
21-
resolveStatic rtable (StaticLabel string typ) = do
20+
resolveStatic :: RemoteTable -> Static a -> Maybe Dynamic
21+
resolveStatic rtable (Static (StaticLabel string typ)) = do
2222
Dynamic _ val <- rtable ^. remoteTableLabel string
2323
return (Dynamic typ val)
24-
resolveStatic rtable (StaticApply static1 static2) = do
25-
f <- resolveStatic rtable static1
26-
x <- resolveStatic rtable static2
24+
resolveStatic rtable (Static (StaticApply static1 static2)) = do
25+
f <- resolveStatic rtable (Static static1)
26+
x <- resolveStatic rtable (Static static2)
2727
f `dynApply` x
28-
resolveStatic _rtable (StaticDuplicate static typ) =
28+
resolveStatic _rtable (Static (StaticDuplicate static typ)) =
2929
return $ Dynamic typ (unsafeCoerce# (Static static))
3030

31-
resolveClosure :: RemoteTable -> StaticLabel -> ByteString -> Maybe Dynamic
31+
resolveClosure :: RemoteTable -> Static a -> ByteString -> Maybe Dynamic
3232
resolveClosure rtable static env = do
3333
decoder <- resolveStatic rtable static
3434
decoder `dynApply` toDyn env

‎distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs

Lines changed: 3 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -118,7 +118,6 @@ import Control.Distributed.Process.Internal.Types
118118
, DidUnlinkPort(..)
119119
, WhereIsReply(..)
120120
, createMessage
121-
, Static(..)
122121
, runLocalProcess
123122
)
124123
import Control.Distributed.Process.Internal.Node (sendMessage, sendBinary)
@@ -503,10 +502,10 @@ nsendRemote nid label msg =
503502

504503
-- | Deserialize a closure
505504
unClosure :: forall a. Typeable a => Closure a -> Process a
506-
unClosure (Closure (Static label) env) = do
505+
unClosure (Closure static env) = do
507506
rtable <- remoteTable . processNode <$> ask
508-
case resolveClosure rtable label env of
509-
Nothing -> error $ "Unregistered closure " ++ show label
507+
case resolveClosure rtable static env of
508+
Nothing -> error $ "Unregistered closure " ++ show static
510509
Just dyn -> return $ fromDyn dyn (throw (typeError dyn))
511510
where
512511
typeError dyn = userError $ "lookupStatic type error: "

‎distributed-process/src/Control/Distributed/Process/Internal/Types.hs

Lines changed: 35 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -78,7 +78,7 @@ import Data.Map (Map)
7878
import Data.Int (Int32)
7979
import Data.Maybe (fromJust)
8080
import Data.Typeable (Typeable, TypeRep, typeOf, funResultTy)
81-
import Data.Binary (Binary(put, get), putWord8, getWord8, encode)
81+
import Data.Binary (Binary(put, get), putWord8, getWord8, encode, Put, Get)
8282
import qualified Data.ByteString as BSS (ByteString, concat)
8383
import qualified Data.ByteString.Lazy as BSL
8484
( ByteString
@@ -109,7 +109,7 @@ import Control.Distributed.Process.Serializable
109109
)
110110
import Control.Distributed.Process.Internal.CQueue (CQueue)
111111
import Control.Distributed.Process.Internal.Dynamic (Dynamic)
112-
import Control.Distributed.Process.Internal.TypeRep () -- Binary instances
112+
import Control.Distributed.Process.Internal.TypeRep (compareTypeRep) -- and Binary instances
113113

114114
--------------------------------------------------------------------------------
115115
-- Node and process identifiers --
@@ -265,7 +265,15 @@ data StaticLabel =
265265
| StaticDuplicate StaticLabel TypeRep
266266
deriving (Typeable, Show)
267267

268-
-- | A static value is top-level bound or the application of two static values
268+
-- | A static value is top-level bound or the application of two static values.
269+
--
270+
-- You construct static values using 'Control.Distributed.Process.Closure.mkStatic'
271+
-- or 'staticApply'. 'Static' has a serializable instance for all /Typeable/ 'a':
272+
--
273+
-- > instance Typeable a => Serializable (Static a)
274+
--
275+
-- The 'Typeable' constraint (not present in the original Cloud Haskell paper)
276+
-- makes it possible to do a type check during deserialization.
269277
newtype Static a = Static StaticLabel
270278
deriving (Typeable, Show)
271279

@@ -518,9 +526,9 @@ instance Binary DiedReason where
518526
4 -> return DiedUnknownId
519527
_ -> fail "DiedReason.get: invalid"
520528

521-
instance Binary (Closure a) where
522-
put (Closure (Static label) env) = put label >> put env
523-
get = Closure <$> (Static <$> get) <*> get
529+
instance Typeable a => Binary (Closure a) where
530+
put (Closure static env) = put static >> put env
531+
get = Closure <$> get <*> get
524532

525533
instance Binary DidSpawn where
526534
put (DidSpawn ref pid) = put ref >> put pid
@@ -542,17 +550,28 @@ instance Binary Identifier where
542550
2 -> SendPortIdentifier <$> get
543551
_ -> fail "Identifier.get: invalid"
544552

545-
instance Binary StaticLabel where
546-
put (StaticLabel string typ) = putWord8 0 >> put string >> put typ
547-
put (StaticApply label1 label2) = putWord8 1 >> put label1 >> put label2
548-
put (StaticDuplicate label typ) = putWord8 2 >> put label >> put typ
553+
-- We don't want StaticLabel to be its own Binary instance
554+
putStaticLabel :: StaticLabel -> Put
555+
putStaticLabel (StaticLabel string typ) = putWord8 0 >> put string >> put typ
556+
putStaticLabel (StaticApply label1 label2) = putWord8 1 >> putStaticLabel label1 >> putStaticLabel label2
557+
putStaticLabel (StaticDuplicate label typ) = putWord8 2 >> putStaticLabel label >> put typ
558+
559+
getStaticLabel :: Get StaticLabel
560+
getStaticLabel = do
561+
header <- getWord8
562+
case header of
563+
0 -> StaticLabel <$> get <*> get
564+
1 -> StaticApply <$> getStaticLabel <*> getStaticLabel
565+
2 -> StaticDuplicate <$> getStaticLabel <*> get
566+
_ -> fail "StaticLabel.get: invalid"
567+
568+
instance Typeable a => Binary (Static a) where
569+
put (Static label) = putStaticLabel label
549570
get = do
550-
header <- getWord8
551-
case header of
552-
0 -> StaticLabel <$> get <*> get
553-
1 -> StaticApply <$> get <*> get
554-
2 -> StaticDuplicate <$> get <*> get
555-
_ -> fail "StaticLabel.get: invalid"
571+
label <- getStaticLabel
572+
if typeOfStaticLabel label `compareTypeRep` typeOf (undefined :: a)
573+
then return $ Static label
574+
else fail "Static.get: type error"
556575

557576
instance Binary WhereIsReply where
558577
put (WhereIsReply label mPid) = put label >> put mPid

‎distributed-process/src/Control/Distributed/Process/Node.hs

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -99,7 +99,6 @@ import Control.Distributed.Process.Internal.Types
9999
, SpawnRef
100100
, DidSpawn(..)
101101
, Closure(..)
102-
, Static(..)
103102
, Message
104103
, TypedChannel(..)
105104
, Identifier(..)
@@ -605,9 +604,9 @@ isLocal nid ident = nodeOf ident == localNodeId nid
605604

606605
-- | Lookup a local closure
607606
unClosure :: Typeable a => Closure a -> NC (Maybe a)
608-
unClosure (Closure (Static label) env) = do
607+
unClosure (Closure static env) = do
609608
rtable <- remoteTable <$> ask
610-
return (resolveClosure rtable label env >>= fromDynamic)
609+
return (resolveClosure rtable static env >>= fromDynamic)
611610

612611
-- | Check if an identifier refers to a valid local object
613612
isValidLocalIdentifier :: Identifier -> NC Bool

‎distributed-process/tests/TestClosure.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -12,7 +12,7 @@ import Network.Transport.TCP (createTransport, defaultTCPParameters)
1212
import Control.Distributed.Process
1313
import Control.Distributed.Process.Closure
1414
import Control.Distributed.Process.Node
15-
import Control.Distributed.Process.Internal.Types (Closure(..), Static(..), StaticLabel(..))
15+
import Control.Distributed.Process.Internal.Types (Static(Static), StaticLabel(StaticLabel))
1616
import TestAuxiliary
1717

1818
sdictInt :: SerializableDict Int

0 commit comments

Comments
 (0)