StringPrimL now takes [Word8]
[packages/template-haskell.git] / Language / Haskell / TH / Lib.hs
1 -- |
2 -- TH.Lib contains lots of useful helper functions for
3 -- generating and manipulating Template Haskell terms
4
5 module Language.Haskell.TH.Lib where
6 -- All of the exports from this module should
7 -- be "public" functions. The main module TH
8 -- re-exports them all.
9
10 import Language.Haskell.TH.Syntax
11 import Control.Monad( liftM, liftM2 )
12 import Data.Word( Word8 )
13
14 ----------------------------------------------------------
15 -- * Type synonyms
16 ----------------------------------------------------------
17
18 type InfoQ = Q Info
19 type PatQ = Q Pat
20 type FieldPatQ = Q FieldPat
21 type ExpQ = Q Exp
22 type DecQ = Q Dec
23 type DecsQ = Q [Dec]
24 type ConQ = Q Con
25 type TypeQ = Q Type
26 type TyLitQ = Q TyLit
27 type CxtQ = Q Cxt
28 type PredQ = Q Pred
29 type MatchQ = Q Match
30 type ClauseQ = Q Clause
31 type BodyQ = Q Body
32 type GuardQ = Q Guard
33 type StmtQ = Q Stmt
34 type RangeQ = Q Range
35 type StrictTypeQ = Q StrictType
36 type VarStrictTypeQ = Q VarStrictType
37 type FieldExpQ = Q FieldExp
38 type InlineSpecQ = Q InlineSpec
39
40 ----------------------------------------------------------
41 -- * Lowercase pattern syntax functions
42 ----------------------------------------------------------
43
44 intPrimL :: Integer -> Lit
45 intPrimL = IntPrimL
46 wordPrimL :: Integer -> Lit
47 wordPrimL = WordPrimL
48 floatPrimL :: Rational -> Lit
49 floatPrimL = FloatPrimL
50 doublePrimL :: Rational -> Lit
51 doublePrimL = DoublePrimL
52 integerL :: Integer -> Lit
53 integerL = IntegerL
54 charL :: Char -> Lit
55 charL = CharL
56 stringL :: String -> Lit
57 stringL = StringL
58 stringPrimL :: [Word8] -> Lit
59 stringPrimL = StringPrimL
60 rationalL :: Rational -> Lit
61 rationalL = RationalL
62
63 litP :: Lit -> PatQ
64 litP l = return (LitP l)
65 varP :: Name -> PatQ
66 varP v = return (VarP v)
67 tupP :: [PatQ] -> PatQ
68 tupP ps = do { ps1 <- sequence ps; return (TupP ps1)}
69 unboxedTupP :: [PatQ] -> PatQ
70 unboxedTupP ps = do { ps1 <- sequence ps; return (UnboxedTupP ps1)}
71 conP :: Name -> [PatQ] -> PatQ
72 conP n ps = do ps' <- sequence ps
73 return (ConP n ps')
74 infixP :: PatQ -> Name -> PatQ -> PatQ
75 infixP p1 n p2 = do p1' <- p1
76 p2' <- p2
77 return (InfixP p1' n p2')
78 uInfixP :: PatQ -> Name -> PatQ -> PatQ
79 uInfixP p1 n p2 = do p1' <- p1
80 p2' <- p2
81 return (UInfixP p1' n p2')
82 parensP :: PatQ -> PatQ
83 parensP p = do p' <- p
84 return (ParensP p')
85
86 tildeP :: PatQ -> PatQ
87 tildeP p = do p' <- p
88 return (TildeP p')
89 bangP :: PatQ -> PatQ
90 bangP p = do p' <- p
91 return (BangP p')
92 asP :: Name -> PatQ -> PatQ
93 asP n p = do p' <- p
94 return (AsP n p')
95 wildP :: PatQ
96 wildP = return WildP
97 recP :: Name -> [FieldPatQ] -> PatQ
98 recP n fps = do fps' <- sequence fps
99 return (RecP n fps')
100 listP :: [PatQ] -> PatQ
101 listP ps = do ps' <- sequence ps
102 return (ListP ps')
103 sigP :: PatQ -> TypeQ -> PatQ
104 sigP p t = do p' <- p
105 t' <- t
106 return (SigP p' t')
107 viewP :: ExpQ -> PatQ -> PatQ
108 viewP e p = do e' <- e
109 p' <- p
110 return (ViewP e' p')
111
112 fieldPat :: Name -> PatQ -> FieldPatQ
113 fieldPat n p = do p' <- p
114 return (n, p')
115
116
117 -------------------------------------------------------------------------------
118 -- * Stmt
119
120 bindS :: PatQ -> ExpQ -> StmtQ
121 bindS p e = liftM2 BindS p e
122
123 letS :: [DecQ] -> StmtQ
124 letS ds = do { ds1 <- sequence ds; return (LetS ds1) }
125
126 noBindS :: ExpQ -> StmtQ
127 noBindS e = do { e1 <- e; return (NoBindS e1) }
128
129 parS :: [[StmtQ]] -> StmtQ
130 parS _ = fail "No parallel comprehensions yet"
131
132 -------------------------------------------------------------------------------
133 -- * Range
134
135 fromR :: ExpQ -> RangeQ
136 fromR x = do { a <- x; return (FromR a) }
137
138 fromThenR :: ExpQ -> ExpQ -> RangeQ
139 fromThenR x y = do { a <- x; b <- y; return (FromThenR a b) }
140
141 fromToR :: ExpQ -> ExpQ -> RangeQ
142 fromToR x y = do { a <- x; b <- y; return (FromToR a b) }
143
144 fromThenToR :: ExpQ -> ExpQ -> ExpQ -> RangeQ
145 fromThenToR x y z = do { a <- x; b <- y; c <- z;
146 return (FromThenToR a b c) }
147 -------------------------------------------------------------------------------
148 -- * Body
149
150 normalB :: ExpQ -> BodyQ
151 normalB e = do { e1 <- e; return (NormalB e1) }
152
153 guardedB :: [Q (Guard,Exp)] -> BodyQ
154 guardedB ges = do { ges' <- sequence ges; return (GuardedB ges') }
155
156 -------------------------------------------------------------------------------
157 -- * Guard
158
159 normalG :: ExpQ -> GuardQ
160 normalG e = do { e1 <- e; return (NormalG e1) }
161
162 normalGE :: ExpQ -> ExpQ -> Q (Guard, Exp)
163 normalGE g e = do { g1 <- g; e1 <- e; return (NormalG g1, e1) }
164
165 patG :: [StmtQ] -> GuardQ
166 patG ss = do { ss' <- sequence ss; return (PatG ss') }
167
168 patGE :: [StmtQ] -> ExpQ -> Q (Guard, Exp)
169 patGE ss e = do { ss' <- sequence ss;
170 e' <- e;
171 return (PatG ss', e') }
172
173 -------------------------------------------------------------------------------
174 -- * Match and Clause
175
176 -- | Use with 'caseE'
177 match :: PatQ -> BodyQ -> [DecQ] -> MatchQ
178 match p rhs ds = do { p' <- p;
179 r' <- rhs;
180 ds' <- sequence ds;
181 return (Match p' r' ds') }
182
183 -- | Use with 'funD'
184 clause :: [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
185 clause ps r ds = do { ps' <- sequence ps;
186 r' <- r;
187 ds' <- sequence ds;
188 return (Clause ps' r' ds') }
189
190
191 ---------------------------------------------------------------------------
192 -- * Exp
193
194 -- | Dynamically binding a variable (unhygenic)
195 dyn :: String -> Q Exp
196 dyn s = return (VarE (mkName s))
197
198 global :: Name -> ExpQ
199 global s = return (VarE s)
200
201 varE :: Name -> ExpQ
202 varE s = return (VarE s)
203
204 conE :: Name -> ExpQ
205 conE s = return (ConE s)
206
207 litE :: Lit -> ExpQ
208 litE c = return (LitE c)
209
210 appE :: ExpQ -> ExpQ -> ExpQ
211 appE x y = do { a <- x; b <- y; return (AppE a b)}
212
213 parensE :: ExpQ -> ExpQ
214 parensE x = do { x' <- x; return (ParensE x') }
215
216 uInfixE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
217 uInfixE x s y = do { x' <- x; s' <- s; y' <- y;
218 return (UInfixE x' s' y') }
219
220 infixE :: Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
221 infixE (Just x) s (Just y) = do { a <- x; s' <- s; b <- y;
222 return (InfixE (Just a) s' (Just b))}
223 infixE Nothing s (Just y) = do { s' <- s; b <- y;
224 return (InfixE Nothing s' (Just b))}
225 infixE (Just x) s Nothing = do { a <- x; s' <- s;
226 return (InfixE (Just a) s' Nothing)}
227 infixE Nothing s Nothing = do { s' <- s; return (InfixE Nothing s' Nothing) }
228
229 infixApp :: ExpQ -> ExpQ -> ExpQ -> ExpQ
230 infixApp x y z = infixE (Just x) y (Just z)
231 sectionL :: ExpQ -> ExpQ -> ExpQ
232 sectionL x y = infixE (Just x) y Nothing
233 sectionR :: ExpQ -> ExpQ -> ExpQ
234 sectionR x y = infixE Nothing x (Just y)
235
236 lamE :: [PatQ] -> ExpQ -> ExpQ
237 lamE ps e = do ps' <- sequence ps
238 e' <- e
239 return (LamE ps' e')
240
241 -- | Single-arg lambda
242 lam1E :: PatQ -> ExpQ -> ExpQ
243 lam1E p e = lamE [p] e
244
245 tupE :: [ExpQ] -> ExpQ
246 tupE es = do { es1 <- sequence es; return (TupE es1)}
247
248 unboxedTupE :: [ExpQ] -> ExpQ
249 unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE es1)}
250
251 condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
252 condE x y z = do { a <- x; b <- y; c <- z; return (CondE a b c)}
253
254 letE :: [DecQ] -> ExpQ -> ExpQ
255 letE ds e = do { ds2 <- sequence ds; e2 <- e; return (LetE ds2 e2) }
256
257 caseE :: ExpQ -> [MatchQ] -> ExpQ
258 caseE e ms = do { e1 <- e; ms1 <- sequence ms; return (CaseE e1 ms1) }
259
260 doE :: [StmtQ] -> ExpQ
261 doE ss = do { ss1 <- sequence ss; return (DoE ss1) }
262
263 compE :: [StmtQ] -> ExpQ
264 compE ss = do { ss1 <- sequence ss; return (CompE ss1) }
265
266 arithSeqE :: RangeQ -> ExpQ
267 arithSeqE r = do { r' <- r; return (ArithSeqE r') }
268
269 listE :: [ExpQ] -> ExpQ
270 listE es = do { es1 <- sequence es; return (ListE es1) }
271
272 sigE :: ExpQ -> TypeQ -> ExpQ
273 sigE e t = do { e1 <- e; t1 <- t; return (SigE e1 t1) }
274
275 recConE :: Name -> [Q (Name,Exp)] -> ExpQ
276 recConE c fs = do { flds <- sequence fs; return (RecConE c flds) }
277
278 recUpdE :: ExpQ -> [Q (Name,Exp)] -> ExpQ
279 recUpdE e fs = do { e1 <- e; flds <- sequence fs; return (RecUpdE e1 flds) }
280
281 stringE :: String -> ExpQ
282 stringE = litE . stringL
283
284 fieldExp :: Name -> ExpQ -> Q (Name, Exp)
285 fieldExp s e = do { e' <- e; return (s,e') }
286
287 -- ** 'arithSeqE' Shortcuts
288 fromE :: ExpQ -> ExpQ
289 fromE x = do { a <- x; return (ArithSeqE (FromR a)) }
290
291 fromThenE :: ExpQ -> ExpQ -> ExpQ
292 fromThenE x y = do { a <- x; b <- y; return (ArithSeqE (FromThenR a b)) }
293
294 fromToE :: ExpQ -> ExpQ -> ExpQ
295 fromToE x y = do { a <- x; b <- y; return (ArithSeqE (FromToR a b)) }
296
297 fromThenToE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
298 fromThenToE x y z = do { a <- x; b <- y; c <- z;
299 return (ArithSeqE (FromThenToR a b c)) }
300
301
302 -------------------------------------------------------------------------------
303 -- * Dec
304
305 valD :: PatQ -> BodyQ -> [DecQ] -> DecQ
306 valD p b ds =
307 do { p' <- p
308 ; ds' <- sequence ds
309 ; b' <- b
310 ; return (ValD p' b' ds')
311 }
312
313 funD :: Name -> [ClauseQ] -> DecQ
314 funD nm cs =
315 do { cs1 <- sequence cs
316 ; return (FunD nm cs1)
317 }
318
319 tySynD :: Name -> [TyVarBndr] -> TypeQ -> DecQ
320 tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) }
321
322 dataD :: CxtQ -> Name -> [TyVarBndr] -> [ConQ] -> [Name] -> DecQ
323 dataD ctxt tc tvs cons derivs =
324 do
325 ctxt1 <- ctxt
326 cons1 <- sequence cons
327 return (DataD ctxt1 tc tvs cons1 derivs)
328
329 newtypeD :: CxtQ -> Name -> [TyVarBndr] -> ConQ -> [Name] -> DecQ
330 newtypeD ctxt tc tvs con derivs =
331 do
332 ctxt1 <- ctxt
333 con1 <- con
334 return (NewtypeD ctxt1 tc tvs con1 derivs)
335
336 classD :: CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [DecQ] -> DecQ
337 classD ctxt cls tvs fds decs =
338 do
339 decs1 <- sequence decs
340 ctxt1 <- ctxt
341 return $ ClassD ctxt1 cls tvs fds decs1
342
343 instanceD :: CxtQ -> TypeQ -> [DecQ] -> DecQ
344 instanceD ctxt ty decs =
345 do
346 ctxt1 <- ctxt
347 decs1 <- sequence decs
348 ty1 <- ty
349 return $ InstanceD ctxt1 ty1 decs1
350
351 sigD :: Name -> TypeQ -> DecQ
352 sigD fun ty = liftM (SigD fun) $ ty
353
354 forImpD :: Callconv -> Safety -> String -> Name -> TypeQ -> DecQ
355 forImpD cc s str n ty
356 = do ty' <- ty
357 return $ ForeignD (ImportF cc s str n ty')
358
359 infixLD :: Int -> Name -> DecQ
360 infixLD prec nm = return (InfixD (Fixity prec InfixL) nm)
361
362 infixRD :: Int -> Name -> DecQ
363 infixRD prec nm = return (InfixD (Fixity prec InfixR) nm)
364
365 infixND :: Int -> Name -> DecQ
366 infixND prec nm = return (InfixD (Fixity prec InfixN) nm)
367
368 pragInlD :: Name -> InlineSpecQ -> DecQ
369 pragInlD n ispec
370 = do
371 ispec1 <- ispec
372 return $ PragmaD (InlineP n ispec1)
373
374 pragSpecD :: Name -> TypeQ -> DecQ
375 pragSpecD n ty
376 = do
377 ty1 <- ty
378 return $ PragmaD (SpecialiseP n ty1 Nothing)
379
380 pragSpecInlD :: Name -> TypeQ -> InlineSpecQ -> DecQ
381 pragSpecInlD n ty ispec
382 = do
383 ty1 <- ty
384 ispec1 <- ispec
385 return $ PragmaD (SpecialiseP n ty1 (Just ispec1))
386
387 familyNoKindD :: FamFlavour -> Name -> [TyVarBndr] -> DecQ
388 familyNoKindD flav tc tvs = return $ FamilyD flav tc tvs Nothing
389
390 familyKindD :: FamFlavour -> Name -> [TyVarBndr] -> Kind -> DecQ
391 familyKindD flav tc tvs k = return $ FamilyD flav tc tvs (Just k)
392
393 dataInstD :: CxtQ -> Name -> [TypeQ] -> [ConQ] -> [Name] -> DecQ
394 dataInstD ctxt tc tys cons derivs =
395 do
396 ctxt1 <- ctxt
397 tys1 <- sequence tys
398 cons1 <- sequence cons
399 return (DataInstD ctxt1 tc tys1 cons1 derivs)
400
401 newtypeInstD :: CxtQ -> Name -> [TypeQ] -> ConQ -> [Name] -> DecQ
402 newtypeInstD ctxt tc tys con derivs =
403 do
404 ctxt1 <- ctxt
405 tys1 <- sequence tys
406 con1 <- con
407 return (NewtypeInstD ctxt1 tc tys1 con1 derivs)
408
409 tySynInstD :: Name -> [TypeQ] -> TypeQ -> DecQ
410 tySynInstD tc tys rhs =
411 do
412 tys1 <- sequence tys
413 rhs1 <- rhs
414 return (TySynInstD tc tys1 rhs1)
415
416 cxt :: [PredQ] -> CxtQ
417 cxt = sequence
418
419 classP :: Name -> [TypeQ] -> PredQ
420 classP cla tys
421 = do
422 tys1 <- sequence tys
423 return (ClassP cla tys1)
424
425 equalP :: TypeQ -> TypeQ -> PredQ
426 equalP tleft tright
427 = do
428 tleft1 <- tleft
429 tright1 <- tright
430 return (EqualP tleft1 tright1)
431
432 normalC :: Name -> [StrictTypeQ] -> ConQ
433 normalC con strtys = liftM (NormalC con) $ sequence strtys
434
435 recC :: Name -> [VarStrictTypeQ] -> ConQ
436 recC con varstrtys = liftM (RecC con) $ sequence varstrtys
437
438 infixC :: Q (Strict, Type) -> Name -> Q (Strict, Type) -> ConQ
439 infixC st1 con st2 = do st1' <- st1
440 st2' <- st2
441 return $ InfixC st1' con st2'
442
443 forallC :: [TyVarBndr] -> CxtQ -> ConQ -> ConQ
444 forallC ns ctxt con = liftM2 (ForallC ns) ctxt con
445
446
447 -------------------------------------------------------------------------------
448 -- * Type
449
450 forallT :: [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
451 forallT tvars ctxt ty = do
452 ctxt1 <- ctxt
453 ty1 <- ty
454 return $ ForallT tvars ctxt1 ty1
455
456 varT :: Name -> TypeQ
457 varT = return . VarT
458
459 conT :: Name -> TypeQ
460 conT = return . ConT
461
462 appT :: TypeQ -> TypeQ -> TypeQ
463 appT t1 t2 = do
464 t1' <- t1
465 t2' <- t2
466 return $ AppT t1' t2'
467
468 arrowT :: TypeQ
469 arrowT = return ArrowT
470
471 listT :: TypeQ
472 listT = return ListT
473
474 litT :: TyLitQ -> TypeQ
475 litT l = fmap LitT l
476
477 tupleT :: Int -> TypeQ
478 tupleT i = return (TupleT i)
479
480 unboxedTupleT :: Int -> TypeQ
481 unboxedTupleT i = return (UnboxedTupleT i)
482
483 sigT :: TypeQ -> Kind -> TypeQ
484 sigT t k
485 = do
486 t' <- t
487 return $ SigT t' k
488
489 promotedT :: Name -> TypeQ
490 promotedT = return . PromotedT
491
492 promotedTupleT :: Int -> TypeQ
493 promotedTupleT i = return (PromotedTupleT i)
494
495 promotedNilT :: TypeQ
496 promotedNilT = return PromotedNilT
497
498 promotedConsT :: TypeQ
499 promotedConsT = return PromotedConsT
500
501 isStrict, notStrict, unpacked :: Q Strict
502 isStrict = return $ IsStrict
503 notStrict = return $ NotStrict
504 unpacked = return Unpacked
505
506 strictType :: Q Strict -> TypeQ -> StrictTypeQ
507 strictType = liftM2 (,)
508
509 varStrictType :: Name -> StrictTypeQ -> VarStrictTypeQ
510 varStrictType v st = do (s, t) <- st
511 return (v, s, t)
512
513 -- * Type Literals
514
515 numTyLit :: Integer -> TyLitQ
516 numTyLit n = if n >= 0 then return (NumTyLit n)
517 else fail ("Negative type-level number: " ++ show n)
518
519 strTyLit :: String -> TyLitQ
520 strTyLit s = return (StrTyLit s)
521
522
523
524 -------------------------------------------------------------------------------
525 -- * Kind
526
527 plainTV :: Name -> TyVarBndr
528 plainTV = PlainTV
529
530 kindedTV :: Name -> Kind -> TyVarBndr
531 kindedTV = KindedTV
532
533 varK :: Name -> Kind
534 varK = VarT
535
536 conK :: Name -> Kind
537 conK = ConT
538
539 tupleK :: Int -> Kind
540 tupleK = TupleT
541
542 arrowK :: Kind
543 arrowK = ArrowT
544
545 listK :: Kind
546 listK = ListT
547
548 appK :: Kind -> Kind -> Kind
549 appK = AppT
550
551 starK :: Kind
552 starK = StarT
553
554 constraintK :: Kind
555 constraintK = ConstraintT
556
557 -------------------------------------------------------------------------------
558 -- * Callconv
559
560 cCall, stdCall :: Callconv
561 cCall = CCall
562 stdCall = StdCall
563
564 -------------------------------------------------------------------------------
565 -- * Safety
566
567 unsafe, safe, interruptible :: Safety
568 unsafe = Unsafe
569 safe = Safe
570 interruptible = Interruptible
571
572 -------------------------------------------------------------------------------
573 -- * InlineSpec
574
575 inlineSpecNoPhase :: Inline -> Bool -> InlineSpecQ
576 inlineSpecNoPhase inline conlike
577 = return $ InlineSpec inline conlike Nothing
578
579 inlineSpecPhase :: Inline -> Bool -> Bool -> Int -> InlineSpecQ
580 inlineSpecPhase inline conlike beforeFrom phase
581 = return $ InlineSpec inline conlike (Just (beforeFrom, phase))
582
583 -------------------------------------------------------------------------------
584 -- * FunDep
585
586 funDep :: [Name] -> [Name] -> FunDep
587 funDep = FunDep
588
589 -------------------------------------------------------------------------------
590 -- * FamFlavour
591
592 typeFam, dataFam :: FamFlavour
593 typeFam = TypeFam
594 dataFam = DataFam
595
596 --------------------------------------------------------------
597 -- * Useful helper function
598
599 appsE :: [ExpQ] -> ExpQ
600 appsE [] = error "appsE []"
601 appsE [x] = x
602 appsE (x:y:zs) = appsE ( (appE x y) : zs )
603