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