7bc7ccb76b9f266137e8998a74cabb220ad9589b
[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 PredQ = Q Pred
25 type MatchQ = Q Match
26 type ClauseQ = Q Clause
27 type BodyQ = Q Body
28 type GuardQ = Q Guard
29 type StmtQ = Q Stmt
30 type RangeQ = Q Range
31 type StrictTypeQ = Q StrictType
32 type VarStrictTypeQ = Q VarStrictType
33 type FieldExpQ = Q FieldExp
34 type InlineSpecQ = Q InlineSpec
35
36 ----------------------------------------------------------
37 -- Lowercase pattern syntax functions
38 ----------------------------------------------------------
39
40 intPrimL :: Integer -> Lit
41 intPrimL = IntPrimL
42 wordPrimL :: Integer -> Lit
43 wordPrimL = WordPrimL
44 floatPrimL :: Rational -> Lit
45 floatPrimL = FloatPrimL
46 doublePrimL :: Rational -> Lit
47 doublePrimL = DoublePrimL
48 integerL :: Integer -> Lit
49 integerL = IntegerL
50 charL :: Char -> Lit
51 charL = CharL
52 stringL :: String -> Lit
53 stringL = StringL
54 rationalL :: Rational -> Lit
55 rationalL = RationalL
56
57 litP :: Lit -> PatQ
58 litP l = return (LitP l)
59 varP :: Name -> PatQ
60 varP v = return (VarP v)
61 tupP :: [PatQ] -> PatQ
62 tupP ps = do { ps1 <- sequence ps; return (TupP ps1)}
63 conP :: Name -> [PatQ] -> PatQ
64 conP n ps = do ps' <- sequence ps
65 return (ConP n ps')
66 infixP :: PatQ -> Name -> PatQ -> PatQ
67 infixP p1 n p2 = do p1' <- p1
68 p2' <- p2
69 return (InfixP p1' n p2')
70 tildeP :: PatQ -> PatQ
71 tildeP p = do p' <- p
72 return (TildeP p')
73 asP :: Name -> PatQ -> PatQ
74 asP n p = do p' <- p
75 return (AsP n p')
76 wildP :: PatQ
77 wildP = return WildP
78 recP :: Name -> [FieldPatQ] -> PatQ
79 recP n fps = do fps' <- sequence fps
80 return (RecP n fps')
81 listP :: [PatQ] -> PatQ
82 listP ps = do ps' <- sequence ps
83 return (ListP ps')
84 sigP :: PatQ -> TypeQ -> PatQ
85 sigP p t = do p' <- p
86 t' <- t
87 return (SigP p' t')
88
89 fieldPat :: Name -> PatQ -> FieldPatQ
90 fieldPat n p = do p' <- p
91 return (n, p')
92
93
94 -------------------------------------------------------------------------------
95 -- Stmt
96
97 bindS :: PatQ -> ExpQ -> StmtQ
98 bindS p e = liftM2 BindS p e
99
100 letS :: [DecQ] -> StmtQ
101 letS ds = do { ds1 <- sequence ds; return (LetS ds1) }
102
103 noBindS :: ExpQ -> StmtQ
104 noBindS e = do { e1 <- e; return (NoBindS e1) }
105
106 parS :: [[StmtQ]] -> StmtQ
107 parS _ = fail "No parallel comprehensions yet"
108
109 -------------------------------------------------------------------------------
110 -- Range
111
112 fromR :: ExpQ -> RangeQ
113 fromR x = do { a <- x; return (FromR a) }
114
115 fromThenR :: ExpQ -> ExpQ -> RangeQ
116 fromThenR x y = do { a <- x; b <- y; return (FromThenR a b) }
117
118 fromToR :: ExpQ -> ExpQ -> RangeQ
119 fromToR x y = do { a <- x; b <- y; return (FromToR a b) }
120
121 fromThenToR :: ExpQ -> ExpQ -> ExpQ -> RangeQ
122 fromThenToR x y z = do { a <- x; b <- y; c <- z;
123 return (FromThenToR a b c) }
124 -------------------------------------------------------------------------------
125 -- Body
126
127 normalB :: ExpQ -> BodyQ
128 normalB e = do { e1 <- e; return (NormalB e1) }
129
130 guardedB :: [Q (Guard,Exp)] -> BodyQ
131 guardedB ges = do { ges' <- sequence ges; return (GuardedB ges') }
132
133 -------------------------------------------------------------------------------
134 -- Guard
135
136 normalG :: ExpQ -> GuardQ
137 normalG e = do { e1 <- e; return (NormalG e1) }
138
139 normalGE :: ExpQ -> ExpQ -> Q (Guard, Exp)
140 normalGE g e = do { g1 <- g; e1 <- e; return (NormalG g1, e1) }
141
142 patG :: [StmtQ] -> GuardQ
143 patG ss = do { ss' <- sequence ss; return (PatG ss') }
144
145 patGE :: [StmtQ] -> ExpQ -> Q (Guard, Exp)
146 patGE ss e = do { ss' <- sequence ss;
147 e' <- e;
148 return (PatG ss', e') }
149
150 -------------------------------------------------------------------------------
151 -- Match and Clause
152
153 match :: PatQ -> BodyQ -> [DecQ] -> MatchQ
154 match p rhs ds = do { p' <- p;
155 r' <- rhs;
156 ds' <- sequence ds;
157 return (Match p' r' ds') }
158
159 clause :: [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
160 clause ps r ds = do { ps' <- sequence ps;
161 r' <- r;
162 ds' <- sequence ds;
163 return (Clause ps' r' ds') }
164
165
166 ---------------------------------------------------------------------------
167 -- Exp
168
169 dyn :: String -> Q Exp
170 dyn s = return (VarE (mkName s))
171
172 global :: Name -> ExpQ
173 global s = return (VarE s)
174
175 varE :: Name -> ExpQ
176 varE s = return (VarE s)
177
178 conE :: Name -> ExpQ
179 conE s = return (ConE s)
180
181 litE :: Lit -> ExpQ
182 litE c = return (LitE c)
183
184 appE :: ExpQ -> ExpQ -> ExpQ
185 appE x y = do { a <- x; b <- y; return (AppE a b)}
186
187 infixE :: Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
188 infixE (Just x) s (Just y) = do { a <- x; s' <- s; b <- y;
189 return (InfixE (Just a) s' (Just b))}
190 infixE Nothing s (Just y) = do { s' <- s; b <- y;
191 return (InfixE Nothing s' (Just b))}
192 infixE (Just x) s Nothing = do { a <- x; s' <- s;
193 return (InfixE (Just a) s' Nothing)}
194 infixE Nothing s Nothing = do { s' <- s; return (InfixE Nothing s' Nothing) }
195
196 infixApp :: ExpQ -> ExpQ -> ExpQ -> ExpQ
197 infixApp x y z = infixE (Just x) y (Just z)
198 sectionL :: ExpQ -> ExpQ -> ExpQ
199 sectionL x y = infixE (Just x) y Nothing
200 sectionR :: ExpQ -> ExpQ -> ExpQ
201 sectionR x y = infixE Nothing x (Just y)
202
203 lamE :: [PatQ] -> ExpQ -> ExpQ
204 lamE ps e = do ps' <- sequence ps
205 e' <- e
206 return (LamE ps' e')
207
208 lam1E :: PatQ -> ExpQ -> ExpQ -- Single-arg lambda
209 lam1E p e = lamE [p] e
210
211 tupE :: [ExpQ] -> ExpQ
212 tupE es = do { es1 <- sequence es; return (TupE es1)}
213
214 condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
215 condE x y z = do { a <- x; b <- y; c <- z; return (CondE a b c)}
216
217 letE :: [DecQ] -> ExpQ -> ExpQ
218 letE ds e = do { ds2 <- sequence ds; e2 <- e; return (LetE ds2 e2) }
219
220 caseE :: ExpQ -> [MatchQ] -> ExpQ
221 caseE e ms = do { e1 <- e; ms1 <- sequence ms; return (CaseE e1 ms1) }
222
223 doE :: [StmtQ] -> ExpQ
224 doE ss = do { ss1 <- sequence ss; return (DoE ss1) }
225
226 compE :: [StmtQ] -> ExpQ
227 compE ss = do { ss1 <- sequence ss; return (CompE ss1) }
228
229 arithSeqE :: RangeQ -> ExpQ
230 arithSeqE r = do { r' <- r; return (ArithSeqE r') }
231
232 -- arithSeqE Shortcuts
233 fromE :: ExpQ -> ExpQ
234 fromE x = do { a <- x; return (ArithSeqE (FromR a)) }
235
236 fromThenE :: ExpQ -> ExpQ -> ExpQ
237 fromThenE x y = do { a <- x; b <- y; return (ArithSeqE (FromThenR a b)) }
238
239 fromToE :: ExpQ -> ExpQ -> ExpQ
240 fromToE x y = do { a <- x; b <- y; return (ArithSeqE (FromToR a b)) }
241
242 fromThenToE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
243 fromThenToE x y z = do { a <- x; b <- y; c <- z;
244 return (ArithSeqE (FromThenToR a b c)) }
245 -- End arithSeqE shortcuts
246
247 listE :: [ExpQ] -> ExpQ
248 listE es = do { es1 <- sequence es; return (ListE es1) }
249
250 sigE :: ExpQ -> TypeQ -> ExpQ
251 sigE e t = do { e1 <- e; t1 <- t; return (SigE e1 t1) }
252
253 recConE :: Name -> [Q (Name,Exp)] -> ExpQ
254 recConE c fs = do { flds <- sequence fs; return (RecConE c flds) }
255
256 recUpdE :: ExpQ -> [Q (Name,Exp)] -> ExpQ
257 recUpdE e fs = do { e1 <- e; flds <- sequence fs; return (RecUpdE e1 flds) }
258
259 stringE :: String -> ExpQ
260 stringE = litE . stringL
261
262 fieldExp :: Name -> ExpQ -> Q (Name, Exp)
263 fieldExp s e = do { e' <- e; return (s,e') }
264
265 -------------------------------------------------------------------------------
266 -- Dec
267
268 valD :: PatQ -> BodyQ -> [DecQ] -> DecQ
269 valD p b ds =
270 do { p' <- p
271 ; ds' <- sequence ds
272 ; b' <- b
273 ; return (ValD p' b' ds')
274 }
275
276 funD :: Name -> [ClauseQ] -> DecQ
277 funD nm cs =
278 do { cs1 <- sequence cs
279 ; return (FunD nm cs1)
280 }
281
282 tySynD :: Name -> [Name] -> TypeQ -> DecQ
283 tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) }
284
285 dataD :: CxtQ -> Name -> [Name] -> [ConQ] -> [Name] -> DecQ
286 dataD ctxt tc tvs cons derivs =
287 do
288 ctxt1 <- ctxt
289 cons1 <- sequence cons
290 return (DataD ctxt1 tc tvs cons1 derivs)
291
292 newtypeD :: CxtQ -> Name -> [Name] -> ConQ -> [Name] -> DecQ
293 newtypeD ctxt tc tvs con derivs =
294 do
295 ctxt1 <- ctxt
296 con1 <- con
297 return (NewtypeD ctxt1 tc tvs con1 derivs)
298
299 classD :: CxtQ -> Name -> [Name] -> [FunDep] -> [DecQ] -> DecQ
300 classD ctxt cls tvs fds decs =
301 do
302 decs1 <- sequence decs
303 ctxt1 <- ctxt
304 return $ ClassD ctxt1 cls tvs fds decs1
305
306 instanceD :: CxtQ -> TypeQ -> [DecQ] -> DecQ
307 instanceD ctxt ty decs =
308 do
309 ctxt1 <- ctxt
310 decs1 <- sequence decs
311 ty1 <- ty
312 return $ InstanceD ctxt1 ty1 decs1
313
314 sigD :: Name -> TypeQ -> DecQ
315 sigD fun ty = liftM (SigD fun) $ ty
316
317 forImpD :: Callconv -> Safety -> String -> Name -> TypeQ -> DecQ
318 forImpD cc s str n ty
319 = do ty' <- ty
320 return $ ForeignD (ImportF cc s str n ty')
321
322 pragInlD :: Name -> InlineSpecQ -> DecQ
323 pragInlD n ispec
324 = do
325 ispec1 <- ispec
326 return $ PragmaD (InlineP n ispec1)
327
328 pragSpecD :: Name -> TypeQ -> DecQ
329 pragSpecD n ty
330 = do
331 ty1 <- ty
332 return $ PragmaD (SpecialiseP n ty1 Nothing)
333
334 pragSpecInlD :: Name -> TypeQ -> InlineSpecQ -> DecQ
335 pragSpecInlD n ty ispec
336 = do
337 ty1 <- ty
338 ispec1 <- ispec
339 return $ PragmaD (SpecialiseP n ty1 (Just ispec1))
340
341 familyD :: FamFlavour -> Name -> [Name] -> DecQ
342 familyD flav tc tvs = return $ FamilyD flav tc tvs
343
344 dataInstD :: CxtQ -> Name -> [TypeQ] -> [ConQ] -> [Name] -> DecQ
345 dataInstD ctxt tc tys cons derivs =
346 do
347 ctxt1 <- ctxt
348 tys1 <- sequence tys
349 cons1 <- sequence cons
350 return (DataInstD ctxt1 tc tys1 cons1 derivs)
351
352 newtypeInstD :: CxtQ -> Name -> [TypeQ] -> ConQ -> [Name] -> DecQ
353 newtypeInstD ctxt tc tys con derivs =
354 do
355 ctxt1 <- ctxt
356 tys1 <- sequence tys
357 con1 <- con
358 return (NewtypeInstD ctxt1 tc tys1 con1 derivs)
359
360 tySynInstD :: Name -> [TypeQ] -> TypeQ -> DecQ
361 tySynInstD tc tys rhs =
362 do
363 tys1 <- sequence tys
364 rhs1 <- rhs
365 return (TySynInstD tc tys1 rhs1)
366
367 cxt :: [PredQ] -> CxtQ
368 cxt = sequence
369
370 classP :: Name -> [TypeQ] -> PredQ
371 classP cla tys
372 = do
373 tys1 <- sequence tys
374 return (ClassP cla tys1)
375
376 equalP :: TypeQ -> TypeQ -> PredQ
377 equalP tleft tright
378 = do
379 tleft1 <- tleft
380 tright1 <- tright
381 return (EqualP tleft1 tright1)
382
383 normalC :: Name -> [StrictTypeQ] -> ConQ
384 normalC con strtys = liftM (NormalC con) $ sequence strtys
385
386 recC :: Name -> [VarStrictTypeQ] -> ConQ
387 recC con varstrtys = liftM (RecC con) $ sequence varstrtys
388
389 infixC :: Q (Strict, Type) -> Name -> Q (Strict, Type) -> ConQ
390 infixC st1 con st2 = do st1' <- st1
391 st2' <- st2
392 return $ InfixC st1' con st2'
393
394 forallC :: [Name] -> CxtQ -> ConQ -> ConQ
395 forallC ns ctxt con = liftM2 (ForallC ns) ctxt con
396
397
398 -------------------------------------------------------------------------------
399 -- Type
400
401 forallT :: [Name] -> CxtQ -> TypeQ -> TypeQ
402 forallT tvars ctxt ty = do
403 ctxt1 <- ctxt
404 ty1 <- ty
405 return $ ForallT tvars ctxt1 ty1
406
407 varT :: Name -> TypeQ
408 varT = return . VarT
409
410 conT :: Name -> TypeQ
411 conT = return . ConT
412
413 appT :: TypeQ -> TypeQ -> TypeQ
414 appT t1 t2 = do
415 t1' <- t1
416 t2' <- t2
417 return $ AppT t1' t2'
418
419 arrowT :: TypeQ
420 arrowT = return ArrowT
421
422 listT :: TypeQ
423 listT = return ListT
424
425 tupleT :: Int -> TypeQ
426 tupleT i = return (TupleT i)
427
428 isStrict, notStrict :: Q Strict
429 isStrict = return $ IsStrict
430 notStrict = return $ NotStrict
431
432 strictType :: Q Strict -> TypeQ -> StrictTypeQ
433 strictType = liftM2 (,)
434
435 varStrictType :: Name -> StrictTypeQ -> VarStrictTypeQ
436 varStrictType v st = do (s, t) <- st
437 return (v, s, t)
438
439 -------------------------------------------------------------------------------
440 -- Callconv
441
442 cCall, stdCall :: Callconv
443 cCall = CCall
444 stdCall = StdCall
445
446 -------------------------------------------------------------------------------
447 -- Safety
448
449 unsafe, safe, threadsafe :: Safety
450 unsafe = Unsafe
451 safe = Safe
452 threadsafe = Threadsafe
453
454 -------------------------------------------------------------------------------
455 -- InlineSpec
456
457 inlineSpecNoPhase :: Bool -> Bool -> InlineSpecQ
458 inlineSpecNoPhase inline conlike
459 = return $ InlineSpec inline conlike Nothing
460
461 inlineSpecPhase :: Bool -> Bool -> Bool -> Int -> InlineSpecQ
462 inlineSpecPhase inline conlike beforeFrom phase
463 = return $ InlineSpec inline conlike (Just (beforeFrom, phase))
464
465 -------------------------------------------------------------------------------
466 -- FunDep
467
468 funDep :: [Name] -> [Name] -> FunDep
469 funDep = FunDep
470
471 -------------------------------------------------------------------------------
472 -- FamFlavour
473
474 typeFam, dataFam :: FamFlavour
475 typeFam = TypeFam
476 dataFam = DataFam
477
478 --------------------------------------------------------------
479 -- Useful helper functions
480
481 combine :: [([(Name, Name)], Pat)] -> ([(Name, Name)], [Pat])
482 combine pairs = foldr f ([],[]) pairs
483 where f (env,p) (es,ps) = (env++es,p:ps)
484
485 rename :: Pat -> Q ([(Name, Name)], Pat)
486 rename (LitP c) = return([],LitP c)
487 rename (VarP s) = do { s1 <- newName (nameBase s); return([(s,s1)],VarP s1) }
488 rename (TupP pats) = do { pairs <- mapM rename pats; g(combine pairs) }
489 where g (es,ps) = return (es,TupP ps)
490 rename (ConP nm pats) = do { pairs <- mapM rename pats; g(combine pairs) }
491 where g (es,ps) = return (es,ConP nm ps)
492 rename (InfixP p1 n p2) = do { r1 <- rename p1;
493 r2 <- rename p2;
494 let {(env, [p1', p2']) = combine [r1, r2]};
495 return (env, InfixP p1' n p2') }
496 rename (TildeP p) = do { (env,p2) <- rename p; return(env,TildeP p2) }
497 rename (AsP s p) =
498 do { s1 <- newName (nameBase s); (env,p2) <- rename p; return((s,s1):env,AsP s1 p2) }
499 rename WildP = return([],WildP)
500 rename (RecP nm fs) = do { pairs <- mapM rename ps; g(combine pairs) }
501 where g (env,ps') = return (env,RecP nm (zip ss ps'))
502 (ss,ps) = unzip fs
503 rename (ListP pats) = do { pairs <- mapM rename pats; g(combine pairs) }
504 where g (es,ps) = return (es,ListP ps)
505 rename (SigP {}) = fail "rename: Don't know how to do SigP yet"
506
507 genpat :: Pat -> Q ((Name -> ExpQ), Pat)
508 genpat p = do { (env,p2) <- rename p; return (alpha env,p2) }
509
510 alpha :: [(Name, Name)] -> Name -> ExpQ
511 alpha env s = case lookup s env of
512 Just x -> varE x
513 Nothing -> varE s
514
515 appsE :: [ExpQ] -> ExpQ
516 appsE [] = error "appsExp []"
517 appsE [x] = x
518 appsE (x:y:zs) = appsE ( (appE x y) : zs )
519
520 simpleMatch :: Pat -> Exp -> Match
521 simpleMatch p e = Match p (NormalB e) []
522