diff options
| -rw-r--r-- | compiler/deSugar/DsMeta.hs | 183 | ||||
| -rw-r--r-- | compiler/prelude/THNames.hs | 124 | ||||
| -rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Lib.hs | 836 | ||||
| -rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs | 936 | ||||
| -rw-r--r-- | libraries/template-haskell/changelog.md | 8 | ||||
| -rw-r--r-- | libraries/template-haskell/template-haskell.cabal | 2 | ||||
| -rw-r--r-- | testsuite/tests/quotes/TH_localname.stderr | 2 | ||||
| -rw-r--r-- | testsuite/tests/th/T13642.hs | 4 | ||||
| -rw-r--r-- | testsuite/tests/th/T13642.stderr | 4 | ||||
| -rw-r--r-- | testsuite/tests/th/T7276.stderr | 4 | ||||
| -rw-r--r-- | testsuite/tests/th/all.T | 2 |
11 files changed, 1117 insertions, 988 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index c6799813df..e732ce56b0 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -307,7 +307,7 @@ repRoleD (L loc (RoleAnnotDecl tycon roles)) ; return (loc, dec) } ------------------------- -repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr] +repDataDefn :: Core TH.Name -> Core [TH.TyVarBndrQ] -> Maybe (Core [TH.TypeQ]) -> HsDataDefn GhcRn -> DsM (Core TH.DecQ) @@ -318,20 +318,20 @@ repDataDefn tc bndrs opt_tys ; derivs1 <- repDerivs mb_derivs ; case (new_or_data, cons) of (NewType, [con]) -> do { con' <- repC con - ; ksig' <- repMaybeLKind ksig + ; ksig' <- repMaybeLTy ksig ; repNewtype cxt1 tc bndrs opt_tys ksig' con' derivs1 } (NewType, _) -> failWithDs (text "Multiple constructors for newtype:" <+> pprQuotedList (getConNames $ unLoc $ head cons)) - (DataType, _) -> do { ksig' <- repMaybeLKind ksig + (DataType, _) -> do { ksig' <- repMaybeLTy ksig ; consL <- mapM repC cons ; cons1 <- coreList conQTyConName consL ; repData cxt1 tc bndrs opt_tys ksig' cons1 derivs1 } } -repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr] +repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ] -> LHsType GhcRn -> DsM (Core TH.DecQ) repSynDecl tc bndrs ty @@ -373,9 +373,9 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info, } -- | Represent result signature of a type family -repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSig) +repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSigQ) repFamilyResultSig NoSig = repNoSig -repFamilyResultSig (KindSig ki) = do { ki' <- repLKind ki +repFamilyResultSig (KindSig ki) = do { ki' <- repLTy ki ; repKindSig ki' } repFamilyResultSig (TyVarSig bndr) = do { bndr' <- repTyVarBndr bndr ; repTyVarSig bndr' } @@ -384,12 +384,12 @@ repFamilyResultSig (TyVarSig bndr) = do { bndr' <- repTyVarBndr bndr -- where the result signature can be either missing or a kind but never a named -- result variable. repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn - -> DsM (Core (Maybe TH.Kind)) + -> DsM (Core (Maybe TH.KindQ)) repFamilyResultSigToMaybeKind NoSig = - do { coreNothing kindTyConName } + do { coreNothing kindQTyConName } repFamilyResultSigToMaybeKind (KindSig ki) = - do { ki' <- repLKind ki - ; coreJust kindTyConName ki' } + do { ki' <- repLTy ki + ; coreJust kindQTyConName ki' } repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind" -- | Represent injectivity annotation of a type family @@ -769,7 +769,7 @@ rep_wc_ty_sig mk_sig loc sig_ty nm = do { nm1 <- lookupLOcc nm ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) ; repTyVarBndrWithKind tv name } - ; th_explicit_tvs <- repList tyVarBndrTyConName rep_in_scope_tv + ; th_explicit_tvs <- repList tyVarBndrQTyConName rep_in_scope_tv explicit_tvs -- NB: Don't pass any implicit type variables to repList above -- See Note [Don't quantify implicit type variables in quotes] @@ -864,7 +864,7 @@ addSimpleTyVarBinds names thing_inside ; wrapGenSyms fresh_names term } addTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added - -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env + -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -- action in the ext env -> DsM (Core (TH.Q a)) -- gensym a list of type variables and enter them into the meta environment; -- the computations passed as the second argument is executed in that extended @@ -875,7 +875,7 @@ addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs }) m ; fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs) ; let fresh_names = fresh_imp_names ++ fresh_exp_names ; term <- addBinds fresh_names $ - do { kbs <- repList tyVarBndrTyConName mk_tv_bndr + do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr (exp_tvs `zip` fresh_exp_names) ; m kbs } ; wrapGenSyms fresh_names term } @@ -883,7 +883,7 @@ addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs }) m mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) addTyClTyVarBinds :: LHsQTyVars GhcRn - -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) + -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -> DsM (Core (TH.Q a)) -- Used for data/newtype declarations, and family instances, @@ -899,29 +899,31 @@ addTyClTyVarBinds tvs m -- This makes things work for family declarations ; term <- addBinds freshNames $ - do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvExplicit tvs) + do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr + (hsQTvExplicit tvs) ; m kbs } ; wrapGenSyms freshNames term } where + mk_tv_bndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ) mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv) ; repTyVarBndrWithKind tv v } -- Produce kinded binder constructors from the Haskell tyvar binders -- repTyVarBndrWithKind :: LHsTyVarBndr GhcRn - -> Core TH.Name -> DsM (Core TH.TyVarBndr) + -> Core TH.Name -> DsM (Core TH.TyVarBndrQ) repTyVarBndrWithKind (L _ (UserTyVar _)) nm = repPlainTV nm repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm - = repLKind ki >>= repKindedTV nm + = repLTy ki >>= repKindedTV nm -- | Represent a type variable binder -repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndr) +repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ) repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm ; repPlainTV nm' } repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm - ; ki' <- repLKind ki + ; ki' <- repLTy ki ; repKindedTV nm' ki' } -- represent a type context @@ -995,6 +997,8 @@ repTy ty@(HsForAllTy {}) = repForall ty repTy ty@(HsQualTy {}) = repForall ty repTy (HsTyVar _ (L _ n)) + | isLiftedTypeKindTyConName n = repTStar + | n `hasKey` constraintKindTyConKey = repTConstraint | isTvOcc occ = do tv1 <- lookupOcc n repTvar tv1 | isDataOcc occ = do tc1 <- lookupOcc n @@ -1043,7 +1047,7 @@ repTy (HsEqTy t1 t2) = do repTapps eq [t1', t2'] repTy (HsKindSig t k) = do t1 <- repLTy t - k1 <- repLKind k + k1 <- repLTy k repTSig t1 k1 repTy (HsSpliceTy splice _) = repSplice splice repTy (HsExplicitListTy _ _ tys) = do @@ -1067,59 +1071,14 @@ repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s ; rep2 strTyLitName [s'] } --- represent a kind --- --- It would be great to scrap this function in favor of repLTy, since Types --- and Kinds are the same things. We have not done so yet for engineering --- reasons, as repLTy returns a monadic TypeQ, whereas repLKind returns a pure --- Kind, so in order to replace repLKind with repLTy, we'd need to go through --- and purify repLTy and every monadic function it calls. This is the subject --- GHC Trac #11785. -repLKind :: LHsKind GhcRn -> DsM (Core TH.Kind) -repLKind ki - = do { let (kis, ki') = splitHsFunType ki - ; kis_rep <- mapM repLKind kis - ; ki'_rep <- repNonArrowLKind ki' - ; kcon <- repKArrow - ; let f k1 k2 = repKApp kcon k1 >>= flip repKApp k2 - ; foldrM f ki'_rep kis_rep - } - --- | Represent a kind wrapped in a Maybe -repMaybeLKind :: Maybe (LHsKind GhcRn) - -> DsM (Core (Maybe TH.Kind)) -repMaybeLKind Nothing = - do { coreNothing kindTyConName } -repMaybeLKind (Just ki) = - do { ki' <- repLKind ki - ; coreJust kindTyConName ki' } - -repNonArrowLKind :: LHsKind GhcRn -> DsM (Core TH.Kind) -repNonArrowLKind (L _ ki) = repNonArrowKind ki - -repNonArrowKind :: HsKind GhcRn -> DsM (Core TH.Kind) -repNonArrowKind (HsTyVar _ (L _ name)) - | isLiftedTypeKindTyConName name = repKStar - | name `hasKey` constraintKindTyConKey = repKConstraint - | isTvOcc (nameOccName name) = lookupOcc name >>= repKVar - | otherwise = lookupOcc name >>= repKCon -repNonArrowKind (HsAppTy f a) = do { f' <- repLKind f - ; a' <- repLKind a - ; repKApp f' a' - } -repNonArrowKind (HsListTy k) = do { k' <- repLKind k - ; kcon <- repKList - ; repKApp kcon k' - } -repNonArrowKind (HsTupleTy _ ks) = do { ks' <- mapM repLKind ks - ; kcon <- repKTuple (length ks) - ; repKApps kcon ks' - } -repNonArrowKind (HsKindSig k sort) = do { k' <- repLKind k - ; sort' <- repLKind sort - ; repKSig k' sort' - } -repNonArrowKind k = notHandled "Exotic form of kind" (ppr k) +-- | Represent a type wrapped in a Maybe +repMaybeLTy :: Maybe (LHsKind GhcRn) + -> DsM (Core (Maybe TH.TypeQ)) +repMaybeLTy Nothing = + do { coreNothing kindQTyConName } +repMaybeLTy (Just ki) = + do { ki' <- repLTy ki + ; coreJust kindQTyConName ki' } repRole :: Located (Maybe Role) -> DsM (Core TH.Role) repRole (L _ (Just Nominal)) = rep2 nominalRName [] @@ -2045,8 +2004,8 @@ repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds] repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ) repFun (MkC nm) (MkC b) = rep2 funDName [nm, b] -repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] - -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind) +repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ] + -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.KindQ) -> Core [TH.ConQ] -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ) repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC cons) (MkC derivs) = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs] @@ -2054,8 +2013,8 @@ repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC cons) (MkC derivs) = rep2 dataInstDName [cxt, nm, tys, ksig, cons, derivs] -repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] - -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind) +repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ] + -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.KindQ) -> Core TH.ConQ -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ) repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC con) (MkC derivs) @@ -2064,7 +2023,7 @@ repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC con) (MkC derivs) = rep2 newtypeInstDName [cxt, nm, tys, ksig, con, derivs] -repTySyn :: Core TH.Name -> Core [TH.TyVarBndr] +repTySyn :: Core TH.Name -> Core [TH.TyVarBndrQ] -> Core TH.TypeQ -> DsM (Core TH.DecQ) repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs] @@ -2104,7 +2063,7 @@ repOverlap mb = just = coreJust overlapTyConName -repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] +repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ] -> Core [TH.FunDep] -> Core [TH.DecQ] -> DsM (Core TH.DecQ) repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) @@ -2149,22 +2108,22 @@ repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ) repTySynInst (MkC nm) (MkC eqn) = rep2 tySynInstDName [nm, eqn] -repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndr] - -> Core (Maybe TH.Kind) -> DsM (Core TH.DecQ) +repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndrQ] + -> Core (Maybe TH.KindQ) -> DsM (Core TH.DecQ) repDataFamilyD (MkC nm) (MkC tvs) (MkC kind) = rep2 dataFamilyDName [nm, tvs, kind] repOpenFamilyD :: Core TH.Name - -> Core [TH.TyVarBndr] - -> Core TH.FamilyResultSig + -> Core [TH.TyVarBndrQ] + -> Core TH.FamilyResultSigQ -> Core (Maybe TH.InjectivityAnn) -> DsM (Core TH.DecQ) repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj) = rep2 openTypeFamilyDName [nm, tvs, result, inj] repClosedFamilyD :: Core TH.Name - -> Core [TH.TyVarBndr] - -> Core TH.FamilyResultSig + -> Core [TH.TyVarBndrQ] + -> Core TH.FamilyResultSigQ -> Core (Maybe TH.InjectivityAnn) -> Core [TH.TySynEqnQ] -> DsM (Core TH.DecQ) @@ -2250,7 +2209,7 @@ repConstr _ _ _ = ------------ Types ------------------- -repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ +repTForall :: Core [TH.TyVarBndrQ] -> Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ) repTForall (MkC tvars) (MkC ctxt) (MkC ty) = rep2 forallTName [tvars, ctxt, ty] @@ -2265,7 +2224,7 @@ repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ) repTapps f [] = return f repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts } -repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ) +repTSig :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ) repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki] repTequality :: DsM (Core TH.TypeQ) @@ -2285,6 +2244,12 @@ repTLit (MkC lit) = rep2 litTName [lit] repTWildCard :: DsM (Core TH.TypeQ) repTWildCard = rep2 wildCardTName [] +repTStar :: DsM (Core TH.TypeQ) +repTStar = rep2 starKName [] + +repTConstraint :: DsM (Core TH.TypeQ) +repTConstraint = rep2 constraintKName [] + --------- Type constructors -------------- repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ) @@ -2324,56 +2289,24 @@ repPromotedNilTyCon = rep2 promotedNilTName [] repPromotedConsTyCon :: DsM (Core TH.TypeQ) repPromotedConsTyCon = rep2 promotedConsTName [] ------------- Kinds ------------------- +------------ TyVarBndrs ------------------- -repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr) +repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndrQ) repPlainTV (MkC nm) = rep2 plainTVName [nm] -repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr) +repKindedTV :: Core TH.Name -> Core TH.KindQ -> DsM (Core TH.TyVarBndrQ) repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki] -repKVar :: Core TH.Name -> DsM (Core TH.Kind) -repKVar (MkC s) = rep2 varKName [s] - -repKCon :: Core TH.Name -> DsM (Core TH.Kind) -repKCon (MkC s) = rep2 conKName [s] - -repKTuple :: Int -> DsM (Core TH.Kind) -repKTuple i = do dflags <- getDynFlags - rep2 tupleKName [mkIntExprInt dflags i] - -repKArrow :: DsM (Core TH.Kind) -repKArrow = rep2 arrowKName [] - -repKList :: DsM (Core TH.Kind) -repKList = rep2 listKName [] - -repKApp :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind) -repKApp (MkC k1) (MkC k2) = rep2 appKName [k1, k2] - -repKApps :: Core TH.Kind -> [Core TH.Kind] -> DsM (Core TH.Kind) -repKApps f [] = return f -repKApps f (k:ks) = do { f' <- repKApp f k; repKApps f' ks } - -repKStar :: DsM (Core TH.Kind) -repKStar = rep2 starKName [] - -repKConstraint :: DsM (Core TH.Kind) -repKConstraint = rep2 constraintKName [] - -repKSig :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind) -repKSig (MkC k) (MkC sort) = rep2 sigTDataConName [k, sort] - ---------------------------------------------------------- -- Type family result signature -repNoSig :: DsM (Core TH.FamilyResultSig) +repNoSig :: DsM (Core TH.FamilyResultSigQ) repNoSig = rep2 noSigName [] -repKindSig :: Core TH.Kind -> DsM (Core TH.FamilyResultSig) +repKindSig :: Core TH.KindQ -> DsM (Core TH.FamilyResultSigQ) repKindSig (MkC ki) = rep2 kindSigName [ki] -repTyVarSig :: Core TH.TyVarBndr -> DsM (Core TH.FamilyResultSig) +repTyVarSig :: Core TH.TyVarBndrQ -> DsM (Core TH.FamilyResultSigQ) repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr] ---------------------------------------------------------- diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs index 85362434cc..4128ab375e 100644 --- a/compiler/prelude/THNames.hs +++ b/compiler/prelude/THNames.hs @@ -95,7 +95,7 @@ templateHaskellNames = [ -- Type forallTName, varTName, conTName, appTName, equalityTName, tupleTName, unboxedTupleTName, unboxedSumTName, - arrowTName, listTName, sigTName, sigTDataConName, litTName, + arrowTName, listTName, sigTName, litTName, promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName, wildCardTName, -- TyLit @@ -152,10 +152,10 @@ templateHaskellNames = [ clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName, stmtQTyConName, decQTyConName, conQTyConName, bangTypeQTyConName, varBangTypeQTyConName, typeQTyConName, expTyConName, decTyConName, - typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName, + typeTyConName, tyVarBndrQTyConName, matchTyConName, clauseTyConName, patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName, predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName, - roleTyConName, tExpTyConName, injAnnTyConName, kindTyConName, + roleTyConName, tExpTyConName, injAnnTyConName, kindQTyConName, overlapTyConName, derivClauseQTyConName, derivStrategyTyConName, -- Quasiquoting @@ -163,7 +163,7 @@ templateHaskellNames = [ thSyn, thLib, qqLib :: Module thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax") -thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib") +thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib.Internal") qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote") mkTHModule :: FastString -> Module @@ -184,9 +184,9 @@ liftClassName = thCls (fsLit "Lift") liftClassKey qTyConName, nameTyConName, fieldExpTyConName, patTyConName, fieldPatTyConName, expTyConName, decTyConName, typeTyConName, - tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName, - predTyConName, tExpTyConName, injAnnTyConName, kindTyConName, - overlapTyConName, derivStrategyTyConName :: Name + matchTyConName, clauseTyConName, funDepTyConName, predTyConName, + tExpTyConName, injAnnTyConName, overlapTyConName, + derivStrategyTyConName :: Name qTyConName = thTc (fsLit "Q") qTyConKey nameTyConName = thTc (fsLit "Name") nameTyConKey fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey @@ -195,14 +195,12 @@ fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey expTyConName = thTc (fsLit "Exp") expTyConKey decTyConName = thTc (fsLit "Dec") decTyConKey typeTyConName = thTc (fsLit "Type") typeTyConKey -tyVarBndrTyConName = thTc (fsLit "TyVarBndr") tyVarBndrTyConKey matchTyConName = thTc (fsLit "Match") matchTyConKey clauseTyConName = thTc (fsLit "Clause") clauseTyConKey funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey predTyConName = thTc (fsLit "Pred") predTyConKey tExpTyConName = thTc (fsLit "TExp") tExpTyConKey injAnnTyConName = thTc (fsLit "InjectivityAnn") injAnnTyConKey -kindTyConName = thTc (fsLit "Kind") kindTyConKey overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey derivStrategyTyConName = thTc (fsLit "DerivStrategy") derivStrategyTyConKey @@ -347,38 +345,36 @@ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName, infixNDName, roleAnnotDName, patSynDName, patSynSigDName, pragCompleteDName :: Name -funDName = libFun (fsLit "funD") funDIdKey -valDName = libFun (fsLit "valD") valDIdKey -dataDName = libFun (fsLit "dataD") dataDIdKey -newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey -tySynDName = libFun (fsLit "tySynD") tySynDIdKey -classDName = libFun (fsLit "classD") classDIdKey -instanceWithOverlapDName - = libFun (fsLit "instanceWithOverlapD") instanceWithOverlapDIdKey -standaloneDerivWithStrategyDName = libFun - (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey -sigDName = libFun (fsLit "sigD") sigDIdKey -defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey -forImpDName = libFun (fsLit "forImpD") forImpDIdKey -pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey -pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey -pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey -pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey -pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey -pragCompleteDName = libFun (fsLit "pragCompleteD") pragCompleteDIdKey -pragAnnDName = libFun (fsLit "pragAnnD") pragAnnDIdKey -dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey -newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey -tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey -openTypeFamilyDName = libFun (fsLit "openTypeFamilyD") openTypeFamilyDIdKey -closedTypeFamilyDName= libFun (fsLit "closedTypeFamilyD") closedTypeFamilyDIdKey -dataFamilyDName = libFun (fsLit "dataFamilyD") dataFamilyDIdKey -infixLDName = libFun (fsLit "infixLD") infixLDIdKey -infixRDName = libFun (fsLit "infixRD") infixRDIdKey -infixNDName = libFun (fsLit "infixND") infixNDIdKey -roleAnnotDName = libFun (fsLit "roleAnnotD") roleAnnotDIdKey -patSynDName = libFun (fsLit "patSynD") patSynDIdKey -patSynSigDName = libFun (fsLit "patSynSigD") patSynSigDIdKey +funDName = libFun (fsLit "funD") funDIdKey +valDName = libFun (fsLit "valD") valDIdKey +dataDName = libFun (fsLit "dataD") dataDIdKey +newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey +tySynDName = libFun (fsLit "tySynD") tySynDIdKey +classDName = libFun (fsLit "classD") classDIdKey +instanceWithOverlapDName = libFun (fsLit "instanceWithOverlapD") instanceWithOverlapDIdKey +standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey +sigDName = libFun (fsLit "sigD") sigDIdKey +defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey +forImpDName = libFun (fsLit "forImpD") forImpDIdKey +pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey +pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey +pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey +pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey +pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey +pragCompleteDName = libFun (fsLit "pragCompleteD") pragCompleteDIdKey +pragAnnDName = libFun (fsLit "pragAnnD") pragAnnDIdKey +dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey +newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey +tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey +openTypeFamilyDName = libFun (fsLit "openTypeFamilyD") openTypeFamilyDIdKey +closedTypeFamilyDName = libFun (fsLit "closedTypeFamilyD") closedTypeFamilyDIdKey +dataFamilyDName = libFun (fsLit "dataFamilyD") dataFamilyDIdKey +infixLDName = libFun (fsLit "infixLD") infixLDIdKey +infixRDName = libFun (fsLit "infixRD") infixRDIdKey +infixNDName = libFun (fsLit "infixND") infixNDIdKey +roleAnnotDName = libFun (fsLit "roleAnnotD") roleAnnotDIdKey +patSynDName = libFun (fsLit "patSynD") patSynDIdKey +patSynSigDName = libFun (fsLit "patSynSigD") patSynSigDIdKey -- type Ctxt = ... cxtName :: Name @@ -432,7 +428,7 @@ recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey -- data Type = ... forallTName, varTName, conTName, tupleTName, unboxedTupleTName, unboxedSumTName, arrowTName, listTName, appTName, sigTName, - sigTDataConName, equalityTName, litTName, promotedTName, + equalityTName, litTName, promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName, wildCardTName :: Name forallTName = libFun (fsLit "forallT") forallTIdKey @@ -445,9 +441,6 @@ arrowTName = libFun (fsLit "arrowT") arrowTIdKey listTName = libFun (fsLit "listT") listTIdKey appTName = libFun (fsLit "appT") appTIdKey sigTName = libFun (fsLit "sigT") sigTIdKey --- Yes, we need names for both the monadic sigT as well as the pure SigT. Why? --- Refer to the documentation for repLKind in DsMeta. -sigTDataConName = thCon (fsLit "SigT") sigTDataConKey equalityTName = libFun (fsLit "equalityT") equalityTIdKey litTName = libFun (fsLit "litT") litTIdKey promotedTName = libFun (fsLit "promotedT") promotedTIdKey @@ -463,8 +456,8 @@ strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey -- data TyVarBndr = ... plainTVName, kindedTVName :: Name -plainTVName = libFun (fsLit "plainTV") plainTVIdKey -kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey +plainTVName = libFun (fsLit "plainTV") plainTVIdKey +kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey -- data Role = ... nominalRName, representationalRName, phantomRName, inferRName :: Name @@ -487,9 +480,9 @@ constraintKName = libFun (fsLit "constraintK") constraintKIdKey -- data FamilyResultSig = ... noSigName, kindSigName, tyVarSigName :: Name -noSigName = libFun (fsLit "noSig") noSigIdKey -kindSigName = libFun (fsLit "kindSig") kindSigIdKey -tyVarSigName = libFun (fsLit "tyVarSig") tyVarSigIdKey +noSigName = libFun (fsLit "noSig") noSigIdKey +kindSigName = libFun (fsLit "kindSig") kindSigIdKey +tyVarSigName = libFun (fsLit "tyVarSig") tyVarSigIdKey -- data InjectivityAnn = ... injectivityAnnName :: Name @@ -546,7 +539,7 @@ matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName, varBangTypeQTyConName, typeQTyConName, fieldExpQTyConName, patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName, - derivClauseQTyConName :: Name + derivClauseQTyConName, kindQTyConName, tyVarBndrQTyConName :: Name matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey expQTyConName = libTc (fsLit "ExpQ") expQTyConKey @@ -565,6 +558,8 @@ ruleBndrQTyConName = libTc (fsLit "RuleBndrQ") ruleBndrQTyConKey tySynEqnQTyConName = libTc (fsLit "TySynEqnQ") tySynEqnQTyConKey roleTyConName = libTc (fsLit "Role") roleTyConKey derivClauseQTyConName = libTc (fsLit "DerivClauseQ") derivClauseQTyConKey +kindQTyConName = libTc (fsLit "KindQ") kindQTyConKey +tyVarBndrQTyConName = libTc (fsLit "TyVarBndrQ") tyVarBndrQTyConKey -- quasiquoting quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name @@ -630,12 +625,12 @@ liftClassKey = mkPreludeClassUnique 200 expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey, - stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey, - decTyConKey, bangTypeQTyConKey, varBangTypeQTyConKey, + stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, + tyVarBndrQTyConKey, decTyConKey, bangTypeQTyConKey, varBangTypeQTyConKey, fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey, predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey, - roleTyConKey, tExpTyConKey, injAnnTyConKey, kindTyConKey, + roleTyConKey, tExpTyConKey, injAnnTyConKey, kindQTyConKey, overlapTyConKey, derivClauseQTyConKey, derivStrategyTyConKey :: Unique expTyConKey = mkPreludeTyConUnique 200 matchTyConKey = mkPreludeTyConUnique 201 @@ -662,14 +657,14 @@ fieldExpQTyConKey = mkPreludeTyConUnique 221 funDepTyConKey = mkPreludeTyConUnique 222 predTyConKey = mkPreludeTyConUnique 223 predQTyConKey = mkPreludeTyConUnique 224 -tyVarBndrTyConKey = mkPreludeTyConUnique 225 +tyVarBndrQTyConKey = mkPreludeTyConUnique 225 decsQTyConKey = mkPreludeTyConUnique 226 ruleBndrQTyConKey = mkPreludeTyConUnique 227 tySynEqnQTyConKey = mkPreludeTyConUnique 228 roleTyConKey = mkPreludeTyConUnique 229 tExpTyConKey = mkPreludeTyConUnique 230 injAnnTyConKey = mkPreludeTyConUnique 231 -kindTyConKey = mkPreludeTyConUnique 232 +kindQTyConKey = mkPreludeTyConUnique 232 overlapTyConKey = mkPreludeTyConUnique 233 derivClauseQTyConKey = mkPreludeTyConUnique 234 derivStrategyTyConKey = mkPreludeTyConUnique 235 @@ -955,7 +950,7 @@ recordPatSynIdKey = mkPreludeMiscIdUnique 372 -- data Type = ... forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, sigTIdKey, - sigTDataConKey, equalityTIdKey, litTIdKey, promotedTIdKey, + equalityTIdKey, litTIdKey, promotedTIdKey, promotedTupleTIdKey, promotedNilTIdKey, promotedConsTIdKey, wildCardTIdKey :: Unique forallTIdKey = mkPreludeMiscIdUnique 381 @@ -968,14 +963,13 @@ arrowTIdKey = mkPreludeMiscIdUnique 387 listTIdKey = mkPreludeMiscIdUnique 388 appTIdKey = mkPreludeMiscIdUnique 389 sigTIdKey = mkPreludeMiscIdUnique 390 -sigTDataConKey = mkPreludeMiscIdUnique 391 -equalityTIdKey = mkPreludeMiscIdUnique 392 -litTIdKey = mkPreludeMiscIdUnique 393 -promotedTIdKey = mkPreludeMiscIdUnique 394 -promotedTupleTIdKey = mkPreludeMiscIdUnique 395 -promotedNilTIdKey = mkPreludeMiscIdUnique 396 -promotedConsTIdKey = mkPreludeMiscIdUnique 397 -wildCardTIdKey = mkPreludeMiscIdUnique 398 +equalityTIdKey = mkPreludeMiscIdUnique 391 +litTIdKey = mkPreludeMiscIdUnique 392 +promotedTIdKey = mkPreludeMiscIdUnique 393 +promotedTupleTIdKey = mkPreludeMiscIdUnique 394 +promotedNilTIdKey = mkPreludeMiscIdUnique 395 +promotedConsTIdKey = mkPreludeMiscIdUnique 396 +wildCardTIdKey = mkPreludeMiscIdUnique 397 -- data TyLit = ... numTyLitIdKey, strTyLitIdKey :: Unique diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index 78fbc41d6f..9ad36f8586 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -1,8 +1,13 @@ -- | --- TH.Lib contains lots of useful helper functions for +-- Language.Haskell.TH.Lib contains lots of useful helper functions for -- generating and manipulating Template Haskell terms -{-# LANGUAGE CPP #-} +-- Note: this module mostly re-exports functions from +-- Language.Haskell.TH.Lib.Internal, but if a change occurs to Template +-- Haskell which requires breaking the API offered in this module, we opt to +-- copy the old definition here, and make the changes in +-- Language.Haskell.TH.Lib.Internal. This way, we can retain backwards +-- compatibility while still allowing GHC to make changes as it needs. module Language.Haskell.TH.Lib ( -- All of the exports from this module should @@ -11,11 +16,12 @@ module Language.Haskell.TH.Lib ( -- * Library functions -- ** Abbreviations - InfoQ, ExpQ, TExpQ, DecQ, DecsQ, ConQ, TypeQ, TyLitQ, CxtQ, PredQ, - DerivClauseQ, MatchQ, ClauseQ, BodyQ, GuardQ, StmtQ, RangeQ, - SourceStrictnessQ, SourceUnpackednessQ, BangQ, BangTypeQ, VarBangTypeQ, - StrictTypeQ, VarStrictTypeQ, FieldExpQ, PatQ, FieldPatQ, RuleBndrQ, - TySynEqnQ, PatSynDirQ, PatSynArgsQ, + InfoQ, ExpQ, TExpQ, DecQ, DecsQ, ConQ, TypeQ, KindQ, TyVarBndrQ, + TyLitQ, CxtQ, PredQ, DerivClauseQ, MatchQ, ClauseQ, BodyQ, GuardQ, + StmtQ, RangeQ, SourceStrictnessQ, SourceUnpackednessQ, BangQ, + BangTypeQ, VarBangTypeQ, StrictTypeQ, VarStrictTypeQ, FieldExpQ, PatQ, + FieldPatQ, RuleBndrQ, TySynEqnQ, PatSynDirQ, PatSynArgsQ, + FamilyResultSigQ, -- ** Constructors lifted to 'Q' -- *** Literals @@ -111,358 +117,45 @@ module Language.Haskell.TH.Lib ( ) where -import Language.Haskell.TH.Syntax hiding (Role, InjectivityAnn) -import qualified Language.Haskell.TH.Syntax as TH -import Control.Monad( liftM, liftM2 ) -import Data.Word( Word8 ) - ----------------------------------------------------------- --- * Type synonyms ----------------------------------------------------------- - -type InfoQ = Q Info -type PatQ = Q Pat -type FieldPatQ = Q FieldPat -type ExpQ = Q Exp -type TExpQ a = Q (TExp a) -type DecQ = Q Dec -type DecsQ = Q [Dec] -type ConQ = Q Con -type TypeQ = Q Type -type TyLitQ = Q TyLit -type CxtQ = Q Cxt -type PredQ = Q Pred -type DerivClauseQ = Q DerivClause -type MatchQ = Q Match -type ClauseQ = Q Clause -type BodyQ = Q Body -type GuardQ = Q Guard -type StmtQ = Q Stmt -type RangeQ = Q Range -type SourceStrictnessQ = Q SourceStrictness -type SourceUnpackednessQ = Q SourceUnpackedness -type BangQ = Q Bang -type BangTypeQ = Q BangType -type VarBangTypeQ = Q VarBangType -type StrictTypeQ = Q StrictType -type VarStrictTypeQ = Q VarStrictType -type FieldExpQ = Q FieldExp -type RuleBndrQ = Q RuleBndr -type TySynEqnQ = Q TySynEqn -type PatSynDirQ = Q PatSynDir -type PatSynArgsQ = Q PatSynArgs - --- must be defined here for DsMeta to find it -type Role = TH.Role -type InjectivityAnn = TH.InjectivityAnn - ----------------------------------------------------------- --- * 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 -charPrimL :: Char -> Lit -charPrimL = CharPrimL -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 <- sequence ps; return (TupP ps1)} - -unboxedTupP :: [PatQ] -> PatQ -unboxedTupP ps = do { ps1 <- sequence ps; return (UnboxedTupP ps1)} - -unboxedSumP :: PatQ -> SumAlt -> SumArity -> PatQ -unboxedSumP p alt arity = do { p1 <- p; return (UnboxedSumP p1 alt arity) } - -conP :: Name -> [PatQ] -> PatQ -conP n ps = do ps' <- sequence ps - return (ConP n ps') -infixP :: PatQ -> Name -> PatQ -> PatQ -infixP p1 n p2 = do p1' <- p1 - p2' <- p2 - return (InfixP p1' n p2') -uInfixP :: PatQ -> Name -> PatQ -> PatQ -uInfixP p1 n p2 = do p1' <- p1 - p2' <- p2 - return (UInfixP p1' n p2') -parensP :: PatQ -> PatQ -parensP p = do p' <- p - return (ParensP p') - -tildeP :: PatQ -> PatQ -tildeP p = do p' <- p - return (TildeP p') -bangP :: PatQ -> PatQ -bangP p = do p' <- p - return (BangP p') -asP :: Name -> PatQ -> PatQ -asP n p = do p' <- p - return (AsP n p') -wildP :: PatQ -wildP = return WildP -recP :: Name -> [FieldPatQ] -> PatQ -recP n fps = do fps' <- sequence fps - return (RecP n fps') -listP :: [PatQ] -> PatQ -listP ps = do ps' <- sequence ps - return (ListP ps') -sigP :: PatQ -> TypeQ -> PatQ -sigP p t = do p' <- p - t' <- t - return (SigP p' t') -viewP :: ExpQ -> PatQ -> PatQ -viewP e p = do e' <- e - p' <- p - return (ViewP e' p') - -fieldPat :: Name -> PatQ -> FieldPatQ -fieldPat n p = do p' <- p - return (n, p') - - -------------------------------------------------------------------------------- --- * Stmt - -bindS :: PatQ -> ExpQ -> StmtQ -bindS p e = liftM2 BindS p e - -letS :: [DecQ] -> StmtQ -letS ds = do { ds1 <- sequence ds; return (LetS ds1) } - -noBindS :: ExpQ -> StmtQ -noBindS e = do { e1 <- e; return (NoBindS e1) } - -parS :: [[StmtQ]] -> StmtQ -parS sss = do { sss1 <- mapM sequence sss; return (ParS sss1) } - -------------------------------------------------------------------------------- --- * Range - -fromR :: 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) } -------------------------------------------------------------------------------- --- * Body - -normalB :: ExpQ -> BodyQ -normalB e = do { e1 <- e; return (NormalB e1) } - -guardedB :: [Q (Guard,Exp)] -> BodyQ -guardedB ges = do { ges' <- sequence ges; return (GuardedB ges') } - -------------------------------------------------------------------------------- --- * Guard - -normalG :: 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' <- sequence ss; return (PatG ss') } - -patGE :: [StmtQ] -> ExpQ -> Q (Guard, Exp) -patGE ss e = do { ss' <- sequence ss; - 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' <- sequence ds; - return (Match p' r' ds') } - --- | Use with 'funD' -clause :: [PatQ] -> BodyQ -> [DecQ] -> ClauseQ -clause ps r ds = do { ps' <- sequence ps; - r' <- r; - ds' <- sequence ds; - return (Clause ps' r' ds') } - - ---------------------------------------------------------------------------- --- * Exp - --- | Dynamically binding a variable (unhygenic) -dyn :: String -> ExpQ -dyn s = return (VarE (mkName 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)} - -appTypeE :: ExpQ -> TypeQ -> ExpQ -appTypeE x t = do { a <- x; s <- t; return (AppTypeE a s) } - -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 :: Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ -infixE (Just x) s (Just y) = do { a <- x; s' <- s; b <- y; - return (InfixE (Just a) s' (Just b))} -infixE Nothing s (Just y) = do { s' <- s; b <- y; - return (InfixE Nothing s' (Just b))} -infixE (Just x) s Nothing = do { a <- x; s' <- s; - return (InfixE (Just a) s' Nothing)} -infixE Nothing s Nothing = do { s' <- s; return (InfixE Nothing s' Nothing) } - -infixApp :: ExpQ -> ExpQ -> ExpQ -> ExpQ -infixApp x y z = infixE (Just x) y (Just z) -sectionL :: ExpQ -> ExpQ -> ExpQ -sectionL x y = infixE (Just x) y Nothing -sectionR :: ExpQ -> ExpQ -> ExpQ -sectionR x y = infixE Nothing x (Just y) - -lamE :: [PatQ] -> ExpQ -> ExpQ -lamE ps e = do ps' <- sequence ps - e' <- e - return (LamE ps' e') - --- | Single-arg lambda -lam1E :: PatQ -> ExpQ -> ExpQ -lam1E p e = lamE [p] e - -lamCaseE :: [MatchQ] -> ExpQ -lamCaseE ms = sequence ms >>= return . LamCaseE - -tupE :: [ExpQ] -> ExpQ -tupE es = do { es1 <- sequence es; return (TupE es1)} - -unboxedTupE :: [ExpQ] -> ExpQ -unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE es1)} - -unboxedSumE :: ExpQ -> SumAlt -> SumArity -> ExpQ -unboxedSumE e alt arity = do { e1 <- e; return (UnboxedSumE e1 alt arity) } - -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 = sequence alts >>= return . MultiIfE - -letE :: [DecQ] -> ExpQ -> ExpQ -letE ds e = do { ds2 <- sequence ds; e2 <- e; return (LetE ds2 e2) } - -caseE :: ExpQ -> [MatchQ] -> ExpQ -caseE e ms = do { e1 <- e; ms1 <- sequence ms; return (CaseE e1 ms1) } - -doE :: [StmtQ] -> ExpQ -doE ss = do { ss1 <- sequence ss; return (DoE ss1) } - -compE :: [StmtQ] -> ExpQ -compE ss = do { ss1 <- sequence ss; return (CompE ss1) } - -arithSeqE :: RangeQ -> ExpQ -arithSeqE r = do { r' <- r; return (ArithSeqE r') } - -listE :: [ExpQ] -> ExpQ -listE es = do { es1 <- sequence es; 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 <- sequence fs; return (RecConE c flds) } - -recUpdE :: ExpQ -> [Q (Name,Exp)] -> ExpQ -recUpdE e fs = do { e1 <- e; flds <- sequence fs; 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 = fmap StaticE - -unboundVarE :: Name -> ExpQ -unboundVarE s = return (UnboundVarE s) - -labelE :: String -> ExpQ -labelE s = return (LabelE s) - --- ** 'arithSeqE' Shortcuts -fromE :: 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)) } - +import Language.Haskell.TH.Lib.Internal hiding + ( tySynD + , dataD + , newtypeD + , classD + , dataInstD + , newtypeInstD + , dataFamilyD + , openTypeFamilyD + , closedTypeFamilyD + , forallC + + , forallT + , sigT + + , plainTV + , kindedTV + , starK + , constraintK + + , noSig + , kindSig + , tyVarSig + + , Role + , InjectivityAnn + ) +import Language.Haskell.TH.Syntax + +import Control.Monad (liftM2) + +-- All definitions below represent the "old" API, since their definitions are +-- different in Language.Haskell.TH.Lib.Internal. Please think carefully before +-- deciding to change the APIs of the functions below, as they represent the +-- public API (as opposed to the Internal module, which has no API promises.) ------------------------------------------------------------------------------- -- * Dec -valD :: PatQ -> BodyQ -> [DecQ] -> DecQ -valD p b ds = - do { p' <- p - ; ds' <- sequence ds - ; b' <- b - ; return (ValD p' b' ds') - } - -funD :: Name -> [ClauseQ] -> DecQ -funD nm cs = - do { cs1 <- sequence cs - ; return (FunD nm cs1) - } - tySynD :: Name -> [TyVarBndr] -> TypeQ -> DecQ tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) } @@ -491,78 +184,6 @@ classD ctxt cls tvs fds decs = ctxt1 <- ctxt return $ ClassD ctxt1 cls tvs fds decs1 -instanceD :: CxtQ -> TypeQ -> [DecQ] -> DecQ -instanceD = instanceWithOverlapD Nothing - -instanceWithOverlapD :: Maybe Overlap -> CxtQ -> TypeQ -> [DecQ] -> DecQ -instanceWithOverlapD o ctxt ty decs = - do - ctxt1 <- ctxt - decs1 <- sequence decs - ty1 <- ty - return $ InstanceD o 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 - = do ty' <- 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 - = do - ty1 <- ty - return $ PragmaD $ SpecialiseP n ty1 Nothing phases - -pragSpecInlD :: Name -> TypeQ -> Inline -> Phases -> DecQ -pragSpecInlD n ty inline phases - = do - ty1 <- ty - return $ PragmaD $ SpecialiseP n ty1 (Just inline) phases - -pragSpecInstD :: TypeQ -> DecQ -pragSpecInstD ty - = do - ty1 <- ty - return $ PragmaD $ SpecialiseInstP ty1 - -pragRuleD :: String -> [RuleBndrQ] -> ExpQ -> ExpQ -> Phases -> DecQ -pragRuleD n bndrs lhs rhs phases - = do - bndrs1 <- sequence bndrs - lhs1 <- lhs - rhs1 <- rhs - return $ PragmaD $ RuleP n bndrs1 lhs1 rhs1 phases - -pragAnnD :: AnnTarget -> ExpQ -> DecQ -pragAnnD target expr - = do - exp1 <- expr - return $ PragmaD $ AnnP target exp1 - -pragLineD :: Int -> String -> DecQ -pragLineD line file = return $ PragmaD $ LineP line file - -pragCompleteD :: [Name] -> Maybe Name -> DecQ -pragCompleteD cls mty = return $ PragmaD $ CompleteP cls mty - dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> [ConQ] -> [DerivClauseQ] -> DecQ dataInstD ctxt tc tys ksig cons derivs = @@ -583,12 +204,6 @@ newtypeInstD ctxt tc tys ksig con derivs = derivs1 <- sequence derivs return (NewtypeInstD ctxt1 tc tys1 ksig con1 derivs1) -tySynInstD :: Name -> TySynEqnQ -> DecQ -tySynInstD tc eqn = - do - eqn1 <- eqn - return (TySynInstD tc eqn1) - dataFamilyD :: Name -> [TyVarBndr] -> Maybe Kind -> DecQ dataFamilyD tc tvs kind = return $ DataFamilyD tc tvs kind @@ -604,112 +219,9 @@ closedTypeFamilyD tc tvs result injectivity eqns = do eqns1 <- sequence eqns return (ClosedTypeFamilyD (TypeFamilyHead tc tvs result injectivity) eqns1) --- These were deprecated in GHC 8.0 with a plan to remove them in 8.2. If you --- remove this check please also: --- 1. remove deprecated functions --- 2. remove CPP language extension from top of this module --- 3. remove the FamFlavour data type from Syntax module --- 4. make sure that all references to FamFlavour are gone from DsMeta, --- Convert, TcSplice (follows from 3) -#if __GLASGOW_HASKELL__ >= 804 -#error Remove deprecated familyNoKindD, familyKindD, closedTypeFamilyNoKindD and closedTypeFamilyKindD -#endif - -{-# DEPRECATED familyNoKindD, familyKindD - "This function will be removed in the next stable release. Use openTypeFamilyD/dataFamilyD instead." #-} -familyNoKindD :: FamFlavour -> Name -> [TyVarBndr] -> DecQ -familyNoKindD flav tc tvs = - case flav of - TypeFam -> return $ OpenTypeFamilyD (TypeFamilyHead tc tvs NoSig Nothing) - DataFam -> return $ DataFamilyD tc tvs Nothing - -familyKindD :: FamFlavour -> Name -> [TyVarBndr] -> Kind -> DecQ -familyKindD flav tc tvs k = - case flav of - TypeFam -> - return $ OpenTypeFamilyD (TypeFamilyHead tc tvs (KindSig k) Nothing) - DataFam -> return $ DataFamilyD tc tvs (Just k) - -{-# DEPRECATED closedTypeFamilyNoKindD, closedTypeFamilyKindD - "This function will be removed in the next stable release. Use closedTypeFamilyD instead." #-} -closedTypeFamilyNoKindD :: Name -> [TyVarBndr] -> [TySynEqnQ] -> DecQ -closedTypeFamilyNoKindD tc tvs eqns = - do eqns1 <- sequence eqns - return (ClosedTypeFamilyD (TypeFamilyHead tc tvs NoSig Nothing) eqns1) - -closedTypeFamilyKindD :: Name -> [TyVarBndr] -> Kind -> [TySynEqnQ] -> DecQ -closedTypeFamilyKindD tc tvs kind eqns = - do eqns1 <- sequence eqns - return (ClosedTypeFamilyD (TypeFamilyHead tc tvs (KindSig kind) Nothing) - eqns1) - -roleAnnotD :: Name -> [Role] -> DecQ -roleAnnotD name roles = return $ RoleAnnotD name roles - -standaloneDerivD :: CxtQ -> TypeQ -> DecQ -standaloneDerivD = standaloneDerivWithStrategyD Nothing - -standaloneDerivWithStrategyD :: Maybe DerivStrategy -> CxtQ -> TypeQ -> DecQ -standaloneDerivWithStrategyD ds ctxtq tyq = - do - ctxt <- ctxtq - ty <- tyq - return $ StandaloneDerivD ds ctxt ty - -defaultSigD :: Name -> TypeQ -> DecQ -defaultSigD n tyq = - do - ty <- tyq - return $ DefaultSigD n ty - --- | Pattern synonym declaration -patSynD :: Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ -patSynD name args dir pat = do - args' <- args - dir' <- dir - pat' <- pat - return (PatSynD name args' dir' pat') - --- | Pattern synonym type signature -patSynSigD :: Name -> TypeQ -> DecQ -patSynSigD nm ty = - do ty' <- ty - return $ PatSynSigD nm ty' - -tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ -tySynEqn lhs rhs = - do - lhs1 <- sequence lhs - rhs1 <- rhs - return (TySynEqn lhs1 rhs1) - -cxt :: [PredQ] -> CxtQ -cxt = sequence - -derivClause :: Maybe DerivStrategy -> [PredQ] -> DerivClauseQ -derivClause ds p = do p' <- cxt p - return $ DerivClause ds p' - -normalC :: Name -> [BangTypeQ] -> ConQ -normalC con strtys = liftM (NormalC con) $ sequence strtys - -recC :: Name -> [VarBangTypeQ] -> ConQ -recC con varstrtys = liftM (RecC con) $ sequence varstrtys - -infixC :: Q (Bang, Type) -> Name -> Q (Bang, Type) -> ConQ -infixC st1 con st2 = do st1' <- st1 - st2' <- st2 - return $ InfixC st1' con st2' - forallC :: [TyVarBndr] -> CxtQ -> ConQ -> ConQ forallC ns ctxt con = liftM2 (ForallC ns) ctxt con -gadtC :: [Name] -> [StrictTypeQ] -> TypeQ -> ConQ -gadtC cons strtys ty = liftM2 (GadtC cons) (sequence strtys) ty - -recGadtC :: [Name] -> [VarStrictTypeQ] -> TypeQ -> ConQ -recGadtC cons varstrtys ty = liftM2 (RecGadtC cons) (sequence varstrtys) ty - ------------------------------------------------------------------------------- -- * Type @@ -719,145 +231,12 @@ forallT tvars ctxt ty = do ty1 <- ty return $ ForallT tvars ctxt1 ty1 -varT :: Name -> TypeQ -varT = return . VarT - -conT :: Name -> TypeQ -conT = return . ConT - -infixT :: TypeQ -> Name -> TypeQ -> TypeQ -infixT t1 n t2 = do t1' <- t1 - t2' <- t2 - return (InfixT t1' n t2') - -uInfixT :: TypeQ -> Name -> TypeQ -> TypeQ -uInfixT t1 n t2 = do t1' <- t1 - t2' <- t2 - return (UInfixT t1' n t2') - -parensT :: TypeQ -> TypeQ -parensT t = do t' <- t - return (ParensT t') - -appT :: TypeQ -> TypeQ -> TypeQ -appT t1 t2 = do - t1' <- t1 - t2' <- t2 - return $ AppT t1' t2' - -arrowT :: TypeQ -arrowT = return ArrowT - -listT :: TypeQ -listT = return ListT - -litT :: TyLitQ -> TypeQ -litT l = fmap LitT l - -tupleT :: Int -> TypeQ -tupleT i = return (TupleT i) - -unboxedTupleT :: Int -> TypeQ -unboxedTupleT i = return (UnboxedTupleT i) - -unboxedSumT :: SumArity -> TypeQ -unboxedSumT arity = return (UnboxedSumT arity) - sigT :: TypeQ -> Kind -> TypeQ sigT t k = do t' <- t return $ SigT t' k -equalityT :: TypeQ -equalityT = return EqualityT - -wildCardT :: TypeQ -wildCardT = return WildCardT - -{-# 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 - = do - tysl <- sequence tys - return (foldl AppT (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 - = do - tleft1 <- tleft - tright1 <- tright - eqT <- equalityT - return (foldl AppT eqT [tleft1, tright1]) - -promotedT :: Name -> TypeQ -promotedT = return . PromotedT - -promotedTupleT :: Int -> TypeQ -promotedTupleT i = return (PromotedTupleT i) - -promotedNilT :: TypeQ -promotedNilT = return PromotedNilT - -promotedConsT :: TypeQ -promotedConsT = return PromotedConsT - -noSourceUnpackedness, sourceNoUnpack, sourceUnpack :: SourceUnpackednessQ -noSourceUnpackedness = return NoSourceUnpackedness -sourceNoUnpack = return SourceNoUnpack -sourceUnpack = return SourceUnpack - -noSourceStrictness, sourceLazy, sourceStrict :: SourceStrictnessQ -noSourceStrictness = return NoSourceStrictness -sourceLazy = return SourceLazy -sourceStrict = return SourceStrict - -{-# DEPRECATED isStrict - ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ", - "Example usage: 'bang noSourceUnpackedness sourceStrict'"] #-} -{-# DEPRECATED notStrict - ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ", - "Example usage: 'bang noSourceUnpackedness noSourceStrictness'"] #-} -{-# DEPRECATED unpacked - ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ", - "Example usage: 'bang sourceUnpack sourceStrict'"] #-} -isStrict, notStrict, unpacked :: Q Strict -isStrict = bang noSourceUnpackedness sourceStrict -notStrict = bang noSourceUnpackedness noSourceStrictness -unpacked = bang sourceUnpack sourceStrict - -bang :: SourceUnpackednessQ -> SourceStrictnessQ -> BangQ -bang u s = do u' <- u - s' <- s - return (Bang u' s') - -bangType :: BangQ -> TypeQ -> BangTypeQ -bangType = liftM2 (,) - -varBangType :: Name -> BangTypeQ -> VarBangTypeQ -varBangType v bt = do (b, t) <- bt - return (v, b, t) - -{-# DEPRECATED strictType - "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'bangType' instead." #-} -strictType :: Q Strict -> TypeQ -> StrictTypeQ -strictType = bangType - -{-# DEPRECATED varStrictType - "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'varBangType' instead." #-} -varStrictType :: Name -> StrictTypeQ -> VarStrictTypeQ -varStrictType = varBangType - --- * Type Literals - -numTyLit :: Integer -> TyLitQ -numTyLit n = if n >= 0 then return (NumTyLit n) - else fail ("Negative type-level number: " ++ show n) - -strTyLit :: String -> TyLitQ -strTyLit s = return (StrTyLit s) - ------------------------------------------------------------------------------- -- * Kind @@ -867,24 +246,6 @@ 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 @@ -902,104 +263,3 @@ kindSig = KindSig tyVarSig :: TyVarBndr -> FamilyResultSig tyVarSig = TyVarSig - -------------------------------------------------------------------------------- --- * Injectivity annotation - -injectivityAnn :: Name -> [Name] -> InjectivityAnn -injectivityAnn = TH.InjectivityAnn - -------------------------------------------------------------------------------- --- * Role - -nominalR, representationalR, phantomR, inferR :: Role -nominalR = NominalR -representationalR = RepresentationalR -phantomR = PhantomR -inferR = InferR - -------------------------------------------------------------------------------- --- * Callconv - -cCall, stdCall, cApi, prim, javaScript :: Callconv -cCall = CCall -stdCall = StdCall -cApi = CApi -prim = Prim -javaScript = JavaScript - -------------------------------------------------------------------------------- --- * Safety - -unsafe, safe, interruptible :: Safety -unsafe = Unsafe -safe = Safe -interruptible = Interruptible - -------------------------------------------------------------------------------- --- * FunDep - -funDep :: [Name] -> [Name] -> FunDep -funDep = FunDep - -------------------------------------------------------------------------------- --- * FamFlavour - -typeFam, dataFam :: FamFlavour -typeFam = TypeFam -dataFam = DataFam - -------------------------------------------------------------------------------- --- * RuleBndr -ruleVar :: Name -> RuleBndrQ -ruleVar = return . RuleVar - -typedRuleVar :: Name -> TypeQ -> RuleBndrQ -typedRuleVar n ty = ty >>= return . TypedRuleVar n - -------------------------------------------------------------------------------- --- * AnnTarget -valueAnnotation :: Name -> AnnTarget -valueAnnotation = ValueAnnotation - -typeAnnotation :: Name -> AnnTarget -typeAnnotation = TypeAnnotation - -moduleAnnotation :: AnnTarget -moduleAnnotation = ModuleAnnotation - -------------------------------------------------------------------------------- --- * Pattern Synonyms (sub constructs) - -unidir, implBidir :: PatSynDirQ -unidir = return Unidir -implBidir = return ImplBidir - -explBidir :: [ClauseQ] -> PatSynDirQ -explBidir cls = do - cls' <- sequence cls - return (ExplBidir cls') - -prefixPatSyn :: [Name] -> PatSynArgsQ -prefixPatSyn args = return $ PrefixPatSyn args - -recordPatSyn :: [Name] -> PatSynArgsQ -recordPatSyn sels = return $ RecordPatSyn sels - -infixPatSyn :: Name -> Name -> PatSynArgsQ -infixPatSyn arg1 arg2 = return $ InfixPatSyn arg1 arg2 - --------------------------------------------------------------- --- * Useful helper function - -appsE :: [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 = do - loc <- location - return $ Module (mkPkgName $ loc_package loc) (mkModName $ loc_module loc) diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs new file mode 100644 index 0000000000..d58ce84f99 --- /dev/null +++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs @@ -0,0 +1,936 @@ +-- | +-- Language.Haskell.TH.Lib.Internal exposes some additional functionality that +-- is used internally in GHC's integration with Template Haskell. This is not a +-- part of the public API, and as such, there are no API guarantees for this +-- module from version to version. + +-- Why do we have both Language.Haskell.TH.Lib.Internal and +-- Language.Haskell.TH.Lib? Ultimately, it's because the functions in the +-- former (which are tailored for GHC's use) need different type signatures +-- than the ones in the latter. Syncing up the Internal type signatures would +-- involve a massive amount of breaking changes, so for the time being, we +-- relegate as many changes as we can to just the Internal module, where it +-- is safe to break things. + +{-# LANGUAGE CPP #-} + +module Language.Haskell.TH.Lib.Internal where + +import Language.Haskell.TH.Syntax hiding (Role, InjectivityAnn) +import qualified Language.Haskell.TH.Syntax as TH +import Control.Monad( liftM, liftM2 ) +import Data.Word( Word8 ) + +---------------------------------------------------------- +-- * Type synonyms +---------------------------------------------------------- + +type InfoQ = Q Info +type PatQ = Q Pat +type FieldPatQ = Q FieldPat +type ExpQ = Q Exp +type TExpQ a = Q (TExp a) +type DecQ = Q Dec +type DecsQ = Q [Dec] +type ConQ = Q Con +type TypeQ = Q Type +type KindQ = Q Kind +type TyVarBndrQ = Q TyVarBndr +type TyLitQ = Q TyLit +type CxtQ = Q Cxt +type PredQ = Q Pred +type DerivClauseQ = Q DerivClause +type MatchQ = Q Match +type ClauseQ = Q Clause +type BodyQ = Q Body +type GuardQ = Q Guard +type StmtQ = Q Stmt +type RangeQ = Q Range +type SourceStrictnessQ = Q SourceStrictness +type SourceUnpackednessQ = Q SourceUnpackedness +type BangQ = Q Bang +type BangTypeQ = Q BangType +type VarBangTypeQ = Q VarBangType +type StrictTypeQ = Q StrictType +type VarStrictTypeQ = Q VarStrictType +type FieldExpQ = Q FieldExp +type RuleBndrQ = Q RuleBndr +type TySynEqnQ = Q TySynEqn +type PatSynDirQ = Q PatSynDir +type PatSynArgsQ = Q PatSynArgs +type FamilyResultSigQ = Q FamilyResultSig + +-- must be defined here for DsMeta to find it +type Role = TH.Role +type InjectivityAnn = TH.InjectivityAnn + +---------------------------------------------------------- +-- * 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 +charPrimL :: Char -> Lit +charPrimL = CharPrimL +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 <- sequence ps; return (TupP ps1)} + +unboxedTupP :: [PatQ] -> PatQ +unboxedTupP ps = do { ps1 <- sequence ps; return (UnboxedTupP ps1)} + +unboxedSumP :: PatQ -> SumAlt -> SumArity -> PatQ +unboxedSumP p alt arity = do { p1 <- p; return (UnboxedSumP p1 alt arity) } + +conP :: Name -> [PatQ] -> PatQ +conP n ps = do ps' <- sequence ps + return (ConP n ps') +infixP :: PatQ -> Name -> PatQ -> PatQ +infixP p1 n p2 = do p1' <- p1 + p2' <- p2 + return (InfixP p1' n p2') +uInfixP :: PatQ -> Name -> PatQ -> PatQ +uInfixP p1 n p2 = do p1' <- p1 + p2' <- p2 + return (UInfixP p1' n p2') +parensP :: PatQ -> PatQ +parensP p = do p' <- p + return (ParensP p') + +tildeP :: PatQ -> PatQ +tildeP p = do p' <- p + return (TildeP p') +bangP :: PatQ -> PatQ +bangP p = do p' <- p + return (BangP p') +asP :: Name -> PatQ -> PatQ +asP n p = do p' <- p + return (AsP n p') +wildP :: PatQ +wildP = return WildP +recP :: Name -> [FieldPatQ] -> PatQ +recP n fps = do fps' <- sequence fps + return (RecP n fps') +listP :: [PatQ] -> PatQ +listP ps = do ps' <- sequence ps + return (ListP ps') +sigP :: PatQ -> TypeQ -> PatQ +sigP p t = do p' <- p + t' <- t + return (SigP p' t') +viewP :: ExpQ -> PatQ -> PatQ +viewP e p = do e' <- e + p' <- p + return (ViewP e' p') + +fieldPat :: Name -> PatQ -> FieldPatQ +fieldPat n p = do p' <- p + return (n, p') + + +------------------------------------------------------------------------------- +-- * Stmt + +bindS :: PatQ -> ExpQ -> StmtQ +bindS p e = liftM2 BindS p e + +letS :: [DecQ] -> StmtQ +letS ds = do { ds1 <- sequence ds; return (LetS ds1) } + +noBindS :: ExpQ -> StmtQ +noBindS e = do { e1 <- e; return (NoBindS e1) } + +parS :: [[StmtQ]] -> StmtQ +parS sss = do { sss1 <- mapM sequence sss; return (ParS sss1) } + +------------------------------------------------------------------------------- +-- * Range + +fromR :: 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) } +------------------------------------------------------------------------------- +-- * Body + +normalB :: ExpQ -> BodyQ +normalB e = do { e1 <- e; return (NormalB e1) } + +guardedB :: [Q (Guard,Exp)] -> BodyQ +guardedB ges = do { ges' <- sequence ges; return (GuardedB ges') } + +------------------------------------------------------------------------------- +-- * Guard + +normalG :: 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' <- sequence ss; return (PatG ss') } + +patGE :: [StmtQ] -> ExpQ -> Q (Guard, Exp) +patGE ss e = do { ss' <- sequence ss; + 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' <- sequence ds; + return (Match p' r' ds') } + +-- | Use with 'funD' +clause :: [PatQ] -> BodyQ -> [DecQ] -> ClauseQ +clause ps r ds = do { ps' <- sequence ps; + r' <- r; + ds' <- sequence ds; + return (Clause ps' r' ds') } + + +--------------------------------------------------------------------------- +-- * Exp + +-- | Dynamically binding a variable (unhygenic) +dyn :: String -> ExpQ +dyn s = return (VarE (mkName 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)} + +appTypeE :: ExpQ -> TypeQ -> ExpQ +appTypeE x t = do { a <- x; s <- t; return (AppTypeE a s) } + +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 :: Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ +infixE (Just x) s (Just y) = do { a <- x; s' <- s; b <- y; + return (InfixE (Just a) s' (Just b))} +infixE Nothing s (Just y) = do { s' <- s; b <- y; + return (InfixE Nothing s' (Just b))} +infixE (Just x) s Nothing = do { a <- x; s' <- s; + return (InfixE (Just a) s' Nothing)} +infixE Nothing s Nothing = do { s' <- s; return (InfixE Nothing s' Nothing) } + +infixApp :: ExpQ -> ExpQ -> ExpQ -> ExpQ +infixApp x y z = infixE (Just x) y (Just z) +sectionL :: ExpQ -> ExpQ -> ExpQ +sectionL x y = infixE (Just x) y Nothing +sectionR :: ExpQ -> ExpQ -> ExpQ +sectionR x y = infixE Nothing x (Just y) + +lamE :: [PatQ] -> ExpQ -> ExpQ +lamE ps e = do ps' <- sequence ps + e' <- e + return (LamE ps' e') + +-- | Single-arg lambda +lam1E :: PatQ -> ExpQ -> ExpQ +lam1E p e = lamE [p] e + +lamCaseE :: [MatchQ] -> ExpQ +lamCaseE ms = sequence ms >>= return . LamCaseE + +tupE :: [ExpQ] -> ExpQ +tupE es = do { es1 <- sequence es; return (TupE es1)} + +unboxedTupE :: [ExpQ] -> ExpQ +unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE es1)} + +unboxedSumE :: ExpQ -> SumAlt -> SumArity -> ExpQ +unboxedSumE e alt arity = do { e1 <- e; return (UnboxedSumE e1 alt arity) } + +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 = sequence alts >>= return . MultiIfE + +letE :: [DecQ] -> ExpQ -> ExpQ +letE ds e = do { ds2 <- sequence ds; e2 <- e; return (LetE ds2 e2) } + +caseE :: ExpQ -> [MatchQ] -> ExpQ +caseE e ms = do { e1 <- e; ms1 <- sequence ms; return (CaseE e1 ms1) } + +doE :: [StmtQ] -> ExpQ +doE ss = do { ss1 <- sequence ss; return (DoE ss1) } + +compE :: [StmtQ] -> ExpQ +compE ss = do { ss1 <- sequence ss; return (CompE ss1) } + +arithSeqE :: RangeQ -> ExpQ +arithSeqE r = do { r' <- r; return (ArithSeqE r') } + +listE :: [ExpQ] -> ExpQ +listE es = do { es1 <- sequence es; 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 <- sequence fs; return (RecConE c flds) } + +recUpdE :: ExpQ -> [Q (Name,Exp)] -> ExpQ +recUpdE e fs = do { e1 <- e; flds <- sequence fs; 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 = fmap StaticE + +unboundVarE :: Name -> ExpQ +unboundVarE s = return (UnboundVarE s) + +labelE :: String -> ExpQ +labelE s = return (LabelE s) + +-- ** 'arithSeqE' Shortcuts +fromE :: 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)) } + + +------------------------------------------------------------------------------- +-- * Dec + +valD :: PatQ -> BodyQ -> [DecQ] -> DecQ +valD p b ds = + do { p' <- p + ; ds' <- sequence ds + ; b' <- b + ; return (ValD p' b' ds') + } + +funD :: Name -> [ClauseQ] -> DecQ +funD nm cs = + do { cs1 <- sequence cs + ; return (FunD nm cs1) + } + +tySynD :: Name -> [TyVarBndrQ] -> TypeQ -> DecQ +tySynD tc tvs rhs = + do { tvs1 <- sequenceA tvs + ; rhs1 <- rhs + ; return (TySynD tc tvs1 rhs1) + } + +dataD :: CxtQ -> Name -> [TyVarBndrQ] -> Maybe KindQ -> [ConQ] + -> [DerivClauseQ] -> DecQ +dataD ctxt tc tvs ksig cons derivs = + do + ctxt1 <- ctxt + tvs1 <- sequenceA tvs + ksig1 <- sequenceA ksig + cons1 <- sequence cons + derivs1 <- sequence derivs + return (DataD ctxt1 tc tvs1 ksig1 cons1 derivs1) + +newtypeD :: CxtQ -> Name -> [TyVarBndrQ] -> Maybe KindQ -> ConQ + -> [DerivClauseQ] -> DecQ +newtypeD ctxt tc tvs ksig con derivs = + do + ctxt1 <- ctxt + tvs1 <- sequenceA tvs + ksig1 <- sequenceA ksig + con1 <- con + derivs1 <- sequence derivs + return (NewtypeD ctxt1 tc tvs1 ksig1 con1 derivs1) + +classD :: CxtQ -> Name -> [TyVarBndrQ] -> [FunDep] -> [DecQ] -> DecQ +classD ctxt cls tvs fds decs = + do + tvs1 <- sequenceA tvs + decs1 <- sequenceA decs + ctxt1 <- ctxt + return $ ClassD ctxt1 cls tvs1 fds decs1 + +instanceD :: CxtQ -> TypeQ -> [DecQ] -> DecQ +instanceD = instanceWithOverlapD Nothing + +instanceWithOverlapD :: Maybe Overlap -> CxtQ -> TypeQ -> [DecQ] -> DecQ +instanceWithOverlapD o ctxt ty decs = + do + ctxt1 <- ctxt + decs1 <- sequence decs + ty1 <- ty + return $ InstanceD o 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 + = do ty' <- 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 + = do + ty1 <- ty + return $ PragmaD $ SpecialiseP n ty1 Nothing phases + +pragSpecInlD :: Name -> TypeQ -> Inline -> Phases -> DecQ +pragSpecInlD n ty inline phases + = do + ty1 <- ty + return $ PragmaD $ SpecialiseP n ty1 (Just inline) phases + +pragSpecInstD :: TypeQ -> DecQ +pragSpecInstD ty + = do + ty1 <- ty + return $ PragmaD $ SpecialiseInstP ty1 + +pragRuleD :: String -> [RuleBndrQ] -> ExpQ -> ExpQ -> Phases -> DecQ +pragRuleD n bndrs lhs rhs phases + = do + bndrs1 <- sequence bndrs + lhs1 <- lhs + rhs1 <- rhs + return $ PragmaD $ RuleP n bndrs1 lhs1 rhs1 phases + +pragAnnD :: AnnTarget -> ExpQ -> DecQ +pragAnnD target expr + = do + exp1 <- expr + return $ PragmaD $ AnnP target exp1 + +pragLineD :: Int -> String -> DecQ +pragLineD line file = return $ PragmaD $ LineP line file + +pragCompleteD :: [Name] -> Maybe Name -> DecQ +pragCompleteD cls mty = return $ PragmaD $ CompleteP cls mty + +dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe KindQ -> [ConQ] + -> [DerivClauseQ] -> DecQ +dataInstD ctxt tc tys ksig cons derivs = + do + ctxt1 <- ctxt + tys1 <- sequenceA tys + ksig1 <- sequenceA ksig + cons1 <- sequenceA cons + derivs1 <- sequenceA derivs + return (DataInstD ctxt1 tc tys1 ksig1 cons1 derivs1) + +newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe KindQ -> ConQ + -> [DerivClauseQ] -> DecQ +newtypeInstD ctxt tc tys ksig con derivs = + do + ctxt1 <- ctxt + tys1 <- sequenceA tys + ksig1 <- sequenceA ksig + con1 <- con + derivs1 <- sequence derivs + return (NewtypeInstD ctxt1 tc tys1 ksig1 con1 derivs1) + +tySynInstD :: Name -> TySynEqnQ -> DecQ +tySynInstD tc eqn = + do + eqn1 <- eqn + return (TySynInstD tc eqn1) + +dataFamilyD :: Name -> [TyVarBndrQ] -> Maybe KindQ -> DecQ +dataFamilyD tc tvs kind = + do tvs' <- sequenceA tvs + kind' <- sequenceA kind + return $ DataFamilyD tc tvs' kind' + +openTypeFamilyD :: Name -> [TyVarBndrQ] -> FamilyResultSigQ + -> Maybe InjectivityAnn -> DecQ +openTypeFamilyD tc tvs res inj = + do tvs' <- sequenceA tvs + res' <- res + return $ OpenTypeFamilyD (TypeFamilyHead tc tvs' res' inj) + +closedTypeFamilyD :: Name -> [TyVarBndrQ] -> FamilyResultSigQ + -> Maybe InjectivityAnn -> [TySynEqnQ] -> DecQ +closedTypeFamilyD tc tvs result injectivity eqns = + do tvs1 <- sequenceA tvs + result1 <- result + eqns1 <- sequenceA eqns + return (ClosedTypeFamilyD (TypeFamilyHead tc tvs1 result1 injectivity) eqns1) + +-- These were deprecated in GHC 8.0 with a plan to remove them in 8.2. If you +-- remove this check please also: +-- 1. remove deprecated functions +-- 2. remove CPP language extension from top of this module +-- 3. remove the FamFlavour data type from Syntax module +-- 4. make sure that all references to FamFlavour are gone from DsMeta, +-- Convert, TcSplice (follows from 3) +#if __GLASGOW_HASKELL__ >= 804 +#error Remove deprecated familyNoKindD, familyKindD, closedTypeFamilyNoKindD and closedTypeFamilyKindD +#endif + +{-# DEPRECATED familyNoKindD, familyKindD + "This function will be removed in the next stable release. Use openTypeFamilyD/dataFamilyD instead." #-} +familyNoKindD :: FamFlavour -> Name -> [TyVarBndr] -> DecQ +familyNoKindD flav tc tvs = + case flav of + TypeFam -> return $ OpenTypeFamilyD (TypeFamilyHead tc tvs NoSig Nothing) + DataFam -> return $ DataFamilyD tc tvs Nothing + +familyKindD :: FamFlavour -> Name -> [TyVarBndr] -> Kind -> DecQ +familyKindD flav tc tvs k = + case flav of + TypeFam -> + return $ OpenTypeFamilyD (TypeFamilyHead tc tvs (KindSig k) Nothing) + DataFam -> return $ DataFamilyD tc tvs (Just k) + +{-# DEPRECATED closedTypeFamilyNoKindD, closedTypeFamilyKindD + "This function will be removed in the next stable release. Use closedTypeFamilyD instead." #-} +closedTypeFamilyNoKindD :: Name -> [TyVarBndr] -> [TySynEqnQ] -> DecQ +closedTypeFamilyNoKindD tc tvs eqns = + do eqns1 <- sequence eqns + return (ClosedTypeFamilyD (TypeFamilyHead tc tvs NoSig Nothing) eqns1) + +closedTypeFamilyKindD :: Name -> [TyVarBndr] -> Kind -> [TySynEqnQ] -> DecQ +closedTypeFamilyKindD tc tvs kind eqns = + do eqns1 <- sequence eqns + return (ClosedTypeFamilyD (TypeFamilyHead tc tvs (KindSig kind) Nothing) + eqns1) + +roleAnnotD :: Name -> [Role] -> DecQ +roleAnnotD name roles = return $ RoleAnnotD name roles + +standaloneDerivD :: CxtQ -> TypeQ -> DecQ +standaloneDerivD = standaloneDerivWithStrategyD Nothing + +standaloneDerivWithStrategyD :: Maybe DerivStrategy -> CxtQ -> TypeQ -> DecQ +standaloneDerivWithStrategyD ds ctxtq tyq = + do + ctxt <- ctxtq + ty <- tyq + return $ StandaloneDerivD ds ctxt ty + +defaultSigD :: Name -> TypeQ -> DecQ +defaultSigD n tyq = + do + ty <- tyq + return $ DefaultSigD n ty + +-- | Pattern synonym declaration +patSynD :: Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ +patSynD name args dir pat = do + args' <- args + dir' <- dir + pat' <- pat + return (PatSynD name args' dir' pat') + +-- | Pattern synonym type signature +patSynSigD :: Name -> TypeQ -> DecQ +patSynSigD nm ty = + do ty' <- ty + return $ PatSynSigD nm ty' + +tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ +tySynEqn lhs rhs = + do + lhs1 <- sequence lhs + rhs1 <- rhs + return (TySynEqn lhs1 rhs1) + +cxt :: [PredQ] -> CxtQ +cxt = sequence + +derivClause :: Maybe DerivStrategy -> [PredQ] -> DerivClauseQ +derivClause ds p = do p' <- cxt p + return $ DerivClause ds p' + +normalC :: Name -> [BangTypeQ] -> ConQ +normalC con strtys = liftM (NormalC con) $ sequence strtys + +recC :: Name -> [VarBangTypeQ] -> ConQ +recC con varstrtys = liftM (RecC con) $ sequence varstrtys + +infixC :: Q (Bang, Type) -> Name -> Q (Bang, Type) -> ConQ +infixC st1 con st2 = do st1' <- st1 + st2' <- st2 + return $ InfixC st1' con st2' + +forallC :: [TyVarBndrQ] -> CxtQ -> ConQ -> ConQ +forallC ns ctxt con = do + ns' <- sequenceA ns + ctxt' <- ctxt + con' <- con + pure $ ForallC ns' ctxt' con' + +gadtC :: [Name] -> [StrictTypeQ] -> TypeQ -> ConQ +gadtC cons strtys ty = liftM2 (GadtC cons) (sequence strtys) ty + +recGadtC :: [Name] -> [VarStrictTypeQ] -> TypeQ -> ConQ +recGadtC cons varstrtys ty = liftM2 (RecGadtC cons) (sequence varstrtys) ty + +------------------------------------------------------------------------------- +-- * Type + +forallT :: [TyVarBndrQ] -> CxtQ -> TypeQ -> TypeQ +forallT tvars ctxt ty = do + tvars1 <- sequenceA tvars + ctxt1 <- ctxt + ty1 <- ty + return $ ForallT tvars1 ctxt1 ty1 + +varT :: Name -> TypeQ +varT = return . VarT + +conT :: Name -> TypeQ +conT = return . ConT + +infixT :: TypeQ -> Name -> TypeQ -> TypeQ +infixT t1 n t2 = do t1' <- t1 + t2' <- t2 + return (InfixT t1' n t2') + +uInfixT :: TypeQ -> Name -> TypeQ -> TypeQ +uInfixT t1 n t2 = do t1' <- t1 + t2' <- t2 + return (UInfixT t1' n t2') + +parensT :: TypeQ -> TypeQ +parensT t = do t' <- t + return (ParensT t') + +appT :: TypeQ -> TypeQ -> TypeQ +appT t1 t2 = do + t1' <- t1 + t2' <- t2 + return $ AppT t1' t2' + +arrowT :: TypeQ +arrowT = return ArrowT + +listT :: TypeQ +listT = return ListT + +litT :: TyLitQ -> TypeQ +litT l = fmap LitT l + +tupleT :: Int -> TypeQ +tupleT i = return (TupleT i) + +unboxedTupleT :: Int -> TypeQ +unboxedTupleT i = return (UnboxedTupleT i) + +unboxedSumT :: SumArity -> TypeQ +unboxedSumT arity = return (UnboxedSumT arity) + +sigT :: TypeQ -> KindQ -> TypeQ +sigT t k + = do + t' <- t + k' <- k + return $ SigT t' k' + +equalityT :: TypeQ +equalityT = return EqualityT + +wildCardT :: TypeQ +wildCardT = return WildCardT + +{-# 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 + = do + tysl <- sequence tys + return (foldl AppT (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 + = do + tleft1 <- tleft + tright1 <- tright + eqT <- equalityT + return (foldl AppT eqT [tleft1, tright1]) + +promotedT :: Name -> TypeQ +promotedT = return . PromotedT + +promotedTupleT :: Int -> TypeQ +promotedTupleT i = return (PromotedTupleT i) + +promotedNilT :: TypeQ +promotedNilT = return PromotedNilT + +promotedConsT :: TypeQ +promotedConsT = return PromotedConsT + +noSourceUnpackedness, sourceNoUnpack, sourceUnpack :: SourceUnpackednessQ +noSourceUnpackedness = return NoSourceUnpackedness +sourceNoUnpack = return SourceNoUnpack +sourceUnpack = return SourceUnpack + +noSourceStrictness, sourceLazy, sourceStrict :: SourceStrictnessQ +noSourceStrictness = return NoSourceStrictness +sourceLazy = return SourceLazy +sourceStrict = return SourceStrict + +{-# DEPRECATED isStrict + ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ", + "Example usage: 'bang noSourceUnpackedness sourceStrict'"] #-} +{-# DEPRECATED notStrict + ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ", + "Example usage: 'bang noSourceUnpackedness noSourceStrictness'"] #-} +{-# DEPRECATED unpacked + ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ", + "Example usage: 'bang sourceUnpack sourceStrict'"] #-} +isStrict, notStrict, unpacked :: Q Strict +isStrict = bang noSourceUnpackedness sourceStrict +notStrict = bang noSourceUnpackedness noSourceStrictness +unpacked = bang sourceUnpack sourceStrict + +bang :: SourceUnpackednessQ -> SourceStrictnessQ -> BangQ +bang u s = do u' <- u + s' <- s + return (Bang u' s') + +bangType :: BangQ -> TypeQ -> BangTypeQ +bangType = liftM2 (,) + +varBangType :: Name -> BangTypeQ -> VarBangTypeQ +varBangType v bt = do (b, t) <- bt + return (v, b, t) + +{-# DEPRECATED strictType + "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'bangType' instead." #-} +strictType :: Q Strict -> TypeQ -> StrictTypeQ +strictType = bangType + +{-# DEPRECATED varStrictType + "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'varBangType' instead." #-} +varStrictType :: Name -> StrictTypeQ -> VarStrictTypeQ +varStrictType = varBangType + +-- * Type Literals + +numTyLit :: Integer -> TyLitQ +numTyLit n = if n >= 0 then return (NumTyLit n) + else fail ("Negative type-level number: " ++ show n) + +strTyLit :: String -> TyLitQ +strTyLit s = return (StrTyLit s) + +------------------------------------------------------------------------------- +-- * Kind + +plainTV :: Name -> TyVarBndrQ +plainTV = pure . PlainTV + +kindedTV :: Name -> KindQ -> TyVarBndrQ +kindedTV n = fmap (KindedTV n) + +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 :: KindQ +starK = pure StarT + +constraintK :: KindQ +constraintK = pure ConstraintT + +------------------------------------------------------------------------------- +-- * Type family result + +noSig :: FamilyResultSigQ +noSig = pure NoSig + +kindSig :: KindQ -> FamilyResultSigQ +kindSig = fmap KindSig + +tyVarSig :: TyVarBndrQ -> FamilyResultSigQ +tyVarSig = fmap TyVarSig + +------------------------------------------------------------------------------- +-- * Injectivity annotation + +injectivityAnn :: Name -> [Name] -> InjectivityAnn +injectivityAnn = TH.InjectivityAnn + +------------------------------------------------------------------------------- +-- * Role + +nominalR, representationalR, phantomR, inferR :: Role +nominalR = NominalR +representationalR = RepresentationalR +phantomR = PhantomR +inferR = InferR + +------------------------------------------------------------------------------- +-- * Callconv + +cCall, stdCall, cApi, prim, javaScript :: Callconv +cCall = CCall +stdCall = StdCall +cApi = CApi +prim = Prim +javaScript = JavaScript + +------------------------------------------------------------------------------- +-- * Safety + +unsafe, safe, interruptible :: Safety +unsafe = Unsafe +safe = Safe +interruptible = Interruptible + +------------------------------------------------------------------------------- +-- * FunDep + +funDep :: [Name] -> [Name] -> FunDep +funDep = FunDep + +------------------------------------------------------------------------------- +-- * FamFlavour + +typeFam, dataFam :: FamFlavour +typeFam = TypeFam +dataFam = DataFam + +------------------------------------------------------------------------------- +-- * RuleBndr +ruleVar :: Name -> RuleBndrQ +ruleVar = return . RuleVar + +typedRuleVar :: Name -> TypeQ -> RuleBndrQ +typedRuleVar n ty = ty >>= return . TypedRuleVar n + +------------------------------------------------------------------------------- +-- * AnnTarget +valueAnnotation :: Name -> AnnTarget +valueAnnotation = ValueAnnotation + +typeAnnotation :: Name -> AnnTarget +typeAnnotation = TypeAnnotation + +moduleAnnotation :: AnnTarget +moduleAnnotation = ModuleAnnotation + +------------------------------------------------------------------------------- +-- * Pattern Synonyms (sub constructs) + +unidir, implBidir :: PatSynDirQ +unidir = return Unidir +implBidir = return ImplBidir + +explBidir :: [ClauseQ] -> PatSynDirQ +explBidir cls = do + cls' <- sequence cls + return (ExplBidir cls') + +prefixPatSyn :: [Name] -> PatSynArgsQ +prefixPatSyn args = return $ PrefixPatSyn args + +recordPatSyn :: [Name] -> PatSynArgsQ +recordPatSyn sels = return $ RecordPatSyn sels + +infixPatSyn :: Name -> Name -> PatSynArgsQ +infixPatSyn arg1 arg2 = return $ InfixPatSyn arg1 arg2 + +-------------------------------------------------------------- +-- * Useful helper function + +appsE :: [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 = do + loc <- location + return $ Module (mkPkgName $ loc_package loc) (mkModName $ loc_module loc) diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md index 8eddedce3d..0e3429caa9 100644 --- a/libraries/template-haskell/changelog.md +++ b/libraries/template-haskell/changelog.md @@ -6,6 +6,14 @@ * Add support for overloaded labels. Introduces `labelE :: String -> ExpQ`. + * Add `KindQ`, `TyVarBndrQ`, and `FamilyResultSigQ` aliases to + `Language.Haskell.TH.Lib`. + + * Add `Language.Haskell.TH.Lib.Internal` module, which exposes some + additional functionality that is used internally in GHC's integration + with Template Haskell. This is not a part of the public API, and as + such, there are no API guarantees for this module from version to version. + ## 2.12.0.0 *TBA* * Bundled with GHC *TBA* diff --git a/libraries/template-haskell/template-haskell.cabal b/libraries/template-haskell/template-haskell.cabal index dfb3b079b3..fcfa448b91 100644 --- a/libraries/template-haskell/template-haskell.cabal +++ b/libraries/template-haskell/template-haskell.cabal @@ -45,6 +45,8 @@ Library Language.Haskell.TH.Syntax Language.Haskell.TH.LanguageExtensions + Language.Haskell.TH.Lib.Internal + other-modules: Language.Haskell.TH.Lib.Map diff --git a/testsuite/tests/quotes/TH_localname.stderr b/testsuite/tests/quotes/TH_localname.stderr index a5af954e82..41eb9882e8 100644 --- a/testsuite/tests/quotes/TH_localname.stderr +++ b/testsuite/tests/quotes/TH_localname.stderr @@ -5,7 +5,7 @@ TH_localname.hs:3:11: error: t0)’ from being solved. Relevant bindings include y :: t0 (bound at TH_localname.hs:3:6) - x :: t0 -> Language.Haskell.TH.Lib.ExpQ + x :: t0 -> Language.Haskell.TH.Lib.Internal.ExpQ (bound at TH_localname.hs:3:1) Probable fix: use a type annotation to specify what ‘t0’ should be. These potential instances exist: diff --git a/testsuite/tests/th/T13642.hs b/testsuite/tests/th/T13642.hs index 35aee30ddb..090b891433 100644 --- a/testsuite/tests/th/T13642.hs +++ b/testsuite/tests/th/T13642.hs @@ -5,5 +5,5 @@ import Data.Kind (Type) import Language.Haskell.TH (stringE, pprint) foo :: IO () -foo = $([d| data Foo :: forall a. a -> Type where MkFoo :: Foo Int |] - >>= \d -> stringE (pprint d)) +foo = putStrLn $([d| data Foo :: forall a. a -> Type where MkFoo :: Foo Int |] + >>= \d -> stringE (pprint d)) diff --git a/testsuite/tests/th/T13642.stderr b/testsuite/tests/th/T13642.stderr deleted file mode 100644 index a6ff054a26..0000000000 --- a/testsuite/tests/th/T13642.stderr +++ /dev/null @@ -1,4 +0,0 @@ - -T13642.hs:8:9: error: - Exotic form of kind not (yet) handled by Template Haskell - forall a. a -> Type diff --git a/testsuite/tests/th/T7276.stderr b/testsuite/tests/th/T7276.stderr index 93c9a0c835..4fa2a3c4c9 100644 --- a/testsuite/tests/th/T7276.stderr +++ b/testsuite/tests/th/T7276.stderr @@ -2,7 +2,7 @@ T7276.hs:6:8: error: • Couldn't match type ‘[Language.Haskell.TH.Syntax.Dec]’ with ‘Language.Haskell.TH.Syntax.Exp’ - Expected type: Language.Haskell.TH.Lib.ExpQ - Actual type: Language.Haskell.TH.Lib.DecsQ + Expected type: Language.Haskell.TH.Lib.Internal.ExpQ + Actual type: Language.Haskell.TH.Lib.Internal.DecsQ • In the expression: [d| y = 3 |] In the untyped splice: $([d| y = 3 |]) diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index b52042bb76..3db985777c 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -386,7 +386,7 @@ test('T13473', normal, multimod_compile_and_run, ['T13473.hs', '-v0 ' + config.ghc_th_way_flags]) test('T13587', expect_broken(13587), compile_and_run, ['-v0']) test('T13618', normal, compile_and_run, ['-v0']) -test('T13642', normal, compile_fail, ['-v0']) +test('T13642', normal, compile, ['-v0']) test('T13781', normal, compile, ['-v0']) test('T13782', normal, compile, ['']) test('T13837', normal, compile_fail, ['-v0 -dsuppress-uniques']) |