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