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