git.iko.soy/distributed-process
on master help sign in
Replace Data.Dynamic with custom library
e3c0bbeEdsko de Vries
distributed-process/distributed-process.cabal+2
compare with master
unifiedsplit
@@ -20,6 +20,7 @@ Library
20 random,
20 random,
21 template-haskell,
21 template-haskell,
22 stm,
22 stm,
23+ ghc-prim,
23 network-transport >= 0.1
24 network-transport >= 0.1
24 Exposed-modules: Control.Distributed.Process,
25 Exposed-modules: Control.Distributed.Process,
25 Control.Distributed.Process.Serializable,
26 Control.Distributed.Process.Serializable,
@@ -43,6 +44,7 @@ Test-Suite TestCH
43 ansi-terminal,
44 ansi-terminal,
44 template-haskell,
45 template-haskell,
45 stm,
46 stm,
47+ ghc-prim,
46 network-transport >= 0.1
48 network-transport >= 0.1
47 Extensions: ExplicitForAll, ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, DeriveDataTypeable, TemplateHaskell, ExistentialQuantification
49 Extensions: ExplicitForAll, ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, DeriveDataTypeable, TemplateHaskell, ExistentialQuantification
48 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
50 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
distributed-process/src/Control/Distributed/Process.hs+1−1
@@ -63,7 +63,6 @@ module Control.Distributed.Process
63import Prelude hiding (catch)
63import Prelude hiding (catch)
64import Data.Binary (decode, encode)
64import Data.Binary (decode, encode)
65import Data.Typeable (Typeable)
65import Data.Typeable (Typeable)
66−import Data.Dynamic (fromDyn)
67import qualified Data.Map as Map ((!))
66import qualified Data.Map as Map ((!))
68import Control.Monad.Reader (ask)
67import Control.Monad.Reader (ask)
69import Control.Monad.IO.Class (MonadIO, liftIO)
68import Control.Monad.IO.Class (MonadIO, liftIO)
@@ -125,6 +124,7 @@ import Control.Distributed.Process.Internal.MessageT
125 , sendBinary
124 , sendBinary
126 , getLocalNode
125 , getLocalNode
127 )
126 )
127+import Control.Distributed.Process.Internal.Dynamic (fromDyn)
128
128
129-- INTERNAL NOTES
129-- INTERNAL NOTES
130--
130--
distributed-process/src/Control/Distributed/Process/Closure.hs+1−1
@@ -45,7 +45,6 @@ import Prelude hiding (lookup)
45import Data.ByteString.Lazy (ByteString)
45import Data.ByteString.Lazy (ByteString)
46import Data.Binary (encode, decode)
46import Data.Binary (encode, decode)
47import qualified Data.Map as Map (insert)
47import qualified Data.Map as Map (insert)
48−import Data.Dynamic (toDyn)
49import Control.Applicative ((<$>))
48import Control.Applicative ((<$>))
50import Control.Monad (join)
49import Control.Monad (join)
51import Language.Haskell.TH
50import Language.Haskell.TH
@@ -83,6 +82,7 @@ import Control.Distributed.Process.Internal.Types
83 , CallReply(..)
82 , CallReply(..)
84 )
83 )
85import Control.Distributed.Process (send, unClosure)
84import Control.Distributed.Process (send, unClosure)
85+import Control.Distributed.Process.Internal.Dynamic (toDyn)
86
86
87--------------------------------------------------------------------------------
87--------------------------------------------------------------------------------
88-- Top-level API --
88-- Top-level API --
distributed-process/src/Control/Distributed/Process/Internal/Dynamic.hsnew file+72
@@ -0,0 +1,72 @@
1+-- | Reimplementation of Dynamic that supports dynBind
2+--
3+-- We don't have access to the internal representation of Dynamic, otherwise
4+-- we would not have to redefine it completely. Note that we use this only
5+-- internally, so the incompatibility with "our" Dynamic from the standard
6+-- Dynamic is not important.
7+{-# LANGUAGE MagicHash #-}
8+module Control.Distributed.Process.Internal.Dynamic
9+ ( Dynamic
10+ , toDyn
11+ , fromDyn
12+ , fromDynamic
13+ , dynBindIO
14+ , dynBindIO'
15+ ) where
16+
17+import Data.Typeable
18+ ( Typeable
19+ , TypeRep
20+ , typeOf
21+ , TyCon
22+ , typeRepTyCon
23+ , splitTyConApp
24+ , funResultTy
25+ )
26+import qualified GHC.Prim as GHC (Any, unsafeCoerce#)
27+import Data.Maybe (fromMaybe)
28+
29+data Dynamic = Dynamic TypeRep GHC.Any
30+
31+toDyn :: Typeable a => a -> Dynamic
32+toDyn x = Dynamic (typeOf x) (GHC.unsafeCoerce# x)
33+
34+fromDyn :: Typeable a => Dynamic -> a -> a
35+fromDyn (Dynamic rep val) a =
36+ if rep == typeOf a
37+ then GHC.unsafeCoerce# val
38+ else a
39+
40+fromDynamic :: forall a. Typeable a => Dynamic -> Maybe a
41+fromDynamic (Dynamic rep val) =
42+ if rep == typeOf (undefined :: a)
43+ then Just (GHC.unsafeCoerce# val)
44+ else Nothing
45+
46+dynTypeRep :: Dynamic -> TypeRep
47+dynTypeRep (Dynamic t _) = t
48+
49+instance Show Dynamic where
50+ show = show . dynTypeRep
51+
52+tyConIO :: TyCon
53+tyConIO = typeRepTyCon (typeOf (undefined :: IO ()))
54+
55+bindIO :: IO a -> (a -> IO b) -> IO b
56+bindIO = (>>=)
57+
58+dynBindIO :: Dynamic -> Dynamic -> Maybe Dynamic
59+-- IO a -> (a -> IO b) -> IO b
60+dynBindIO (Dynamic t1 x) (Dynamic t2 f) =
61+ case splitTyConApp t1 of
62+ (io, [a]) | io == tyConIO ->
63+ case funResultTy t2 a of
64+ Just ioB -> Just (Dynamic ioB (GHC.unsafeCoerce# bindIO x f))
65+ _ -> Nothing
66+ _ -> Nothing
67+
68+dynBindIO' :: Dynamic -> Dynamic -> Dynamic
69+dynBindIO' x f = fromMaybe (error typeError) (dynBindIO x f)
70+ where
71+ typeError = "Type error in dynamic bind.\n"
72+ ++ "Can't bind " ++ show x ++ " to " ++ show f
distributed-process/src/Control/Distributed/Process/Internal/Types.hs+1−1
@@ -64,7 +64,6 @@ import Data.Map (Map)
64import qualified Data.Map as Map (empty)
64import qualified Data.Map as Map (empty)
65import Data.Int (Int32)
65import Data.Int (Int32)
66import Data.Typeable (Typeable)
66import Data.Typeable (Typeable)
67−import Data.Dynamic (Dynamic)
68import Data.Binary (Binary, encode, put, get, putWord8, getWord8)
67import Data.Binary (Binary, encode, put, get, putWord8, getWord8)
69import Data.ByteString.Lazy (ByteString)
68import Data.ByteString.Lazy (ByteString)
70import Data.Accessor (Accessor, accessor)
69import Data.Accessor (Accessor, accessor)
@@ -90,6 +89,7 @@ import Control.Distributed.Process.Serializable ( Fingerprint
90 , sizeOfFingerprint
89 , sizeOfFingerprint
91 )
90 )
92import Control.Distributed.Process.Internal.CQueue (CQueue)
91import Control.Distributed.Process.Internal.CQueue (CQueue)
92+import Control.Distributed.Process.Internal.Dynamic (Dynamic)
93
93
94--------------------------------------------------------------------------------
94--------------------------------------------------------------------------------
95-- Global state --
95-- Global state --
distributed-process/src/Control/Distributed/Process/Node.hs+1−1
@@ -20,7 +20,6 @@ import qualified Data.Set as Set (empty, insert, delete, member)
20import Data.Foldable (forM_)
20import Data.Foldable (forM_)
21import Data.Maybe (isJust)
21import Data.Maybe (isJust)
22import Data.Typeable (Typeable)
22import Data.Typeable (Typeable)
23−import Data.Dynamic (fromDynamic)
24import Control.Category ((>>>))
23import Control.Category ((>>>))
25import Control.Applicative ((<$>))
24import Control.Applicative ((<$>))
26import Control.Monad (void, when, forever)
25import Control.Monad (void, when, forever)
@@ -99,6 +98,7 @@ import Control.Distributed.Process.Internal.MessageT
99 , sendMessage
98 , sendMessage
100 , getLocalNode
99 , getLocalNode
101 )
100 )
101+import Control.Distributed.Process.Internal.Dynamic (fromDynamic)
102
102
103--------------------------------------------------------------------------------
103--------------------------------------------------------------------------------
104-- Initialization --
104-- Initialization --