565b128 · distributed-process

git.iko.soy/distributed-process

on master help sign in

Workaround bug in Typeable only for base < 4.6

565b128Edsko de Vries14 years ago

distributed-process/src/Control/Distributed/Process/Internal/Closure/CP.hs+2−8

compare with master

unifiedsplit

@@ -29,7 +29,6 @@ module Control.Distributed.Process.Internal.Closure.CP

29import Data.Binary (encode)

30import Data.ByteString.Lazy (ByteString)

31import Data.Typeable (Typeable, typeOf, typeRepTyCon, TyCon)

32−import Data.Typeable.Internal (TypeRep(..))

33import Control.Applicative ((<$>))

32import Control.Applicative ((<$>))

34import Control.Monad ((>=>))

33import Control.Monad ((>=>))

35import Control.Distributed.Process.Serializable (Serializable)

34import Control.Distributed.Process.Serializable (Serializable)

@@ -77,6 +76,7 @@ import Control.Distributed.Process.Internal.Dynamic

77 , dynTypeRep

76 , dynTypeRep

78 , dynKleisli

77 , dynKleisli

79 )

78 )

79+import Control.Distributed.Process.Internal.TypeRep (compareTypeRep)

81--------------------------------------------------------------------------------

82-- Setup: A number of functions that we will pass to 'remotable' --

@@ -123,18 +123,12 @@ unClosure (Static label) env = do

123 Nothing -> fail "Derived.unClosure: resolveClosure failed"

124 Just dyn -> return dyn

125

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−

132-- | Remove a 'Dynamic' constructor, provided that the recorded type matches the

126-- | Remove a 'Dynamic' constructor, provided that the recorded type matches the

133-- type of the first static argument (the value of that argument is not used)

127-- type of the first static argument (the value of that argument is not used)

134unDynamic :: Static a -> Process Dynamic -> Process a

128unDynamic :: Static a -> Process Dynamic -> Process a

135unDynamic (Static label) pdyn = do

129unDynamic (Static label) pdyn = do

136 Dynamic typ val <- pdyn

130 Dynamic typ val <- pdyn

137− if compareWithoutFingerprint typ (typeOfStaticLabel label) -- typ == typeOfStaticLabel label

131+ if typ `compareTypeRep` typeOfStaticLabel label

138 then return (unsafeCoerce# val)

132 then return (unsafeCoerce# val)

139 else fail $ "unDynamic: cannot match "

133 else fail $ "unDynamic: cannot match "

140 ++ show typ

134 ++ 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)

2{-# OPTIONS_GHC -fno-warn-orphans #-}

3−module Control.Distributed.Process.Internal.TypeRep () where

3+module Control.Distributed.Process.Internal.TypeRep (compareTypeRep) where

5import Control.Applicative ((<$>), (<*>))

6import Data.Binary (Binary(get, put))

@@ -19,3 +19,15 @@ instance Binary TyCon where

19 put (TyCon hash package modul name) = put hash >> put package >> put modul >> put name

20 get = TyCon <$> get <*> get <*> get <*> get

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