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