Add support for ImplicitParams and RecursiveDo in TH
[ghc.git] / libraries / template-haskell / Language / Haskell / TH / Lib / Internal.hs
1 -- |
2 -- Language.Haskell.TH.Lib.Internal exposes some additional functionality that
3 -- is used internally in GHC's integration with Template Haskell. This is not a
4 -- part of the public API, and as such, there are no API guarantees for this
5 -- module from version to version.
6
7 -- Why do we have both Language.Haskell.TH.Lib.Internal and
8 -- Language.Haskell.TH.Lib? Ultimately, it's because the functions in the
9 -- former (which are tailored for GHC's use) need different type signatures
10 -- than the ones in the latter. Syncing up the Internal type signatures would
11 -- involve a massive amount of breaking changes, so for the time being, we
12 -- relegate as many changes as we can to just the Internal module, where it
13 -- is safe to break things.
14
15 module Language.Haskell.TH.Lib.Internal where
16
17 import Language.Haskell.TH.Syntax hiding (Role, InjectivityAnn)
18 import qualified Language.Haskell.TH.Syntax as TH
19 import Control.Monad( liftM, liftM2 )
20 import Data.Word( Word8 )
21 import Prelude
22
23 ----------------------------------------------------------
24 -- * Type synonyms
25 ----------------------------------------------------------
26
27 type InfoQ = Q Info
28 type PatQ = Q Pat
29 type FieldPatQ = Q FieldPat
30 type ExpQ = Q Exp
31 type TExpQ a = Q (TExp a)
32 type DecQ = Q Dec
33 type DecsQ = Q [Dec]
34 type ConQ = Q Con
35 type TypeQ = Q Type
36 type KindQ = Q Kind
37 type TyVarBndrQ = Q TyVarBndr
38 type TyLitQ = Q TyLit
39 type CxtQ = Q Cxt
40 type PredQ = Q Pred
41 type DerivClauseQ = Q DerivClause
42 type MatchQ = Q Match
43 type ClauseQ = Q Clause
44 type BodyQ = Q Body
45 type GuardQ = Q Guard
46 type StmtQ = Q Stmt
47 type RangeQ = Q Range
48 type SourceStrictnessQ = Q SourceStrictness
49 type SourceUnpackednessQ = Q SourceUnpackedness
50 type BangQ = Q Bang
51 type BangTypeQ = Q BangType
52 type VarBangTypeQ = Q VarBangType
53 type StrictTypeQ = Q StrictType
54 type VarStrictTypeQ = Q VarStrictType
55 type FieldExpQ = Q FieldExp
56 type RuleBndrQ = Q RuleBndr
57 type TySynEqnQ = Q TySynEqn
58 type PatSynDirQ = Q PatSynDir
59 type PatSynArgsQ = Q PatSynArgs
60 type FamilyResultSigQ = Q FamilyResultSig
61 type DerivStrategyQ = Q DerivStrategy
62
63 -- must be defined here for DsMeta to find it
64 type Role = TH.Role
65 type InjectivityAnn = TH.InjectivityAnn
66
67 ----------------------------------------------------------
68 -- * Lowercase pattern syntax functions
69 ----------------------------------------------------------
70
71 intPrimL :: Integer -> Lit
72 intPrimL = IntPrimL
73 wordPrimL :: Integer -> Lit
74 wordPrimL = WordPrimL
75 floatPrimL :: Rational -> Lit
76 floatPrimL = FloatPrimL
77 doublePrimL :: Rational -> Lit
78 doublePrimL = DoublePrimL
79 integerL :: Integer -> Lit
80 integerL = IntegerL
81 charL :: Char -> Lit
82 charL = CharL
83 charPrimL :: Char -> Lit
84 charPrimL = CharPrimL
85 stringL :: String -> Lit
86 stringL = StringL
87 stringPrimL :: [Word8] -> Lit
88 stringPrimL = StringPrimL
89 rationalL :: Rational -> Lit
90 rationalL = RationalL
91
92 litP :: Lit -> PatQ
93 litP l = return (LitP l)
94
95 varP :: Name -> PatQ
96 varP v = return (VarP v)
97
98 tupP :: [PatQ] -> PatQ
99 tupP ps = do { ps1 <- sequence ps; return (TupP ps1)}
100
101 unboxedTupP :: [PatQ] -> PatQ
102 unboxedTupP ps = do { ps1 <- sequence ps; return (UnboxedTupP ps1)}
103
104 unboxedSumP :: PatQ -> SumAlt -> SumArity -> PatQ
105 unboxedSumP p alt arity = do { p1 <- p; return (UnboxedSumP p1 alt arity) }
106
107 conP :: Name -> [PatQ] -> PatQ
108 conP n ps = do ps' <- sequence ps
109 return (ConP n ps')
110 infixP :: PatQ -> Name -> PatQ -> PatQ
111 infixP p1 n p2 = do p1' <- p1
112 p2' <- p2
113 return (InfixP p1' n p2')
114 uInfixP :: PatQ -> Name -> PatQ -> PatQ
115 uInfixP p1 n p2 = do p1' <- p1
116 p2' <- p2
117 return (UInfixP p1' n p2')
118 parensP :: PatQ -> PatQ
119 parensP p = do p' <- p
120 return (ParensP p')
121
122 tildeP :: PatQ -> PatQ
123 tildeP p = do p' <- p
124 return (TildeP p')
125 bangP :: PatQ -> PatQ
126 bangP p = do p' <- p
127 return (BangP p')
128 asP :: Name -> PatQ -> PatQ
129 asP n p = do p' <- p
130 return (AsP n p')
131 wildP :: PatQ
132 wildP = return WildP
133 recP :: Name -> [FieldPatQ] -> PatQ
134 recP n fps = do fps' <- sequence fps
135 return (RecP n fps')
136 listP :: [PatQ] -> PatQ
137 listP ps = do ps' <- sequence ps
138 return (ListP ps')
139 sigP :: PatQ -> TypeQ -> PatQ
140 sigP p t = do p' <- p
141 t' <- t
142 return (SigP p' t')
143 viewP :: ExpQ -> PatQ -> PatQ
144 viewP e p = do e' <- e
145 p' <- p
146 return (ViewP e' p')
147
148 fieldPat :: Name -> PatQ -> FieldPatQ
149 fieldPat n p = do p' <- p
150 return (n, p')
151
152
153 -------------------------------------------------------------------------------
154 -- * Stmt
155
156 bindS :: PatQ -> ExpQ -> StmtQ
157 bindS p e = liftM2 BindS p e
158
159 letS :: [DecQ] -> StmtQ
160 letS ds = do { ds1 <- sequence ds; return (LetS ds1) }
161
162 noBindS :: ExpQ -> StmtQ
163 noBindS e = do { e1 <- e; return (NoBindS e1) }
164
165 parS :: [[StmtQ]] -> StmtQ
166 parS sss = do { sss1 <- mapM sequence sss; return (ParS sss1) }
167
168 recS :: [StmtQ] -> StmtQ
169 recS ss = do { ss1 <- sequence ss; return (RecS ss1) }
170
171 -------------------------------------------------------------------------------
172 -- * Range
173
174 fromR :: ExpQ -> RangeQ
175 fromR x = do { a <- x; return (FromR a) }
176
177 fromThenR :: ExpQ -> ExpQ -> RangeQ
178 fromThenR x y = do { a <- x; b <- y; return (FromThenR a b) }
179
180 fromToR :: ExpQ -> ExpQ -> RangeQ
181 fromToR x y = do { a <- x; b <- y; return (FromToR a b) }
182
183 fromThenToR :: ExpQ -> ExpQ -> ExpQ -> RangeQ
184 fromThenToR x y z = do { a <- x; b <- y; c <- z;
185 return (FromThenToR a b c) }
186 -------------------------------------------------------------------------------
187 -- * Body
188
189 normalB :: ExpQ -> BodyQ
190 normalB e = do { e1 <- e; return (NormalB e1) }
191
192 guardedB :: [Q (Guard,Exp)] -> BodyQ
193 guardedB ges = do { ges' <- sequence ges; return (GuardedB ges') }
194
195 -------------------------------------------------------------------------------
196 -- * Guard
197
198 normalG :: ExpQ -> GuardQ
199 normalG e = do { e1 <- e; return (NormalG e1) }
200
201 normalGE :: ExpQ -> ExpQ -> Q (Guard, Exp)
202 normalGE g e = do { g1 <- g; e1 <- e; return (NormalG g1, e1) }
203
204 patG :: [StmtQ] -> GuardQ
205 patG ss = do { ss' <- sequence ss; return (PatG ss') }
206
207 patGE :: [StmtQ] -> ExpQ -> Q (Guard, Exp)
208 patGE ss e = do { ss' <- sequence ss;
209 e' <- e;
210 return (PatG ss', e') }
211
212 -------------------------------------------------------------------------------
213 -- * Match and Clause
214
215 -- | Use with 'caseE'
216 match :: PatQ -> BodyQ -> [DecQ] -> MatchQ
217 match p rhs ds = do { p' <- p;
218 r' <- rhs;
219 ds' <- sequence ds;
220 return (Match p' r' ds') }
221
222 -- | Use with 'funD'
223 clause :: [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
224 clause ps r ds = do { ps' <- sequence ps;
225 r' <- r;
226 ds' <- sequence ds;
227 return (Clause ps' r' ds') }
228
229
230 ---------------------------------------------------------------------------
231 -- * Exp
232
233 -- | Dynamically binding a variable (unhygenic)
234 dyn :: String -> ExpQ
235 dyn s = return (VarE (mkName s))
236
237 varE :: Name -> ExpQ
238 varE s = return (VarE s)
239
240 conE :: Name -> ExpQ
241 conE s = return (ConE s)
242
243 litE :: Lit -> ExpQ
244 litE c = return (LitE c)
245
246 appE :: ExpQ -> ExpQ -> ExpQ
247 appE x y = do { a <- x; b <- y; return (AppE a b)}
248
249 appTypeE :: ExpQ -> TypeQ -> ExpQ
250 appTypeE x t = do { a <- x; s <- t; return (AppTypeE a s) }
251
252 parensE :: ExpQ -> ExpQ
253 parensE x = do { x' <- x; return (ParensE x') }
254
255 uInfixE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
256 uInfixE x s y = do { x' <- x; s' <- s; y' <- y;
257 return (UInfixE x' s' y') }
258
259 infixE :: Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
260 infixE (Just x) s (Just y) = do { a <- x; s' <- s; b <- y;
261 return (InfixE (Just a) s' (Just b))}
262 infixE Nothing s (Just y) = do { s' <- s; b <- y;
263 return (InfixE Nothing s' (Just b))}
264 infixE (Just x) s Nothing = do { a <- x; s' <- s;
265 return (InfixE (Just a) s' Nothing)}
266 infixE Nothing s Nothing = do { s' <- s; return (InfixE Nothing s' Nothing) }
267
268 infixApp :: ExpQ -> ExpQ -> ExpQ -> ExpQ
269 infixApp x y z = infixE (Just x) y (Just z)
270 sectionL :: ExpQ -> ExpQ -> ExpQ
271 sectionL x y = infixE (Just x) y Nothing
272 sectionR :: ExpQ -> ExpQ -> ExpQ
273 sectionR x y = infixE Nothing x (Just y)
274
275 lamE :: [PatQ] -> ExpQ -> ExpQ
276 lamE ps e = do ps' <- sequence ps
277 e' <- e
278 return (LamE ps' e')
279
280 -- | Single-arg lambda
281 lam1E :: PatQ -> ExpQ -> ExpQ
282 lam1E p e = lamE [p] e
283
284 lamCaseE :: [MatchQ] -> ExpQ
285 lamCaseE ms = sequence ms >>= return . LamCaseE
286
287 tupE :: [ExpQ] -> ExpQ
288 tupE es = do { es1 <- sequence es; return (TupE es1)}
289
290 unboxedTupE :: [ExpQ] -> ExpQ
291 unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE es1)}
292
293 unboxedSumE :: ExpQ -> SumAlt -> SumArity -> ExpQ
294 unboxedSumE e alt arity = do { e1 <- e; return (UnboxedSumE e1 alt arity) }
295
296 condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
297 condE x y z = do { a <- x; b <- y; c <- z; return (CondE a b c)}
298
299 multiIfE :: [Q (Guard, Exp)] -> ExpQ
300 multiIfE alts = sequence alts >>= return . MultiIfE
301
302 letE :: [DecQ] -> ExpQ -> ExpQ
303 letE ds e = do { ds2 <- sequence ds; e2 <- e; return (LetE ds2 e2) }
304
305 caseE :: ExpQ -> [MatchQ] -> ExpQ
306 caseE e ms = do { e1 <- e; ms1 <- sequence ms; return (CaseE e1 ms1) }
307
308 doE :: [StmtQ] -> ExpQ
309 doE ss = do { ss1 <- sequence ss; return (DoE ss1) }
310
311 mdoE :: [StmtQ] -> ExpQ
312 mdoE ss = do { ss1 <- sequence ss; return (MDoE ss1) }
313
314 compE :: [StmtQ] -> ExpQ
315 compE ss = do { ss1 <- sequence ss; return (CompE ss1) }
316
317 arithSeqE :: RangeQ -> ExpQ
318 arithSeqE r = do { r' <- r; return (ArithSeqE r') }
319
320 listE :: [ExpQ] -> ExpQ
321 listE es = do { es1 <- sequence es; return (ListE es1) }
322
323 sigE :: ExpQ -> TypeQ -> ExpQ
324 sigE e t = do { e1 <- e; t1 <- t; return (SigE e1 t1) }
325
326 recConE :: Name -> [Q (Name,Exp)] -> ExpQ
327 recConE c fs = do { flds <- sequence fs; return (RecConE c flds) }
328
329 recUpdE :: ExpQ -> [Q (Name,Exp)] -> ExpQ
330 recUpdE e fs = do { e1 <- e; flds <- sequence fs; return (RecUpdE e1 flds) }
331
332 stringE :: String -> ExpQ
333 stringE = litE . stringL
334
335 fieldExp :: Name -> ExpQ -> Q (Name, Exp)
336 fieldExp s e = do { e' <- e; return (s,e') }
337
338 -- | @staticE x = [| static x |]@
339 staticE :: ExpQ -> ExpQ
340 staticE = fmap StaticE
341
342 unboundVarE :: Name -> ExpQ
343 unboundVarE s = return (UnboundVarE s)
344
345 labelE :: String -> ExpQ
346 labelE s = return (LabelE s)
347
348 implicitParamVarE :: String -> ExpQ
349 implicitParamVarE n = return (ImplicitParamVarE n)
350
351 -- ** 'arithSeqE' Shortcuts
352 fromE :: ExpQ -> ExpQ
353 fromE x = do { a <- x; return (ArithSeqE (FromR a)) }
354
355 fromThenE :: ExpQ -> ExpQ -> ExpQ
356 fromThenE x y = do { a <- x; b <- y; return (ArithSeqE (FromThenR a b)) }
357
358 fromToE :: ExpQ -> ExpQ -> ExpQ
359 fromToE x y = do { a <- x; b <- y; return (ArithSeqE (FromToR a b)) }
360
361 fromThenToE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
362 fromThenToE x y z = do { a <- x; b <- y; c <- z;
363 return (ArithSeqE (FromThenToR a b c)) }
364
365
366 -------------------------------------------------------------------------------
367 -- * Dec
368
369 valD :: PatQ -> BodyQ -> [DecQ] -> DecQ
370 valD p b ds =
371 do { p' <- p
372 ; ds' <- sequence ds
373 ; b' <- b
374 ; return (ValD p' b' ds')
375 }
376
377 funD :: Name -> [ClauseQ] -> DecQ
378 funD nm cs =
379 do { cs1 <- sequence cs
380 ; return (FunD nm cs1)
381 }
382
383 tySynD :: Name -> [TyVarBndrQ] -> TypeQ -> DecQ
384 tySynD tc tvs rhs =
385 do { tvs1 <- sequenceA tvs
386 ; rhs1 <- rhs
387 ; return (TySynD tc tvs1 rhs1)
388 }
389
390 dataD :: CxtQ -> Name -> [TyVarBndrQ] -> Maybe KindQ -> [ConQ]
391 -> [DerivClauseQ] -> DecQ
392 dataD ctxt tc tvs ksig cons derivs =
393 do
394 ctxt1 <- ctxt
395 tvs1 <- sequenceA tvs
396 ksig1 <- sequenceA ksig
397 cons1 <- sequence cons
398 derivs1 <- sequence derivs
399 return (DataD ctxt1 tc tvs1 ksig1 cons1 derivs1)
400
401 newtypeD :: CxtQ -> Name -> [TyVarBndrQ] -> Maybe KindQ -> ConQ
402 -> [DerivClauseQ] -> DecQ
403 newtypeD ctxt tc tvs ksig con derivs =
404 do
405 ctxt1 <- ctxt
406 tvs1 <- sequenceA tvs
407 ksig1 <- sequenceA ksig
408 con1 <- con
409 derivs1 <- sequence derivs
410 return (NewtypeD ctxt1 tc tvs1 ksig1 con1 derivs1)
411
412 classD :: CxtQ -> Name -> [TyVarBndrQ] -> [FunDep] -> [DecQ] -> DecQ
413 classD ctxt cls tvs fds decs =
414 do
415 tvs1 <- sequenceA tvs
416 decs1 <- sequenceA decs
417 ctxt1 <- ctxt
418 return $ ClassD ctxt1 cls tvs1 fds decs1
419
420 instanceD :: CxtQ -> TypeQ -> [DecQ] -> DecQ
421 instanceD = instanceWithOverlapD Nothing
422
423 instanceWithOverlapD :: Maybe Overlap -> CxtQ -> TypeQ -> [DecQ] -> DecQ
424 instanceWithOverlapD o ctxt ty decs =
425 do
426 ctxt1 <- ctxt
427 decs1 <- sequence decs
428 ty1 <- ty
429 return $ InstanceD o ctxt1 ty1 decs1
430
431
432
433 sigD :: Name -> TypeQ -> DecQ
434 sigD fun ty = liftM (SigD fun) $ ty
435
436 forImpD :: Callconv -> Safety -> String -> Name -> TypeQ -> DecQ
437 forImpD cc s str n ty
438 = do ty' <- ty
439 return $ ForeignD (ImportF cc s str n ty')
440
441 infixLD :: Int -> Name -> DecQ
442 infixLD prec nm = return (InfixD (Fixity prec InfixL) nm)
443
444 infixRD :: Int -> Name -> DecQ
445 infixRD prec nm = return (InfixD (Fixity prec InfixR) nm)
446
447 infixND :: Int -> Name -> DecQ
448 infixND prec nm = return (InfixD (Fixity prec InfixN) nm)
449
450 pragInlD :: Name -> Inline -> RuleMatch -> Phases -> DecQ
451 pragInlD name inline rm phases
452 = return $ PragmaD $ InlineP name inline rm phases
453
454 pragSpecD :: Name -> TypeQ -> Phases -> DecQ
455 pragSpecD n ty phases
456 = do
457 ty1 <- ty
458 return $ PragmaD $ SpecialiseP n ty1 Nothing phases
459
460 pragSpecInlD :: Name -> TypeQ -> Inline -> Phases -> DecQ
461 pragSpecInlD n ty inline phases
462 = do
463 ty1 <- ty
464 return $ PragmaD $ SpecialiseP n ty1 (Just inline) phases
465
466 pragSpecInstD :: TypeQ -> DecQ
467 pragSpecInstD ty
468 = do
469 ty1 <- ty
470 return $ PragmaD $ SpecialiseInstP ty1
471
472 pragRuleD :: String -> [RuleBndrQ] -> ExpQ -> ExpQ -> Phases -> DecQ
473 pragRuleD n bndrs lhs rhs phases
474 = do
475 bndrs1 <- sequence bndrs
476 lhs1 <- lhs
477 rhs1 <- rhs
478 return $ PragmaD $ RuleP n bndrs1 lhs1 rhs1 phases
479
480 pragAnnD :: AnnTarget -> ExpQ -> DecQ
481 pragAnnD target expr
482 = do
483 exp1 <- expr
484 return $ PragmaD $ AnnP target exp1
485
486 pragLineD :: Int -> String -> DecQ
487 pragLineD line file = return $ PragmaD $ LineP line file
488
489 pragCompleteD :: [Name] -> Maybe Name -> DecQ
490 pragCompleteD cls mty = return $ PragmaD $ CompleteP cls mty
491
492 dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe KindQ -> [ConQ]
493 -> [DerivClauseQ] -> DecQ
494 dataInstD ctxt tc tys ksig cons derivs =
495 do
496 ctxt1 <- ctxt
497 tys1 <- sequenceA tys
498 ksig1 <- sequenceA ksig
499 cons1 <- sequenceA cons
500 derivs1 <- sequenceA derivs
501 return (DataInstD ctxt1 tc tys1 ksig1 cons1 derivs1)
502
503 newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe KindQ -> ConQ
504 -> [DerivClauseQ] -> DecQ
505 newtypeInstD ctxt tc tys ksig con derivs =
506 do
507 ctxt1 <- ctxt
508 tys1 <- sequenceA tys
509 ksig1 <- sequenceA ksig
510 con1 <- con
511 derivs1 <- sequence derivs
512 return (NewtypeInstD ctxt1 tc tys1 ksig1 con1 derivs1)
513
514 tySynInstD :: Name -> TySynEqnQ -> DecQ
515 tySynInstD tc eqn =
516 do
517 eqn1 <- eqn
518 return (TySynInstD tc eqn1)
519
520 dataFamilyD :: Name -> [TyVarBndrQ] -> Maybe KindQ -> DecQ
521 dataFamilyD tc tvs kind =
522 do tvs' <- sequenceA tvs
523 kind' <- sequenceA kind
524 return $ DataFamilyD tc tvs' kind'
525
526 openTypeFamilyD :: Name -> [TyVarBndrQ] -> FamilyResultSigQ
527 -> Maybe InjectivityAnn -> DecQ
528 openTypeFamilyD tc tvs res inj =
529 do tvs' <- sequenceA tvs
530 res' <- res
531 return $ OpenTypeFamilyD (TypeFamilyHead tc tvs' res' inj)
532
533 closedTypeFamilyD :: Name -> [TyVarBndrQ] -> FamilyResultSigQ
534 -> Maybe InjectivityAnn -> [TySynEqnQ] -> DecQ
535 closedTypeFamilyD tc tvs result injectivity eqns =
536 do tvs1 <- sequenceA tvs
537 result1 <- result
538 eqns1 <- sequenceA eqns
539 return (ClosedTypeFamilyD (TypeFamilyHead tc tvs1 result1 injectivity) eqns1)
540
541 roleAnnotD :: Name -> [Role] -> DecQ
542 roleAnnotD name roles = return $ RoleAnnotD name roles
543
544 standaloneDerivD :: CxtQ -> TypeQ -> DecQ
545 standaloneDerivD = standaloneDerivWithStrategyD Nothing
546
547 standaloneDerivWithStrategyD :: Maybe DerivStrategyQ -> CxtQ -> TypeQ -> DecQ
548 standaloneDerivWithStrategyD mdsq ctxtq tyq =
549 do
550 mds <- sequenceA mdsq
551 ctxt <- ctxtq
552 ty <- tyq
553 return $ StandaloneDerivD mds ctxt ty
554
555 defaultSigD :: Name -> TypeQ -> DecQ
556 defaultSigD n tyq =
557 do
558 ty <- tyq
559 return $ DefaultSigD n ty
560
561 -- | Pattern synonym declaration
562 patSynD :: Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ
563 patSynD name args dir pat = do
564 args' <- args
565 dir' <- dir
566 pat' <- pat
567 return (PatSynD name args' dir' pat')
568
569 -- | Pattern synonym type signature
570 patSynSigD :: Name -> TypeQ -> DecQ
571 patSynSigD nm ty =
572 do ty' <- ty
573 return $ PatSynSigD nm ty'
574
575 -- | Implicit parameter binding declaration. Can only be used in let
576 -- and where clauses which consist entirely of implicit bindings.
577 implicitParamBindD :: String -> ExpQ -> DecQ
578 implicitParamBindD n e =
579 do
580 e' <- e
581 return $ ImplicitParamBindD n e'
582
583 tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ
584 tySynEqn lhs rhs =
585 do
586 lhs1 <- sequence lhs
587 rhs1 <- rhs
588 return (TySynEqn lhs1 rhs1)
589
590 cxt :: [PredQ] -> CxtQ
591 cxt = sequence
592
593 derivClause :: Maybe DerivStrategyQ -> [PredQ] -> DerivClauseQ
594 derivClause mds p = do mds' <- sequenceA mds
595 p' <- cxt p
596 return $ DerivClause mds' p'
597
598 stockStrategy :: DerivStrategyQ
599 stockStrategy = pure StockStrategy
600
601 anyclassStrategy :: DerivStrategyQ
602 anyclassStrategy = pure AnyclassStrategy
603
604 newtypeStrategy :: DerivStrategyQ
605 newtypeStrategy = pure NewtypeStrategy
606
607 viaStrategy :: TypeQ -> DerivStrategyQ
608 viaStrategy = fmap ViaStrategy
609
610 normalC :: Name -> [BangTypeQ] -> ConQ
611 normalC con strtys = liftM (NormalC con) $ sequence strtys
612
613 recC :: Name -> [VarBangTypeQ] -> ConQ
614 recC con varstrtys = liftM (RecC con) $ sequence varstrtys
615
616 infixC :: Q (Bang, Type) -> Name -> Q (Bang, Type) -> ConQ
617 infixC st1 con st2 = do st1' <- st1
618 st2' <- st2
619 return $ InfixC st1' con st2'
620
621 forallC :: [TyVarBndrQ] -> CxtQ -> ConQ -> ConQ
622 forallC ns ctxt con = do
623 ns' <- sequenceA ns
624 ctxt' <- ctxt
625 con' <- con
626 pure $ ForallC ns' ctxt' con'
627
628 gadtC :: [Name] -> [StrictTypeQ] -> TypeQ -> ConQ
629 gadtC cons strtys ty = liftM2 (GadtC cons) (sequence strtys) ty
630
631 recGadtC :: [Name] -> [VarStrictTypeQ] -> TypeQ -> ConQ
632 recGadtC cons varstrtys ty = liftM2 (RecGadtC cons) (sequence varstrtys) ty
633
634 -------------------------------------------------------------------------------
635 -- * Type
636
637 forallT :: [TyVarBndrQ] -> CxtQ -> TypeQ -> TypeQ
638 forallT tvars ctxt ty = do
639 tvars1 <- sequenceA tvars
640 ctxt1 <- ctxt
641 ty1 <- ty
642 return $ ForallT tvars1 ctxt1 ty1
643
644 varT :: Name -> TypeQ
645 varT = return . VarT
646
647 conT :: Name -> TypeQ
648 conT = return . ConT
649
650 infixT :: TypeQ -> Name -> TypeQ -> TypeQ
651 infixT t1 n t2 = do t1' <- t1
652 t2' <- t2
653 return (InfixT t1' n t2')
654
655 uInfixT :: TypeQ -> Name -> TypeQ -> TypeQ
656 uInfixT t1 n t2 = do t1' <- t1
657 t2' <- t2
658 return (UInfixT t1' n t2')
659
660 parensT :: TypeQ -> TypeQ
661 parensT t = do t' <- t
662 return (ParensT t')
663
664 appT :: TypeQ -> TypeQ -> TypeQ
665 appT t1 t2 = do
666 t1' <- t1
667 t2' <- t2
668 return $ AppT t1' t2'
669
670 arrowT :: TypeQ
671 arrowT = return ArrowT
672
673 listT :: TypeQ
674 listT = return ListT
675
676 litT :: TyLitQ -> TypeQ
677 litT l = fmap LitT l
678
679 tupleT :: Int -> TypeQ
680 tupleT i = return (TupleT i)
681
682 unboxedTupleT :: Int -> TypeQ
683 unboxedTupleT i = return (UnboxedTupleT i)
684
685 unboxedSumT :: SumArity -> TypeQ
686 unboxedSumT arity = return (UnboxedSumT arity)
687
688 sigT :: TypeQ -> KindQ -> TypeQ
689 sigT t k
690 = do
691 t' <- t
692 k' <- k
693 return $ SigT t' k'
694
695 equalityT :: TypeQ
696 equalityT = return EqualityT
697
698 wildCardT :: TypeQ
699 wildCardT = return WildCardT
700
701 implicitParamT :: String -> TypeQ -> TypeQ
702 implicitParamT n t
703 = do
704 t' <- t
705 return $ ImplicitParamT n t'
706
707 {-# DEPRECATED classP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please use 'conT' and 'appT'." #-}
708 classP :: Name -> [Q Type] -> Q Pred
709 classP cla tys
710 = do
711 tysl <- sequence tys
712 return (foldl AppT (ConT cla) tysl)
713
714 {-# DEPRECATED equalP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please see 'equalityT'." #-}
715 equalP :: TypeQ -> TypeQ -> PredQ
716 equalP tleft tright
717 = do
718 tleft1 <- tleft
719 tright1 <- tright
720 eqT <- equalityT
721 return (foldl AppT eqT [tleft1, tright1])
722
723 promotedT :: Name -> TypeQ
724 promotedT = return . PromotedT
725
726 promotedTupleT :: Int -> TypeQ
727 promotedTupleT i = return (PromotedTupleT i)
728
729 promotedNilT :: TypeQ
730 promotedNilT = return PromotedNilT
731
732 promotedConsT :: TypeQ
733 promotedConsT = return PromotedConsT
734
735 noSourceUnpackedness, sourceNoUnpack, sourceUnpack :: SourceUnpackednessQ
736 noSourceUnpackedness = return NoSourceUnpackedness
737 sourceNoUnpack = return SourceNoUnpack
738 sourceUnpack = return SourceUnpack
739
740 noSourceStrictness, sourceLazy, sourceStrict :: SourceStrictnessQ
741 noSourceStrictness = return NoSourceStrictness
742 sourceLazy = return SourceLazy
743 sourceStrict = return SourceStrict
744
745 {-# DEPRECATED isStrict
746 ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ",
747 "Example usage: 'bang noSourceUnpackedness sourceStrict'"] #-}
748 {-# DEPRECATED notStrict
749 ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ",
750 "Example usage: 'bang noSourceUnpackedness noSourceStrictness'"] #-}
751 {-# DEPRECATED unpacked
752 ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ",
753 "Example usage: 'bang sourceUnpack sourceStrict'"] #-}
754 isStrict, notStrict, unpacked :: Q Strict
755 isStrict = bang noSourceUnpackedness sourceStrict
756 notStrict = bang noSourceUnpackedness noSourceStrictness
757 unpacked = bang sourceUnpack sourceStrict
758
759 bang :: SourceUnpackednessQ -> SourceStrictnessQ -> BangQ
760 bang u s = do u' <- u
761 s' <- s
762 return (Bang u' s')
763
764 bangType :: BangQ -> TypeQ -> BangTypeQ
765 bangType = liftM2 (,)
766
767 varBangType :: Name -> BangTypeQ -> VarBangTypeQ
768 varBangType v bt = do (b, t) <- bt
769 return (v, b, t)
770
771 {-# DEPRECATED strictType
772 "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'bangType' instead." #-}
773 strictType :: Q Strict -> TypeQ -> StrictTypeQ
774 strictType = bangType
775
776 {-# DEPRECATED varStrictType
777 "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'varBangType' instead." #-}
778 varStrictType :: Name -> StrictTypeQ -> VarStrictTypeQ
779 varStrictType = varBangType
780
781 -- * Type Literals
782
783 numTyLit :: Integer -> TyLitQ
784 numTyLit n = if n >= 0 then return (NumTyLit n)
785 else fail ("Negative type-level number: " ++ show n)
786
787 strTyLit :: String -> TyLitQ
788 strTyLit s = return (StrTyLit s)
789
790 -------------------------------------------------------------------------------
791 -- * Kind
792
793 plainTV :: Name -> TyVarBndrQ
794 plainTV = pure . PlainTV
795
796 kindedTV :: Name -> KindQ -> TyVarBndrQ
797 kindedTV n = fmap (KindedTV n)
798
799 varK :: Name -> Kind
800 varK = VarT
801
802 conK :: Name -> Kind
803 conK = ConT
804
805 tupleK :: Int -> Kind
806 tupleK = TupleT
807
808 arrowK :: Kind
809 arrowK = ArrowT
810
811 listK :: Kind
812 listK = ListT
813
814 appK :: Kind -> Kind -> Kind
815 appK = AppT
816
817 starK :: KindQ
818 starK = pure StarT
819
820 constraintK :: KindQ
821 constraintK = pure ConstraintT
822
823 -------------------------------------------------------------------------------
824 -- * Type family result
825
826 noSig :: FamilyResultSigQ
827 noSig = pure NoSig
828
829 kindSig :: KindQ -> FamilyResultSigQ
830 kindSig = fmap KindSig
831
832 tyVarSig :: TyVarBndrQ -> FamilyResultSigQ
833 tyVarSig = fmap TyVarSig
834
835 -------------------------------------------------------------------------------
836 -- * Injectivity annotation
837
838 injectivityAnn :: Name -> [Name] -> InjectivityAnn
839 injectivityAnn = TH.InjectivityAnn
840
841 -------------------------------------------------------------------------------
842 -- * Role
843
844 nominalR, representationalR, phantomR, inferR :: Role
845 nominalR = NominalR
846 representationalR = RepresentationalR
847 phantomR = PhantomR
848 inferR = InferR
849
850 -------------------------------------------------------------------------------
851 -- * Callconv
852
853 cCall, stdCall, cApi, prim, javaScript :: Callconv
854 cCall = CCall
855 stdCall = StdCall
856 cApi = CApi
857 prim = Prim
858 javaScript = JavaScript
859
860 -------------------------------------------------------------------------------
861 -- * Safety
862
863 unsafe, safe, interruptible :: Safety
864 unsafe = Unsafe
865 safe = Safe
866 interruptible = Interruptible
867
868 -------------------------------------------------------------------------------
869 -- * FunDep
870
871 funDep :: [Name] -> [Name] -> FunDep
872 funDep = FunDep
873
874 -------------------------------------------------------------------------------
875 -- * RuleBndr
876 ruleVar :: Name -> RuleBndrQ
877 ruleVar = return . RuleVar
878
879 typedRuleVar :: Name -> TypeQ -> RuleBndrQ
880 typedRuleVar n ty = ty >>= return . TypedRuleVar n
881
882 -------------------------------------------------------------------------------
883 -- * AnnTarget
884 valueAnnotation :: Name -> AnnTarget
885 valueAnnotation = ValueAnnotation
886
887 typeAnnotation :: Name -> AnnTarget
888 typeAnnotation = TypeAnnotation
889
890 moduleAnnotation :: AnnTarget
891 moduleAnnotation = ModuleAnnotation
892
893 -------------------------------------------------------------------------------
894 -- * Pattern Synonyms (sub constructs)
895
896 unidir, implBidir :: PatSynDirQ
897 unidir = return Unidir
898 implBidir = return ImplBidir
899
900 explBidir :: [ClauseQ] -> PatSynDirQ
901 explBidir cls = do
902 cls' <- sequence cls
903 return (ExplBidir cls')
904
905 prefixPatSyn :: [Name] -> PatSynArgsQ
906 prefixPatSyn args = return $ PrefixPatSyn args
907
908 recordPatSyn :: [Name] -> PatSynArgsQ
909 recordPatSyn sels = return $ RecordPatSyn sels
910
911 infixPatSyn :: Name -> Name -> PatSynArgsQ
912 infixPatSyn arg1 arg2 = return $ InfixPatSyn arg1 arg2
913
914 --------------------------------------------------------------
915 -- * Useful helper function
916
917 appsE :: [ExpQ] -> ExpQ
918 appsE [] = error "appsE []"
919 appsE [x] = x
920 appsE (x:y:zs) = appsE ( (appE x y) : zs )
921
922 -- | Return the Module at the place of splicing. Can be used as an
923 -- input for 'reifyModule'.
924 thisModule :: Q Module
925 thisModule = do
926 loc <- location
927 return $ Module (mkPkgName $ loc_package loc) (mkModName $ loc_module loc)