[project @ 2004-11-18 00:56:24 by igloo]
[ghc.git] / libraries / template-haskell / Language / Haskell / TH / Lib.hs
1 -- TH.Lib contains lots of useful helper functions for
2 -- generating and manipulating Template Haskell terms
3
4 module Language.Haskell.TH.Lib where
5 -- All of the exports from this module should
6 -- be "public" functions. The main module TH
7 -- re-exports them all.
8
9 import Language.Haskell.TH.Syntax
10 import Control.Monad( liftM, liftM2 )
11
12 ----------------------------------------------------------
13 -- Type synonyms
14 ----------------------------------------------------------
15
16 type InfoQ = Q Info
17 type PatQ = Q Pat
18 type FieldPatQ = Q FieldPat
19 type ExpQ = Q Exp
20 type DecQ = Q Dec
21 type ConQ = Q Con
22 type TypeQ = Q Type
23 type CxtQ = Q Cxt
24 type MatchQ = Q Match
25 type ClauseQ = Q Clause
26 type BodyQ = Q Body
27 type GuardQ = Q Guard
28 type StmtQ = Q Stmt
29 type RangeQ = Q Range
30 type StrictTypeQ = Q StrictType
31 type VarStrictTypeQ = Q VarStrictType
32 type FieldExpQ = Q FieldExp
33
34 ----------------------------------------------------------
35 -- Lowercase pattern syntax functions
36 ----------------------------------------------------------
37
38 intPrimL :: Integer -> Lit
39 intPrimL = IntPrimL
40 floatPrimL :: Rational -> Lit
41 floatPrimL = FloatPrimL
42 doublePrimL :: Rational -> Lit
43 doublePrimL = DoublePrimL
44 integerL :: Integer -> Lit
45 integerL = IntegerL
46 charL :: Char -> Lit
47 charL = CharL
48 stringL :: String -> Lit
49 stringL = StringL
50 rationalL :: Rational -> Lit
51 rationalL = RationalL
52
53 litP :: Lit -> PatQ
54 litP l = return (LitP l)
55 varP :: Name -> PatQ
56 varP v = return (VarP v)
57 tupP :: [PatQ] -> PatQ
58 tupP ps = do { ps1 <- sequence ps; return (TupP ps1)}
59 conP :: Name -> [PatQ] -> PatQ
60 conP n ps = do ps' <- sequence ps
61 return (ConP n ps')
62 infixP :: PatQ -> Name -> PatQ -> PatQ
63 infixP p1 n p2 = do p1' <- p1
64 p2' <- p2
65 return (InfixP p1' n p2')
66 tildeP :: PatQ -> PatQ
67 tildeP p = do p' <- p
68 return (TildeP p')
69 asP :: Name -> PatQ -> PatQ
70 asP n p = do p' <- p
71 return (AsP n p')
72 wildP :: PatQ
73 wildP = return WildP
74 recP :: Name -> [FieldPatQ] -> PatQ
75 recP n fps = do fps' <- sequence fps
76 return (RecP n fps')
77 listP :: [PatQ] -> PatQ
78 listP ps = do ps' <- sequence ps
79 return (ListP ps')
80 sigP :: PatQ -> TypeQ -> PatQ
81 sigP p t = do p' <- p
82 t' <- t
83 return (SigP p' t')
84
85 fieldPat :: Name -> PatQ -> FieldPatQ
86 fieldPat n p = do p' <- p
87 return (n, p')
88
89
90 -------------------------------------------------------------------------------
91 -- Stmt
92
93 bindS :: PatQ -> ExpQ -> StmtQ
94 bindS p e = liftM2 BindS p e
95
96 letS :: [DecQ] -> StmtQ
97 letS ds = do { ds1 <- sequence ds; return (LetS ds1) }
98
99 noBindS :: ExpQ -> StmtQ
100 noBindS e = do { e1 <- e; return (NoBindS e1) }
101
102 parS :: [[StmtQ]] -> StmtQ
103 parS _ = fail "No parallel comprehensions yet"
104
105 -------------------------------------------------------------------------------
106 -- Range
107
108 fromR :: ExpQ -> RangeQ
109 fromR x = do { a <- x; return (FromR a) }
110
111 fromThenR :: ExpQ -> ExpQ -> RangeQ
112 fromThenR x y = do { a <- x; b <- y; return (FromThenR a b) }
113
114 fromToR :: ExpQ -> ExpQ -> RangeQ
115 fromToR x y = do { a <- x; b <- y; return (FromToR a b) }
116
117 fromThenToR :: ExpQ -> ExpQ -> ExpQ -> RangeQ
118 fromThenToR x y z = do { a <- x; b <- y; c <- z;
119 return (FromThenToR a b c) }
120 -------------------------------------------------------------------------------
121 -- Body
122
123 normalB :: ExpQ -> BodyQ
124 normalB e = do { e1 <- e; return (NormalB e1) }
125
126 guardedB :: [Q (Guard,Exp)] -> BodyQ
127 guardedB ges = do { ges' <- sequence ges; return (GuardedB ges') }
128
129 -------------------------------------------------------------------------------
130 -- Guard
131
132 normalG :: ExpQ -> GuardQ
133 normalG e = do { e1 <- e; return (NormalG e1) }
134
135 normalGE :: ExpQ -> ExpQ -> Q (Guard, Exp)
136 normalGE g e = do { g1 <- g; e1 <- e; return (NormalG g1, e1) }
137
138 patG :: [StmtQ] -> GuardQ
139 patG ss = do { ss' <- sequence ss; return (PatG ss') }
140
141 patGE :: [StmtQ] -> Q (Guard, Exp)
142 patGE ss = do { ss' <- sequence ss;
143 let {NoBindS e = last ss'};
144 return (PatG (init ss'), e) }
145
146 -------------------------------------------------------------------------------
147 -- Match and Clause
148
149 match :: PatQ -> BodyQ -> [DecQ] -> MatchQ
150 match p rhs ds = do { p' <- p;
151 r' <- rhs;
152 ds' <- sequence ds;
153 return (Match p' r' ds') }
154
155 clause :: [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
156 clause ps r ds = do { ps' <- sequence ps;
157 r' <- r;
158 ds' <- sequence ds;
159 return (Clause ps' r' ds') }
160
161
162 ---------------------------------------------------------------------------
163 -- Exp
164
165 dyn :: String -> Q Exp
166 dyn s = return (VarE (mkName s))
167
168 global :: Name -> ExpQ
169 global s = return (VarE s)
170
171 varE :: Name -> ExpQ
172 varE s = return (VarE s)
173
174 conE :: Name -> ExpQ
175 conE s = return (ConE s)
176
177 litE :: Lit -> ExpQ
178 litE c = return (LitE c)
179
180 appE :: ExpQ -> ExpQ -> ExpQ
181 appE x y = do { a <- x; b <- y; return (AppE a b)}
182
183 infixE :: Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
184 infixE (Just x) s (Just y) = do { a <- x; s' <- s; b <- y;
185 return (InfixE (Just a) s' (Just b))}
186 infixE Nothing s (Just y) = do { s' <- s; b <- y;
187 return (InfixE Nothing s' (Just b))}
188 infixE (Just x) s Nothing = do { a <- x; s' <- s;
189 return (InfixE (Just a) s' Nothing)}
190 infixE Nothing s Nothing = do { s' <- s; return (InfixE Nothing s' Nothing) }
191
192 infixApp :: ExpQ -> ExpQ -> ExpQ -> ExpQ
193 infixApp x y z = infixE (Just x) y (Just z)
194 sectionL :: ExpQ -> ExpQ -> ExpQ
195 sectionL x y = infixE (Just x) y Nothing
196 sectionR :: ExpQ -> ExpQ -> ExpQ
197 sectionR x y = infixE Nothing x (Just y)
198
199 lamE :: [PatQ] -> ExpQ -> ExpQ
200 lamE ps e = do ps' <- sequence ps
201 e' <- e
202 return (LamE ps' e')
203
204 lam1E :: PatQ -> ExpQ -> ExpQ -- Single-arg lambda
205 lam1E p e = lamE [p] e
206
207 tupE :: [ExpQ] -> ExpQ
208 tupE es = do { es1 <- sequence es; return (TupE es1)}
209
210 condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
211 condE x y z = do { a <- x; b <- y; c <- z; return (CondE a b c)}
212
213 letE :: [DecQ] -> ExpQ -> ExpQ
214 letE ds e = do { ds2 <- sequence ds; e2 <- e; return (LetE ds2 e2) }
215
216 caseE :: ExpQ -> [MatchQ] -> ExpQ
217 caseE e ms = do { e1 <- e; ms1 <- sequence ms; return (CaseE e1 ms1) }
218
219 doE :: [StmtQ] -> ExpQ
220 doE ss = do { ss1 <- sequence ss; return (DoE ss1) }
221
222 compE :: [StmtQ] -> ExpQ
223 compE ss = do { ss1 <- sequence ss; return (CompE ss1) }
224
225 arithSeqE :: RangeQ -> ExpQ
226 arithSeqE r = do { r' <- r; return (ArithSeqE r') }
227
228 -- arithSeqE Shortcuts
229 fromE :: ExpQ -> ExpQ
230 fromE x = do { a <- x; return (ArithSeqE (FromR a)) }
231
232 fromThenE :: ExpQ -> ExpQ -> ExpQ
233 fromThenE x y = do { a <- x; b <- y; return (ArithSeqE (FromThenR a b)) }
234
235 fromToE :: ExpQ -> ExpQ -> ExpQ
236 fromToE x y = do { a <- x; b <- y; return (ArithSeqE (FromToR a b)) }
237
238 fromThenToE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
239 fromThenToE x y z = do { a <- x; b <- y; c <- z;
240 return (ArithSeqE (FromThenToR a b c)) }
241 -- End arithSeqE shortcuts
242
243 listE :: [ExpQ] -> ExpQ
244 listE es = do { es1 <- sequence es; return (ListE es1) }
245
246 sigE :: ExpQ -> TypeQ -> ExpQ
247 sigE e t = do { e1 <- e; t1 <- t; return (SigE e1 t1) }
248
249 recConE :: Name -> [Q (Name,Exp)] -> ExpQ
250 recConE c fs = do { flds <- sequence fs; return (RecConE c flds) }
251
252 recUpdE :: ExpQ -> [Q (Name,Exp)] -> ExpQ
253 recUpdE e fs = do { e1 <- e; flds <- sequence fs; return (RecUpdE e1 flds) }
254
255 stringE :: String -> ExpQ
256 stringE = litE . stringL
257
258 fieldExp :: Name -> ExpQ -> Q (Name, Exp)
259 fieldExp s e = do { e' <- e; return (s,e') }
260
261 -------------------------------------------------------------------------------
262 -- Dec
263
264 valD :: PatQ -> BodyQ -> [DecQ] -> DecQ
265 valD p b ds =
266 do { p' <- p
267 ; ds' <- sequence ds
268 ; b' <- b
269 ; return (ValD p' b' ds')
270 }
271
272 funD :: Name -> [ClauseQ] -> DecQ
273 funD nm cs =
274 do { cs1 <- sequence cs
275 ; return (FunD nm cs1)
276 }
277
278 tySynD :: Name -> [Name] -> TypeQ -> DecQ
279 tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) }
280
281 dataD :: CxtQ -> Name -> [Name] -> [ConQ] -> [Name] -> DecQ
282 dataD ctxt tc tvs cons derivs =
283 do
284 ctxt1 <- ctxt
285 cons1 <- sequence cons
286 return (DataD ctxt1 tc tvs cons1 derivs)
287
288 newtypeD :: CxtQ -> Name -> [Name] -> ConQ -> [Name] -> DecQ
289 newtypeD ctxt tc tvs con derivs =
290 do
291 ctxt1 <- ctxt
292 con1 <- con
293 return (NewtypeD ctxt1 tc tvs con1 derivs)
294
295 classD :: CxtQ -> Name -> [Name] -> [FunDep] -> [DecQ] -> DecQ
296 classD ctxt cls tvs fds decs =
297 do
298 decs1 <- sequence decs
299 ctxt1 <- ctxt
300 return $ ClassD ctxt1 cls tvs fds decs1
301
302 instanceD :: CxtQ -> TypeQ -> [DecQ] -> DecQ
303 instanceD ctxt ty decs =
304 do
305 ctxt1 <- ctxt
306 decs1 <- sequence decs
307 ty1 <- ty
308 return $ InstanceD ctxt1 ty1 decs1
309
310 sigD :: Name -> TypeQ -> DecQ
311 sigD fun ty = liftM (SigD fun) $ ty
312
313 forImpD :: Callconv -> Safety -> String -> Name -> TypeQ -> DecQ
314 forImpD cc s str n ty
315 = do ty' <- ty
316 return $ ForeignD (ImportF cc s str n ty')
317
318 cxt :: [TypeQ] -> CxtQ
319 cxt = sequence
320
321 normalC :: Name -> [StrictTypeQ] -> ConQ
322 normalC con strtys = liftM (NormalC con) $ sequence strtys
323
324 recC :: Name -> [VarStrictTypeQ] -> ConQ
325 recC con varstrtys = liftM (RecC con) $ sequence varstrtys
326
327 infixC :: Q (Strict, Type) -> Name -> Q (Strict, Type) -> ConQ
328 infixC st1 con st2 = do st1' <- st1
329 st2' <- st2
330 return $ InfixC st1' con st2'
331
332 forallC :: [Name] -> CxtQ -> ConQ -> ConQ
333 forallC ns ctxt con = liftM2 (ForallC ns) ctxt con
334
335
336 -------------------------------------------------------------------------------
337 -- Type
338
339 forallT :: [Name] -> CxtQ -> TypeQ -> TypeQ
340 forallT tvars ctxt ty = do
341 ctxt1 <- ctxt
342 ty1 <- ty
343 return $ ForallT tvars ctxt1 ty1
344
345 varT :: Name -> TypeQ
346 varT = return . VarT
347
348 conT :: Name -> TypeQ
349 conT = return . ConT
350
351 appT :: TypeQ -> TypeQ -> TypeQ
352 appT t1 t2 = do
353 t1' <- t1
354 t2' <- t2
355 return $ AppT t1' t2'
356
357 arrowT :: TypeQ
358 arrowT = return ArrowT
359
360 listT :: TypeQ
361 listT = return ListT
362
363 tupleT :: Int -> TypeQ
364 tupleT i = return (TupleT i)
365
366 isStrict, notStrict :: Q Strict
367 isStrict = return $ IsStrict
368 notStrict = return $ NotStrict
369
370 strictType :: Q Strict -> TypeQ -> StrictTypeQ
371 strictType = liftM2 (,)
372
373 varStrictType :: Name -> StrictTypeQ -> VarStrictTypeQ
374 varStrictType v st = do (s, t) <- st
375 return (v, s, t)
376
377 -------------------------------------------------------------------------------
378 -- Callconv
379
380 cCall, stdCall :: Callconv
381 cCall = CCall
382 stdCall = StdCall
383
384 -------------------------------------------------------------------------------
385 -- Safety
386
387 unsafe, safe, threadsafe :: Safety
388 unsafe = Unsafe
389 safe = Safe
390 threadsafe = Threadsafe
391
392 -------------------------------------------------------------------------------
393 -- FunDep
394
395 funDep :: [Name] -> [Name] -> FunDep
396 funDep = FunDep
397
398 --------------------------------------------------------------
399 -- Useful helper functions
400
401 combine :: [([(Name, Name)], Pat)] -> ([(Name, Name)], [Pat])
402 combine pairs = foldr f ([],[]) pairs
403 where f (env,p) (es,ps) = (env++es,p:ps)
404
405 rename :: Pat -> Q ([(Name, Name)], Pat)
406 rename (LitP c) = return([],LitP c)
407 rename (VarP s) = do { s1 <- newName (nameBase s); return([(s,s1)],VarP s1) }
408 rename (TupP pats) = do { pairs <- mapM rename pats; g(combine pairs) }
409 where g (es,ps) = return (es,TupP ps)
410 rename (ConP nm pats) = do { pairs <- mapM rename pats; g(combine pairs) }
411 where g (es,ps) = return (es,ConP nm ps)
412 rename (InfixP p1 n p2) = do { r1 <- rename p1;
413 r2 <- rename p2;
414 let {(env, [p1', p2']) = combine [r1, r2]};
415 return (env, InfixP p1' n p2') }
416 rename (TildeP p) = do { (env,p2) <- rename p; return(env,TildeP p2) }
417 rename (AsP s p) =
418 do { s1 <- newName (nameBase s); (env,p2) <- rename p; return((s,s1):env,AsP s1 p2) }
419 rename WildP = return([],WildP)
420 rename (RecP nm fs) = do { pairs <- mapM rename ps; g(combine pairs) }
421 where g (env,ps') = return (env,RecP nm (zip ss ps'))
422 (ss,ps) = unzip fs
423 rename (ListP pats) = do { pairs <- mapM rename pats; g(combine pairs) }
424 where g (es,ps) = return (es,ListP ps)
425
426 genpat :: Pat -> Q ((Name -> ExpQ), Pat)
427 genpat p = do { (env,p2) <- rename p; return (alpha env,p2) }
428
429 alpha :: [(Name, Name)] -> Name -> ExpQ
430 alpha env s = case lookup s env of
431 Just x -> varE x
432 Nothing -> varE s
433
434 appsE :: [ExpQ] -> ExpQ
435 appsE [] = error "appsExp []"
436 appsE [x] = x
437 appsE (x:y:zs) = appsE ( (appE x y) : zs )
438
439 simpleMatch :: Pat -> Exp -> Match
440 simpleMatch p e = Match p (NormalB e) []
441