git.iko.soy/distributed-process
on master help sign in
Fix the TH code to use ANY and co
c25b5a3Edsko de Vries
distributed-process/distributed-process.cabal+4−2
compare with master
unifiedsplit
@@ -45,7 +45,8 @@ Library
45 random >= 1.0 && < 1.1,
45 random >= 1.0 && < 1.1,
46 ghc-prim >= 0.2 && < 0.3,
46 ghc-prim >= 0.2 && < 0.3,
47 distributed-static >= 0.1 && < 0.2,
47 distributed-static >= 0.1 && < 0.2,
48− rank1dynamic >= 0.1 && < 0.2
48+ rank1dynamic >= 0.1 && < 0.2,
49+ syb >= 0.3 && < 0.4
49 Exposed-modules: Control.Distributed.Process,
50 Exposed-modules: Control.Distributed.Process,
50 Control.Distributed.Process.Serializable,
51 Control.Distributed.Process.Serializable,
51 Control.Distributed.Process.Closure,
52 Control.Distributed.Process.Closure,
@@ -121,7 +122,8 @@ Test-Suite TestClosure
121 ghc-prim >= 0.2 && < 0.3,
122 ghc-prim >= 0.2 && < 0.3,
122 ansi-terminal >= 0.5 && < 0.6,
123 ansi-terminal >= 0.5 && < 0.6,
123 distributed-static >= 0.1 && < 0.2,
124 distributed-static >= 0.1 && < 0.2,
124− rank1dynamic >= 0.1 && < 0.2
125+ rank1dynamic >= 0.1 && < 0.2,
126+ syb >= 0.3 && < 0.4
125 Other-modules: TestAuxiliary
127 Other-modules: TestAuxiliary
126 Extensions: RankNTypes,
128 Extensions: RankNTypes,
127 ScopedTypeVariables,
129 ScopedTypeVariables,
distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs+42−6
@@ -9,7 +9,7 @@ module Control.Distributed.Process.Internal.Closure.TH
9 , mkClosure
9 , mkClosure
10 ) where
10 ) where
11
11
12−import Prelude hiding (lookup)
12+import Prelude hiding (succ, any)
13import Control.Applicative ((<$>))
13import Control.Applicative ((<$>))
14import Language.Haskell.TH
14import Language.Haskell.TH
15 ( -- Q monad and operations
15 ( -- Q monad and operations
@@ -39,9 +39,14 @@ import Language.Haskell.TH
39 , funD
39 , funD
40 , sigD
40 , sigD
41 )
41 )
42−
43import Data.Binary (encode)
42import Data.Binary (encode)
43+import Data.Generics (everywhereM, mkM, gmapM)
44import Data.Rank1Dynamic (toDynamic)
44import Data.Rank1Dynamic (toDynamic)
45+import Data.Rank1Typeable
46+ ( Zero
47+ , Succ
48+ , TypVar
49+ )
45import Control.Distributed.Static
50import Control.Distributed.Static
46 ( RemoteTable
51 ( RemoteTable
47 , registerStatic
52 , registerStatic
@@ -147,7 +152,7 @@ generateDefs n = do
147 static <- generateStatic origName typVars typ
152 static <- generateStatic origName typVars typ
148 let dyn = case typVars of
153 let dyn = case typVars of
149 [] -> [| toDynamic $(varE origName) |]
154 [] -> [| toDynamic $(varE origName) |]
150− _ -> [| toDynamic $(varE origName) |]
155+ _ -> [| toDynamic ($(varE origName) :: $(monomorphize typVars typ)) |]
151 return ( static
156 return ( static
152 , [ [| registerStatic $(stringE (show origName)) $dyn |] ]
157 , [ [| registerStatic $(stringE (show origName)) $dyn |] ]
153 )
158 )
@@ -159,7 +164,34 @@ generateDefs n = do
159 return ( sdict
164 return ( sdict
160 , [ [| registerStatic $(stringE (show dictName)) $dyn |] ]
165 , [ [| registerStatic $(stringE (show dictName)) $dyn |] ]
161 )
166 )
162−
167+
168+-- | Turn a polymorphic type into a monomorphic type using ANY and co
169+monomorphize :: [TyVarBndr] -> Type -> Q Type
170+monomorphize tvs =
171+ let subst = zip (map tyVarBndrName tvs) anys
172+ in everywhereM (mkM (applySubst subst))
173+ where
174+ anys :: [Q Type]
175+ anys = map typVar (iterate succ zero)
176+
177+ typVar :: Q Type -> Q Type
178+ typVar t = [t| TypVar $t |]
179+
180+ zero :: Q Type
181+ zero = [t| Zero |]
182+
183+ succ :: Q Type -> Q Type
184+ succ t = [t| Succ $t |]
185+
186+ applySubst :: [(Name, Q Type)] -> Type -> Q Type
187+ applySubst s (VarT n) =
188+ case lookup n s of
189+ Nothing -> return (VarT n)
190+ Just t -> t
191+ applySubst s t = gmapM (mkM (applySubst s)) t
192+
193+
194+
163-- | Generate a static value
195-- | Generate a static value
164generateStatic :: Name -> [TyVarBndr] -> Type -> Q [Dec]
196generateStatic :: Name -> [TyVarBndr] -> Type -> Q [Dec]
165generateStatic n xs typ = do
197generateStatic n xs typ = do
@@ -174,8 +206,7 @@ generateStatic n xs typ = do
174 ]
206 ]
175 where
207 where
176 typeable :: TyVarBndr -> Pred
208 typeable :: TyVarBndr -> Pred
177− typeable (PlainTV v) = ClassP (mkName "Typeable") [VarT v]
209+ typeable tv = ClassP (mkName "Typeable") [VarT (tyVarBndrName tv)]
178− typeable (KindedTV v _) = ClassP (mkName "Typeable") [VarT v]
179
210
180-- | Generate a serialization dictionary with name 'n' for type 'typ'
211-- | Generate a serialization dictionary with name 'n' for type 'typ'
181generateDict :: Name -> Type -> Q [Dec]
212generateDict :: Name -> Type -> Q [Dec]
@@ -219,3 +250,8 @@ getType name = do
219-- | Variation on 'funD' which takes a single expression to define the function
250-- | Variation on 'funD' which takes a single expression to define the function
220sfnD :: Name -> Q Exp -> Q Dec
251sfnD :: Name -> Q Exp -> Q Dec
221sfnD n e = funD n [clause [] (normalB e) []]
252sfnD n e = funD n [clause [] (normalB e) []]
253+
254+-- | The name of a type variable binding occurrence
255+tyVarBndrName :: TyVarBndr -> Name
256+tyVarBndrName (PlainTV n) = n
257+tyVarBndrName (KindedTV n _) = n
distributed-process/tests/TestClosure.hs+11−1
@@ -1,7 +1,7 @@
1module Main where
1module Main where
2
2
3import Data.ByteString.Lazy (empty)
3import Data.ByteString.Lazy (empty)
4−import Data.Typeable (Typeable, typeOf)
4+import Data.Typeable (Typeable)
5import Control.Monad (join, replicateM, forever)
5import Control.Monad (join, replicateM, forever)
6import Control.Exception (IOException, throw)
6import Control.Exception (IOException, throw)
7import Control.Concurrent (forkIO, threadDelay)
7import Control.Concurrent (forkIO, threadDelay)
@@ -15,6 +15,9 @@ import Control.Distributed.Process.Node
15import Control.Distributed.Static (staticLabel, staticClosure)
15import Control.Distributed.Static (staticLabel, staticClosure)
16import TestAuxiliary
16import TestAuxiliary
17
17
18+quintuple :: a -> b -> c -> d -> e -> (a, b, c, d, e)
19+quintuple a b c d e = (a, b, c, d, e)
20+
18sdictInt :: SerializableDict Int
21sdictInt :: SerializableDict Int
19sdictInt = SerializableDict
22sdictInt = SerializableDict
20
23
@@ -41,6 +44,7 @@ isPrime n = return . (n `elem`) . takeWhile (<= n) . sieve $ [2..]
41 where
44 where
42 sieve :: [Integer] -> [Integer]
45 sieve :: [Integer] -> [Integer]
43 sieve (p : xs) = p : sieve [x | x <- xs, x `mod` p > 0]
46 sieve (p : xs) = p : sieve [x | x <- xs, x `mod` p > 0]
47+ sieve [] = error "Uh oh -- we've run out of primes"
44
48
45-- | First argument indicates empty closure environment
49-- | First argument indicates empty closure environment
46typedPingServer :: () -> ReceivePort (SendPort ()) -> Process ()
50typedPingServer :: () -> ReceivePort (SendPort ()) -> Process ()
@@ -56,8 +60,14 @@ remotable [ 'factorial
56 , 'wait
60 , 'wait
57 , 'typedPingServer
61 , 'typedPingServer
58 , 'isPrime
62 , 'isPrime
63+ , 'quintuple
59 ]
64 ]
60
65
66+-- Just try creating a static polymorphic value
67+staticQuintuple :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e)
68+ => Static (a -> b -> c -> d -> e -> (a, b, c, d, e))
69+staticQuintuple = $(mkStatic 'quintuple)
70+
61factorialClosure :: Int -> Closure (Process Int)
71factorialClosure :: Int -> Closure (Process Int)
62factorialClosure = $(mkClosure 'factorial)
72factorialClosure = $(mkClosure 'factorial)
63
73