Commit b3b564fb authored by Ryan Scott's avatar Ryan Scott

Merge types and kinds in DsMeta

Summary:
Types and kinds are now the same in GHC... well, except in the code
that involves Template Haskell, where types and kinds are given separate
treatment. This aims to unify that treatment in the `DsMeta` module.

The gist of this patch is replacing all uses of `repLKind` with `repLTy`.
This is isn't quite as simple as one might imagine, since `repLTy` returns a
`Core (Q Type)` (a monadic expression), whereas `repLKind` returns a
`Core Kind` (a pure expression). This causes many awkward impedance mismatches.

One option would be to change every combinator in `Language.Haskell.TH.Lib` to
take `KindQ` as an argument instead of `Kind`. But this would be a breaking
change of colossal proportions.

Instead, this patch takes a somewhat different approach. This migrates the
existing `Language.Haskell.TH.Lib` module to
`Language.Haskell.TH.Lib.Internal`, and changes all `Kind`-related combinators
in `Language.Haskell.TH.Lib.Internal` to live in `Q`. The new
`Language.Haskell.TH.Lib` module then re-exports most of
`Language.Haskell.TH.Lib.Internal` with the exception of the `Kind`-related
combinators, for which it redefines them to be their current definitions (which
don't live in `Q`). This allows us to retain backwards compatibility with
previous `template-haskell` releases, but more importantly, it allows GHC to
make as many changes to the `Internal` code as it wants for its purposes
without fear of disrupting the public API.

This solves half of #11785 (the other half being `TcSplice`).

Test Plan: ./validate

Reviewers: goldfire, austin, bgamari

Reviewed By: goldfire

Subscribers: rwbarton, thomie

GHC Trac Issues: #11785

Differential Revision: https://phabricator.haskell.org/D3751
parent d6186496
......@@ -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]
----------------------------------------------------------
......
......@@ -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
......
-- |
-- 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