git.iko.soy/distributed-process
on master help sign in
Workaround bug in Typeable only for base < 4.6
commit565b128faacdcc81da8014a14b16e6ef0552588f authorEdsko de Vries <edsko@edsko.net> dateMon 16 Jul 2012, 15:14 (14 years ago) parent867f51b
2 files changed+16−10
compare with master
unifiedsplit
distributed-process/src/Control/Distributed/Process/Internal/Closure/CP.hs+2−8 distributed-process/src/Control/Distributed/Process/Internal/TypeRep.hs+14−2
distributed-process/src/Control/Distributed/Process/Internal/Closure/CP.hs+2−8
@@ -29,7 +29,6 @@ module Control.Distributed.Process.Internal.Closure.CP
2929import Data.Binary (encode)
3030import Data.ByteString.Lazy (ByteString)
3131import Data.Typeable (Typeable, typeOf, typeRepTyCon, TyCon)
32−import Data.Typeable.Internal (TypeRep(..))
3332import Control.Applicative ((<$>))
3433import Control.Monad ((>=>))
3534import Control.Distributed.Process.Serializable (Serializable)
@@ -77,6 +76,7 @@ import Control.Distributed.Process.Internal.Dynamic
7776 , dynTypeRep
7877 , dynKleisli
7978 )
79+import Control.Distributed.Process.Internal.TypeRep (compareTypeRep)
8080
8181--------------------------------------------------------------------------------
8282-- Setup: A number of functions that we will pass to 'remotable' --
@@ -123,18 +123,12 @@ unClosure (Static label) env = do
123123 Nothing -> fail "Derived.unClosure: resolveClosure failed"
124124 Just dyn -> return dyn
125125
126−-- | Work around a bug in Typeable
127−-- (http://hackage.haskell.org/trac/ghc/ticket/5692)
128−compareWithoutFingerprint :: TypeRep -> TypeRep -> Bool
129−compareWithoutFingerprint (TypeRep _ con ts) (TypeRep _ con' ts')
130− = con == con' && all (uncurry compareWithoutFingerprint) (zip ts ts')
131−
132126-- | Remove a 'Dynamic' constructor, provided that the recorded type matches the
133127-- type of the first static argument (the value of that argument is not used)
134128unDynamic :: Static a -> Process Dynamic -> Process a
135129unDynamic (Static label) pdyn = do
136130 Dynamic typ val <- pdyn
137− if compareWithoutFingerprint typ (typeOfStaticLabel label) -- typ == typeOfStaticLabel label
131+ if typ `compareTypeRep` typeOfStaticLabel label
138132 then return (unsafeCoerce# val)
139133 else fail $ "unDynamic: cannot match "
140134 ++ show typ
distributed-process/src/Control/Distributed/Process/Internal/TypeRep.hs+14−2
@@ -1,6 +1,6 @@
1−-- | 'Binary' instances for 'TypeRep'
1+-- | 'Binary' instances for 'TypeRep', and 'TypeRep' equality (bug workaround)
22{-# OPTIONS_GHC -fno-warn-orphans #-}
3−module Control.Distributed.Process.Internal.TypeRep () where
3+module Control.Distributed.Process.Internal.TypeRep (compareTypeRep) where
44
55import Control.Applicative ((<$>), (<*>))
66import Data.Binary (Binary(get, put))
@@ -19,3 +19,15 @@ instance Binary TyCon where
1919 put (TyCon hash package modul name) = put hash >> put package >> put modul >> put name
2020 get = TyCon <$> get <*> get <*> get <*> get
2121
22+-- | Compare two type representations
23+--
24+-- For base >= 4.6 this compares fingerprints, but older versions of base
25+-- have a bug in the fingerprint construction
26+-- (<http://hackage.haskell.org/trac/ghc/ticket/5692>)
27+compareTypeRep :: TypeRep -> TypeRep -> Bool
28+#if ! MIN_VERSION_base(4,6,0)
29+compareTypeRep (TypeRep _ con ts) (TypeRep _ con' ts')
30+ = con == con' && all (uncurry compareTypeRep) (zip ts ts')
31+#else
32+compareTypeRep = (==)
33+#endif