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