-- |-- TH.Lib contains lots of useful helper functions for-- generating and manipulating Template Haskell termsmoduleLanguage.Haskell.TH.Libwhere-- All of the exports from this module should-- be "public" functions. The main module TH-- re-exports them all.importLanguage.Haskell.TH.Syntax hiding(Role )importqualifiedLanguage.Haskell.TH.Syntax asTHimportControl.Monad(liftM,liftM2)importData.Word(Word8)------------------------------------------------------------ * Type synonyms----------------------------------------------------------typeInfoQ =Q Info typePatQ =Q Pat typeFieldPatQ =Q FieldPat typeExpQ =Q Exp typeTExpQ a =Q (TExp a )typeDecQ =Q Dec typeDecsQ =Q [Dec ]typeConQ =Q Con typeTypeQ =Q Type typeTyLitQ =Q TyLit typeCxtQ =Q Cxt typePredQ =Q Pred typeMatchQ =Q Match typeClauseQ =Q Clause typeBodyQ =Q Body typeGuardQ =Q Guard typeStmtQ =Q Stmt typeRangeQ =Q Range typeStrictTypeQ =Q StrictType typeVarStrictTypeQ =Q VarStrictType typeFieldExpQ =Q FieldExp typeRuleBndrQ =Q RuleBndr typeTySynEqnQ =Q TySynEqn typeRole =TH.Role -- must be defined here for DsMeta to find it------------------------------------------------------------ * Lowercase pattern syntax functions----------------------------------------------------------intPrimL::Integer->Lit intPrimL =IntPrimL wordPrimL::Integer->Lit wordPrimL =WordPrimL floatPrimL::Rational->Lit floatPrimL =FloatPrimL doublePrimL::Rational->Lit doublePrimL =DoublePrimL integerL::Integer->Lit integerL =IntegerL charL::Char->Lit charL =CharL stringL::String->Lit stringL =StringL stringPrimL::[Word8]->Lit stringPrimL =StringPrimL rationalL::Rational->Lit rationalL =RationalL litP::Lit ->PatQ litP l =return(LitP l )varP::Name ->PatQ varP v =return(VarP v )tupP::[PatQ ]->PatQ tupP ps =do{ps1 <-sequenceps ;return(TupP ps1 )}unboxedTupP::[PatQ ]->PatQ unboxedTupP ps =do{ps1 <-sequenceps ;return(UnboxedTupP ps1 )}conP::Name ->[PatQ ]->PatQ conP n ps =dops' <-sequenceps return(ConP n ps' )infixP::PatQ ->Name ->PatQ ->PatQ infixP p1 n p2 =dop1' <-p1 p2' <-p2 return(InfixP p1' n p2' )uInfixP::PatQ ->Name ->PatQ ->PatQ uInfixP p1 n p2 =dop1' <-p1 p2' <-p2 return(UInfixP p1' n p2' )parensP::PatQ ->PatQ parensP p =dop' <-p return(ParensP p' )tildeP::PatQ ->PatQ tildeP p =dop' <-p return(TildeP p' )bangP::PatQ ->PatQ bangP p =dop' <-p return(BangP p' )asP::Name ->PatQ ->PatQ asP n p =dop' <-p return(AsP n p' )wildP::PatQ wildP =returnWildP recP::Name ->[FieldPatQ ]->PatQ recP n fps =dofps' <-sequencefps return(RecP n fps' )listP::[PatQ ]->PatQ listP ps =dops' <-sequenceps return(ListP ps' )sigP::PatQ ->TypeQ ->PatQ sigP p t =dop' <-p t' <-t return(SigP p' t' )viewP::ExpQ ->PatQ ->PatQ viewP e p =doe' <-e p' <-p return(ViewP e' p' )fieldPat::Name ->PatQ ->FieldPatQ fieldPat n p =dop' <-p return(n ,p' )--------------------------------------------------------------------------------- * StmtbindS::PatQ ->ExpQ ->StmtQ bindS p e =liftM2BindS p e letS::[DecQ ]->StmtQ letS ds =do{ds1 <-sequenceds ;return(LetS ds1 )}noBindS::ExpQ ->StmtQ noBindS e =do{e1 <-e ;return(NoBindS e1 )}parS::[[StmtQ ]]->StmtQ parS sss =do{sss1 <-mapMsequencesss ;return(ParS sss1 )}--------------------------------------------------------------------------------- * RangefromR::ExpQ ->RangeQ fromR x =do{a <-x ;return(FromR a )}fromThenR::ExpQ ->ExpQ ->RangeQ fromThenR x y =do{a <-x ;b <-y ;return(FromThenR a b )}fromToR::ExpQ ->ExpQ ->RangeQ fromToR x y =do{a <-x ;b <-y ;return(FromToR a b )}fromThenToR::ExpQ ->ExpQ ->ExpQ ->RangeQ fromThenToR x y z =do{a <-x ;b <-y ;c <-z ;return(FromThenToR a b c )}--------------------------------------------------------------------------------- * BodynormalB::ExpQ ->BodyQ normalB e =do{e1 <-e ;return(NormalB e1 )}guardedB::[Q (Guard ,Exp )]->BodyQ guardedB ges =do{ges' <-sequenceges ;return(GuardedB ges' )}--------------------------------------------------------------------------------- * GuardnormalG::ExpQ ->GuardQ normalG e =do{e1 <-e ;return(NormalG e1 )}normalGE::ExpQ ->ExpQ ->Q (Guard ,Exp )normalGE g e =do{g1 <-g ;e1 <-e ;return(NormalG g1 ,e1 )}patG::[StmtQ ]->GuardQ patG ss =do{ss' <-sequencess ;return(PatG ss' )}patGE::[StmtQ ]->ExpQ ->Q (Guard ,Exp )patGE ss e =do{ss' <-sequencess ;e' <-e ;return(PatG ss' ,e' )}--------------------------------------------------------------------------------- * Match and Clause-- | Use with 'caseE'match::PatQ ->BodyQ ->[DecQ ]->MatchQ match p rhs ds =do{p' <-p ;r' <-rhs ;ds' <-sequenceds ;return(Match p' r' ds' )}-- | Use with 'funD'clause::[PatQ ]->BodyQ ->[DecQ ]->ClauseQ clause ps r ds =do{ps' <-sequenceps ;r' <-r ;ds' <-sequenceds ;return(Clause ps' r' ds' )}----------------------------------------------------------------------------- * Exp-- | Dynamically binding a variable (unhygenic)dyn::String->ExpQ dyn s =return(VarE (mkName s ))global::Name ->ExpQ {-# DEPRECATED global "Use varE instead" #-}-- Trac #8656; I have no idea why this function is duplicatedglobal s =return(VarE s )varE::Name ->ExpQ varE s =return(VarE s )conE::Name ->ExpQ conE s =return(ConE s )litE::Lit ->ExpQ litE c =return(LitE c )appE::ExpQ ->ExpQ ->ExpQ appE x y =do{a <-x ;b <-y ;return(AppE a b )}parensE::ExpQ ->ExpQ parensE x =do{x' <-x ;return(ParensE x' )}uInfixE::ExpQ ->ExpQ ->ExpQ ->ExpQ uInfixE x s y =do{x' <-x ;s' <-s ;y' <-y ;return(UInfixE x' s' y' )}infixE::MaybeExpQ ->ExpQ ->MaybeExpQ ->ExpQ infixE (Justx )s (Justy )=do{a <-x ;s' <-s ;b <-y ;return(InfixE (Justa )s' (Justb ))}infixENothings (Justy )=do{s' <-s ;b <-y ;return(InfixE Nothings' (Justb ))}infixE(Justx )s Nothing=do{a <-x ;s' <-s ;return(InfixE (Justa )s' Nothing)}infixENothings Nothing=do{s' <-s ;return(InfixE Nothings' Nothing)}infixApp::ExpQ ->ExpQ ->ExpQ ->ExpQ infixApp x y z =infixE (Justx )y (Justz )sectionL::ExpQ ->ExpQ ->ExpQ sectionL x y =infixE (Justx )y NothingsectionR::ExpQ ->ExpQ ->ExpQ sectionR x y =infixE Nothingx (Justy )lamE::[PatQ ]->ExpQ ->ExpQ lamE ps e =dops' <-sequenceps e' <-e return(LamE ps' e' )-- | Single-arg lambdalam1E::PatQ ->ExpQ ->ExpQ lam1E p e =lamE [p ]e lamCaseE::[MatchQ ]->ExpQ lamCaseE ms =sequencems >>=return.LamCaseE tupE::[ExpQ ]->ExpQ tupE es =do{es1 <-sequencees ;return(TupE es1 )}unboxedTupE::[ExpQ ]->ExpQ unboxedTupE es =do{es1 <-sequencees ;return(UnboxedTupE es1 )}condE::ExpQ ->ExpQ ->ExpQ ->ExpQ condE x y z =do{a <-x ;b <-y ;c <-z ;return(CondE a b c )}multiIfE::[Q (Guard ,Exp )]->ExpQ multiIfE alts =sequencealts >>=return.MultiIfE letE::[DecQ ]->ExpQ ->ExpQ letE ds e =do{ds2 <-sequenceds ;e2 <-e ;return(LetE ds2 e2 )}caseE::ExpQ ->[MatchQ ]->ExpQ caseE e ms =do{e1 <-e ;ms1 <-sequencems ;return(CaseE e1 ms1 )}doE::[StmtQ ]->ExpQ doE ss =do{ss1 <-sequencess ;return(DoE ss1 )}compE::[StmtQ ]->ExpQ compE ss =do{ss1 <-sequencess ;return(CompE ss1 )}arithSeqE::RangeQ ->ExpQ arithSeqE r =do{r' <-r ;return(ArithSeqE r' )}listE::[ExpQ ]->ExpQ listE es =do{es1 <-sequencees ;return(ListE es1 )}sigE::ExpQ ->TypeQ ->ExpQ sigE e t =do{e1 <-e ;t1 <-t ;return(SigE e1 t1 )}recConE::Name ->[Q (Name ,Exp )]->ExpQ recConE c fs =do{flds <-sequencefs ;return(RecConE c flds )}recUpdE::ExpQ ->[Q (Name ,Exp )]->ExpQ recUpdE e fs =do{e1 <-e ;flds <-sequencefs ;return(RecUpdE e1 flds )}stringE::String->ExpQ stringE =litE .stringL fieldExp::Name ->ExpQ ->Q (Name ,Exp )fieldExp s e =do{e' <-e ;return(s ,e' )}-- | @staticE x = [| static x |]@staticE::ExpQ ->ExpQ staticE =fmapStaticE -- ** 'arithSeqE' ShortcutsfromE::ExpQ ->ExpQ fromE x =do{a <-x ;return(ArithSeqE (FromR a ))}fromThenE::ExpQ ->ExpQ ->ExpQ fromThenE x y =do{a <-x ;b <-y ;return(ArithSeqE (FromThenR a b ))}fromToE::ExpQ ->ExpQ ->ExpQ fromToE x y =do{a <-x ;b <-y ;return(ArithSeqE (FromToR a b ))}fromThenToE::ExpQ ->ExpQ ->ExpQ ->ExpQ fromThenToE x y z =do{a <-x ;b <-y ;c <-z ;return(ArithSeqE (FromThenToR a b c ))}--------------------------------------------------------------------------------- * DecvalD::PatQ ->BodyQ ->[DecQ ]->DecQ valD p b ds =do{p' <-p ;ds' <-sequenceds ;b' <-b ;return(ValD p' b' ds' )}funD::Name ->[ClauseQ ]->DecQ funD nm cs =do{cs1 <-sequencecs ;return(FunD nm cs1 )}tySynD::Name ->[TyVarBndr ]->TypeQ ->DecQ tySynD tc tvs rhs =do{rhs1 <-rhs ;return(TySynD tc tvs rhs1 )}dataD::CxtQ ->Name ->[TyVarBndr ]->[ConQ ]->[Name ]->DecQ dataD ctxt tc tvs cons derivs =doctxt1 <-ctxt cons1 <-sequencecons return(DataD ctxt1 tc tvs cons1 derivs )newtypeD::CxtQ ->Name ->[TyVarBndr ]->ConQ ->[Name ]->DecQ newtypeD ctxt tc tvs con derivs =doctxt1 <-ctxt con1 <-con return(NewtypeD ctxt1 tc tvs con1 derivs )classD::CxtQ ->Name ->[TyVarBndr ]->[FunDep ]->[DecQ ]->DecQ classD ctxt cls tvs fds decs =dodecs1 <-sequencedecs ctxt1 <-ctxt return$ClassD ctxt1 cls tvs fds decs1 instanceD::CxtQ ->TypeQ ->[DecQ ]->DecQ instanceD ctxt ty decs =doctxt1 <-ctxt decs1 <-sequencedecs ty1 <-ty return$InstanceD ctxt1 ty1 decs1 sigD::Name ->TypeQ ->DecQ sigD fun ty =liftM(SigD fun )$ty forImpD::Callconv ->Safety ->String->Name ->TypeQ ->DecQ forImpD cc s str n ty =doty' <-ty return$ForeignD (ImportF cc s str n ty' )infixLD::Int->Name ->DecQ infixLD prec nm =return(InfixD (Fixity prec InfixL )nm )infixRD::Int->Name ->DecQ infixRD prec nm =return(InfixD (Fixity prec InfixR )nm )infixND::Int->Name ->DecQ infixND prec nm =return(InfixD (Fixity prec InfixN )nm )pragInlD::Name ->Inline ->RuleMatch ->Phases ->DecQ pragInlD name inline rm phases =return$PragmaD $InlineP name inline rm phases pragSpecD::Name ->TypeQ ->Phases ->DecQ pragSpecD n ty phases =doty1 <-ty return$PragmaD $SpecialiseP n ty1 Nothingphases pragSpecInlD::Name ->TypeQ ->Inline ->Phases ->DecQ pragSpecInlD n ty inline phases =doty1 <-ty return$PragmaD $SpecialiseP n ty1 (Justinline )phases pragSpecInstD::TypeQ ->DecQ pragSpecInstD ty =doty1 <-ty return$PragmaD $SpecialiseInstP ty1 pragRuleD::String->[RuleBndrQ ]->ExpQ ->ExpQ ->Phases ->DecQ pragRuleD n bndrs lhs rhs phases =dobndrs1 <-sequencebndrs lhs1 <-lhs rhs1 <-rhs return$PragmaD $RuleP n bndrs1 lhs1 rhs1 phases pragAnnD::AnnTarget ->ExpQ ->DecQ pragAnnD target expr =doexp1 <-expr return$PragmaD $AnnP target exp1 pragLineD::Int->String->DecQ pragLineD line file =return$PragmaD $LineP line file familyNoKindD::FamFlavour ->Name ->[TyVarBndr ]->DecQ familyNoKindD flav tc tvs =return$FamilyD flav tc tvs NothingfamilyKindD::FamFlavour ->Name ->[TyVarBndr ]->Kind ->DecQ familyKindD flav tc tvs k =return$FamilyD flav tc tvs (Justk )dataInstD::CxtQ ->Name ->[TypeQ ]->[ConQ ]->[Name ]->DecQ dataInstD ctxt tc tys cons derivs =doctxt1 <-ctxt tys1 <-sequencetys cons1 <-sequencecons return(DataInstD ctxt1 tc tys1 cons1 derivs )newtypeInstD::CxtQ ->Name ->[TypeQ ]->ConQ ->[Name ]->DecQ newtypeInstD ctxt tc tys con derivs =doctxt1 <-ctxt tys1 <-sequencetys con1 <-con return(NewtypeInstD ctxt1 tc tys1 con1 derivs )tySynInstD::Name ->TySynEqnQ ->DecQ tySynInstD tc eqn =doeqn1 <-eqn return(TySynInstD tc eqn1 )closedTypeFamilyNoKindD::Name ->[TyVarBndr ]->[TySynEqnQ ]->DecQ closedTypeFamilyNoKindD tc tvs eqns =doeqns1 <-sequenceeqns return(ClosedTypeFamilyD tc tvs Nothingeqns1 )closedTypeFamilyKindD::Name ->[TyVarBndr ]->Kind ->[TySynEqnQ ]->DecQ closedTypeFamilyKindD tc tvs kind eqns =doeqns1 <-sequenceeqns return(ClosedTypeFamilyD tc tvs (Justkind )eqns1 )roleAnnotD::Name ->[Role ]->DecQ roleAnnotD name roles =return$RoleAnnotD name roles standaloneDerivD::CxtQ ->TypeQ ->DecQ standaloneDerivD ctxtq tyq =doctxt <-ctxtq ty <-tyq return$StandaloneDerivD ctxt ty defaultSigD::Name ->TypeQ ->DecQ defaultSigD n tyq =doty <-tyq return$DefaultSigD n ty tySynEqn::[TypeQ ]->TypeQ ->TySynEqnQ tySynEqn lhs rhs =dolhs1 <-sequencelhs rhs1 <-rhs return(TySynEqn lhs1 rhs1 )cxt::[PredQ ]->CxtQ cxt =sequencenormalC::Name ->[StrictTypeQ ]->ConQ normalC con strtys =liftM(NormalC con )$sequencestrtys recC::Name ->[VarStrictTypeQ ]->ConQ recC con varstrtys =liftM(RecC con )$sequencevarstrtys infixC::Q (Strict ,Type )->Name ->Q (Strict ,Type )->ConQ infixC st1 con st2 =dost1' <-st1 st2' <-st2 return$InfixC st1' con st2' forallC::[TyVarBndr ]->CxtQ ->ConQ ->ConQ forallC ns ctxt con =liftM2(ForallC ns )ctxt con --------------------------------------------------------------------------------- * TypeforallT::[TyVarBndr ]->CxtQ ->TypeQ ->TypeQ forallT tvars ctxt ty =doctxt1 <-ctxt ty1 <-ty return$ForallT tvars ctxt1 ty1 varT::Name ->TypeQ varT =return.VarT conT::Name ->TypeQ conT =return.ConT appT::TypeQ ->TypeQ ->TypeQ appT t1 t2 =dot1' <-t1 t2' <-t2 return$AppT t1' t2' arrowT::TypeQ arrowT =returnArrowT listT::TypeQ listT =returnListT litT::TyLitQ ->TypeQ litT l =fmapLitT l tupleT::Int->TypeQ tupleT i =return(TupleT i )unboxedTupleT::Int->TypeQ unboxedTupleT i =return(UnboxedTupleT i )sigT::TypeQ ->Kind ->TypeQ sigT t k =dot' <-t return$SigT t' k equalityT::TypeQ equalityT =returnEqualityT {-# DEPRECATED classP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please use 'conT' and 'appT'." #-}classP::Name ->[Q Type ]->Q Pred classP cla tys =dotysl <-sequencetys return(foldlAppT (ConT cla )tysl ){-# DEPRECATED equalP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please see 'equalityT'." #-}equalP::TypeQ ->TypeQ ->PredQ equalP tleft tright =dotleft1 <-tleft tright1 <-tright eqT <-equalityT return(foldlAppT eqT [tleft1 ,tright1 ])promotedT::Name ->TypeQ promotedT =return.PromotedT promotedTupleT::Int->TypeQ promotedTupleT i =return(PromotedTupleT i )promotedNilT::TypeQ promotedNilT =returnPromotedNilT promotedConsT::TypeQ promotedConsT =returnPromotedConsT isStrict,notStrict,unpacked::Q Strict isStrict =return$IsStrict notStrict =return$NotStrict unpacked =returnUnpacked strictType::Q Strict ->TypeQ ->StrictTypeQ strictType =liftM2(,)varStrictType::Name ->StrictTypeQ ->VarStrictTypeQ varStrictType v st =do(s ,t )<-st return(v ,s ,t )-- * Type LiteralsnumTyLit::Integer->TyLitQ numTyLit n =ifn >=0thenreturn(NumTyLit n )elsefail("Negative type-level number: "++shown )strTyLit::String->TyLitQ strTyLit s =return(StrTyLit s )--------------------------------------------------------------------------------- * KindplainTV::Name ->TyVarBndr plainTV =PlainTV kindedTV::Name ->Kind ->TyVarBndr kindedTV =KindedTV varK::Name ->Kind varK =VarT conK::Name ->Kind conK =ConT tupleK::Int->Kind tupleK =TupleT arrowK::Kind arrowK =ArrowT listK::Kind listK =ListT appK::Kind ->Kind ->Kind appK =AppT starK::Kind starK =StarT constraintK::Kind constraintK =ConstraintT --------------------------------------------------------------------------------- * RolenominalR,representationalR,phantomR,inferR::Role nominalR =NominalR representationalR =RepresentationalR phantomR =PhantomR inferR =InferR --------------------------------------------------------------------------------- * CallconvcCall,stdCall,cApi,prim,javaScript::Callconv cCall =CCall stdCall =StdCall cApi =CApi prim =Prim javaScript =JavaScript --------------------------------------------------------------------------------- * Safetyunsafe,safe,interruptible::Safety unsafe =Unsafe safe =Safe interruptible =Interruptible --------------------------------------------------------------------------------- * FunDepfunDep::[Name ]->[Name ]->FunDep funDep =FunDep --------------------------------------------------------------------------------- * FamFlavourtypeFam,dataFam::FamFlavour typeFam =TypeFam dataFam =DataFam --------------------------------------------------------------------------------- * RuleBndrruleVar::Name ->RuleBndrQ ruleVar =return.RuleVar typedRuleVar::Name ->TypeQ ->RuleBndrQ typedRuleVar n ty =ty >>=return.TypedRuleVar n --------------------------------------------------------------------------------- * AnnTargetvalueAnnotation::Name ->AnnTarget valueAnnotation =ValueAnnotation typeAnnotation::Name ->AnnTarget typeAnnotation =TypeAnnotation moduleAnnotation::AnnTarget moduleAnnotation =ModuleAnnotation ---------------------------------------------------------------- * Useful helper functionappsE::[ExpQ ]->ExpQ appsE []=error"appsE []"appsE[x ]=x appsE(x :y :zs )=appsE ((appE x y ):zs )-- | Return the Module at the place of splicing. Can be used as an-- input for 'reifyModule'.thisModule::Q Module thisModule =doloc <-location return$Module (mkPkgName $loc_package loc )(mkModName $loc_module loc )