@@ -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