git.iko.soy/distributed-process
on master help sign in
Fix the TH code to use ANY and co
commitc25b5a34aa6e4a1ce1a4b5804515cf8f02b50a9f authorEdsko de Vries <edsko@edsko.net> dateFri 10 Aug 2012, 16:44 (14 years ago) parent4e9442b
3 files changed+57−9
compare with master
unifiedsplit
distributed-process/distributed-process.cabal+4−2 distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs+42−6 distributed-process/tests/TestClosure.hs+11−1
distributed-process/distributed-process.cabal+4−2
@@ -45,7 +45,8 @@ Library
4545 random >= 1.0 && < 1.1,
4646 ghc-prim >= 0.2 && < 0.3,
4747 distributed-static >= 0.1 && < 0.2,
48− rank1dynamic >= 0.1 && < 0.2
48+ rank1dynamic >= 0.1 && < 0.2,
49+ syb >= 0.3 && < 0.4
4950 Exposed-modules: Control.Distributed.Process,
5051 Control.Distributed.Process.Serializable,
5152 Control.Distributed.Process.Closure,
@@ -121,7 +122,8 @@ Test-Suite TestClosure
121122 ghc-prim >= 0.2 && < 0.3,
122123 ansi-terminal >= 0.5 && < 0.6,
123124 distributed-static >= 0.1 && < 0.2,
124− rank1dynamic >= 0.1 && < 0.2
125+ rank1dynamic >= 0.1 && < 0.2,
126+ syb >= 0.3 && < 0.4
125127 Other-modules: TestAuxiliary
126128 Extensions: RankNTypes,
127129 ScopedTypeVariables,
distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs+42−6
@@ -9,7 +9,7 @@ module Control.Distributed.Process.Internal.Closure.TH
99 , mkClosure
1010 ) where
1111
12−import Prelude hiding (lookup)
12+import Prelude hiding (succ, any)
1313import Control.Applicative ((<$>))
1414import Language.Haskell.TH
1515 ( -- Q monad and operations
@@ -39,9 +39,14 @@ import Language.Haskell.TH
3939 , funD
4040 , sigD
4141 )
42−
4342import Data.Binary (encode)
43+import Data.Generics (everywhereM, mkM, gmapM)
4444import Data.Rank1Dynamic (toDynamic)
45+import Data.Rank1Typeable
46+ ( Zero
47+ , Succ
48+ , TypVar
49+ )
4550import Control.Distributed.Static
4651 ( RemoteTable
4752 , registerStatic
@@ -147,7 +152,7 @@ generateDefs n = do
147152 static <- generateStatic origName typVars typ
148153 let dyn = case typVars of
149154 [] -> [| toDynamic $(varE origName) |]
150− _ -> [| toDynamic $(varE origName) |]
155+ _ -> [| toDynamic ($(varE origName) :: $(monomorphize typVars typ)) |]
151156 return ( static
152157 , [ [| registerStatic $(stringE (show origName)) $dyn |] ]
153158 )
@@ -159,7 +164,34 @@ generateDefs n = do
159164 return ( sdict
160165 , [ [| registerStatic $(stringE (show dictName)) $dyn |] ]
161166 )
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+
163195-- | Generate a static value
164196generateStatic :: Name -> [TyVarBndr] -> Type -> Q [Dec]
165197generateStatic n xs typ = do
@@ -174,8 +206,7 @@ generateStatic n xs typ = do
174206 ]
175207 where
176208 typeable :: TyVarBndr -> Pred
177− typeable (PlainTV v) = ClassP (mkName "Typeable") [VarT v]
178− typeable (KindedTV v _) = ClassP (mkName "Typeable") [VarT v]
209+ typeable tv = ClassP (mkName "Typeable") [VarT (tyVarBndrName tv)]
179210
180211-- | Generate a serialization dictionary with name 'n' for type 'typ'
181212generateDict :: Name -> Type -> Q [Dec]
@@ -219,3 +250,8 @@ getType name = do
219250-- | Variation on 'funD' which takes a single expression to define the function
220251sfnD :: Name -> Q Exp -> Q Dec
221252sfnD 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 @@
11module Main where
22
33import Data.ByteString.Lazy (empty)
4−import Data.Typeable (Typeable, typeOf)
4+import Data.Typeable (Typeable)
55import Control.Monad (join, replicateM, forever)
66import Control.Exception (IOException, throw)
77import Control.Concurrent (forkIO, threadDelay)
@@ -15,6 +15,9 @@ import Control.Distributed.Process.Node
1515import Control.Distributed.Static (staticLabel, staticClosure)
1616import TestAuxiliary
1717
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+
1821sdictInt :: SerializableDict Int
1922sdictInt = SerializableDict
2023
@@ -41,6 +44,7 @@ isPrime n = return . (n `elem`) . takeWhile (<= n) . sieve $ [2..]
4144 where
4245 sieve :: [Integer] -> [Integer]
4346 sieve (p : xs) = p : sieve [x | x <- xs, x `mod` p > 0]
47+ sieve [] = error "Uh oh -- we've run out of primes"
4448
4549-- | First argument indicates empty closure environment
4650typedPingServer :: () -> ReceivePort (SendPort ()) -> Process ()
@@ -56,8 +60,14 @@ remotable [ 'factorial
5660 , 'wait
5761 , 'typedPingServer
5862 , 'isPrime
63+ , 'quintuple
5964 ]
6065
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+
6171factorialClosure :: Int -> Closure (Process Int)
6272factorialClosure = $(mkClosure 'factorial)
6373