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