[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Mark T16916 fragile
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Dec 5 07:38:27 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
bb674262 by Bryan Richter at 2022-12-03T04:38:46-05:00
Mark T16916 fragile
See https://gitlab.haskell.org/ghc/ghc/-/issues/16966
- - - - -
5d267d46 by Vladislav Zavialov at 2022-12-03T04:39:22-05:00
Refactor: FreshOrReuse instead of addTyClTyVarBinds
This is a refactoring that should have no effect on observable behavior.
Prior to this change, GHC.HsToCore.Quote contained a few closely related
functions to process type variable bindings: addSimpleTyVarBinds,
addHsTyVarBinds, addQTyVarBinds, and addTyClTyVarBinds.
We can classify them by their input type and name generation strategy:
Fresh names only Reuse bound names
+---------------------+-------------------+
[Name] | addSimpleTyVarBinds | |
[LHsTyVarBndr flag GhcRn] | addHsTyVarBinds | |
LHsQTyVars GhcRn | addQTyVarBinds | addTyClTyVarBinds |
+---------------------+-------------------+
Note how two functions are missing. Because of this omission, there were
two places where a LHsQTyVars value was constructed just to be able to pass it
to addTyClTyVarBinds:
1. mk_qtvs in addHsOuterFamEqnTyVarBinds -- bad
2. mkHsQTvs in repFamilyDecl -- bad
This prevented me from making other changes to LHsQTyVars, so the main
goal of this refactoring is to get rid of those workarounds.
The most direct solution would be to define the missing functions.
But that would lead to a certain amount of code duplication. To avoid
code duplication, I factored out the name generation strategy into a
function parameter:
data FreshOrReuse
= FreshNamesOnly
| ReuseBoundNames
addSimpleTyVarBinds :: FreshOrReuse -> ...
addHsTyVarBinds :: FreshOrReuse -> ...
addQTyVarBinds :: FreshOrReuse -> ...
- - - - -
c189b831 by Vladislav Zavialov at 2022-12-03T04:39:22-05:00
addHsOuterFamEqnTyVarBinds: use FreshNamesOnly for explicit binders
Consider this example:
[d| instance forall a. C [a] where
type forall b. G [a] b = Proxy b |]
When we process "forall b." in the associated type instance, it is
unambiguously the binding site for "b" and we want a fresh name for it.
Therefore, FreshNamesOnly is more fitting than ReuseBoundNames.
This should not have any observable effect but it avoids pointless
lookups in the MetaEnv.
- - - - -
42512264 by Ross Paterson at 2022-12-03T10:32:45+00:00
Handle type data declarations in Template Haskell quotations and splices (fixes #22500)
This adds a TypeDataD constructor to the Template Haskell Dec type,
and ensures that the constructors it contains go in the TyCls namespace.
- - - - -
1edc2579 by Vladislav Zavialov at 2022-12-05T02:38:05-05:00
Add BufSpan to EpaLocation (#22319, #22558)
The key part of this patch is the change to mkTokenLocation:
- mkTokenLocation (RealSrcSpan r _) = TokenLoc (EpaSpan r)
+ mkTokenLocation (RealSrcSpan r mb) = TokenLoc (EpaSpan r mb)
mkTokenLocation used to discard the BufSpan, but now it is saved and can
be retrieved from LHsToken or LHsUniToken.
This is made possible by the following change to EpaLocation:
- data EpaLocation = EpaSpan !RealSrcSpan
+ data EpaLocation = EpaSpan !RealSrcSpan !(Strict.Maybe BufSpan)
| ...
The end goal is to make use of the BufSpan in Parser/PostProcess/Haddock.
- - - - -
27 changed files:
- compiler/GHC/Builtin/Names/TH.hs
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/SrcLoc.hs
- libraries/template-haskell/Language/Haskell/TH/Lib.hs
- libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
- libraries/template-haskell/Language/Haskell/TH/Ppr.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- libraries/template-haskell/changelog.md
- testsuite/tests/lib/base/all.T
- + testsuite/tests/type-data/should_compile/TD_TH_splice.hs
- testsuite/tests/type-data/should_compile/all.T
- + testsuite/tests/type-data/should_run/T22500.hs
- + testsuite/tests/type-data/should_run/T22500.stdout
- testsuite/tests/type-data/should_run/all.T
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Parsers.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
Changes:
=====================================
compiler/GHC/Builtin/Names/TH.hs
=====================================
@@ -69,7 +69,7 @@ templateHaskellNames = [
-- Stmt
bindSName, letSName, noBindSName, parSName, recSName,
-- Dec
- funDName, valDName, dataDName, newtypeDName, tySynDName,
+ funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName,
classDName, instanceWithOverlapDName,
standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName,
pragInlDName, pragOpaqueDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
@@ -354,7 +354,7 @@ parSName = libFun (fsLit "parS") parSIdKey
recSName = libFun (fsLit "recS") recSIdKey
-- data Dec = ...
-funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
+funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName, classDName,
instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName,
pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName,
pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName, defaultDName,
@@ -366,6 +366,7 @@ funDName = libFun (fsLit "funD")
valDName = libFun (fsLit "valD") valDIdKey
dataDName = libFun (fsLit "dataD") dataDIdKey
newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey
+typeDataDName = libFun (fsLit "typeDataD") typeDataDIdKey
tySynDName = libFun (fsLit "tySynD") tySynDIdKey
classDName = libFun (fsLit "classD") classDIdKey
instanceWithOverlapDName = libFun (fsLit "instanceWithOverlapD") instanceWithOverlapDIdKey
@@ -888,7 +889,7 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,
infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,
patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey,
- kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey :: Unique
+ kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey, typeDataDIdKey :: Unique
funDIdKey = mkPreludeMiscIdUnique 320
valDIdKey = mkPreludeMiscIdUnique 321
dataDIdKey = mkPreludeMiscIdUnique 322
@@ -923,7 +924,8 @@ pragCompleteDIdKey = mkPreludeMiscIdUnique 350
implicitParamBindDIdKey = mkPreludeMiscIdUnique 351
kiSigDIdKey = mkPreludeMiscIdUnique 352
defaultDIdKey = mkPreludeMiscIdUnique 353
-pragOpaqueDIdKey = mkPreludeMiscIdUnique 354
+pragOpaqueDIdKey = mkPreludeMiscIdUnique 354
+typeDataDIdKey = mkPreludeMiscIdUnique 355
-- type Cxt = ...
cxtIdKey :: Unique
=====================================
compiler/GHC/Hs/Dump.hs
=====================================
@@ -144,7 +144,7 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
_ -> parens $ text "SourceText" <+> text "blanked"
epaAnchor :: EpaLocation -> SDoc
- epaAnchor (EpaSpan r) = parens $ text "EpaSpan" <+> realSrcSpan r
+ epaAnchor (EpaSpan r _) = parens $ text "EpaSpan" <+> realSrcSpan r
epaAnchor (EpaDelta d cs) = case ba of
NoBlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> showAstData' cs
BlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> text "blanked"
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -461,7 +461,7 @@ repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $
repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
= do { tc1 <- lookupLOcc tc -- See Note [Binders and occurrences]
- ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
+ ; dec <- addQTyVarBinds ReuseBoundNames tvs $ \bndrs ->
repSynDecl tc1 bndrs rhs
; return (Just (locA loc, dec)) }
@@ -469,7 +469,7 @@ repTyClD (L loc (DataDecl { tcdLName = tc
, tcdTyVars = tvs
, tcdDataDefn = defn }))
= do { tc1 <- lookupLOcc tc -- See Note [Binders and occurrences]
- ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
+ ; dec <- addQTyVarBinds ReuseBoundNames tvs $ \bndrs ->
repDataDefn tc1 (Left bndrs) defn
; return (Just (locA loc, dec)) }
@@ -478,7 +478,7 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
tcdSigs = sigs, tcdMeths = meth_binds,
tcdATs = ats, tcdATDefs = atds }))
= do { cls1 <- lookupLOcc cls -- See Note [Binders and occurrences]
- ; dec <- addQTyVarBinds tvs $ \bndrs ->
+ ; dec <- addQTyVarBinds FreshNamesOnly tvs $ \bndrs ->
do { cxt1 <- repLContext cxt
-- See Note [Scoped type variables in quotes]
; (ss, sigs_binds) <- rep_meth_sigs_binds sigs meth_binds
@@ -528,10 +528,10 @@ repDataDefn tc opts
; ksig' <- repMaybeLTy ksig
; repNewtype cxt1 tc opts ksig' con'
derivs1 }
- DataTypeCons _ cons -> do { ksig' <- repMaybeLTy ksig
+ DataTypeCons type_data cons -> do { ksig' <- repMaybeLTy ksig
; consL <- mapM repC cons
; cons1 <- coreListM conTyConName consL
- ; repData cxt1 tc opts ksig' cons1
+ ; repData type_data cxt1 tc opts ksig' cons1
derivs1 }
}
@@ -549,14 +549,11 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info
, fdResultSig = L _ resultSig
, fdInjectivityAnn = injectivity }))
= do { tc1 <- lookupLOcc tc -- See Note [Binders and occurrences]
- ; let mkHsQTvs :: [LHsTyVarBndr () GhcRn] -> LHsQTyVars GhcRn
- mkHsQTvs tvs = HsQTvs { hsq_ext = []
- , hsq_explicit = tvs }
- resTyVar = case resultSig of
- TyVarSig _ bndr -> mkHsQTvs [bndr]
- _ -> mkHsQTvs []
- ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
- addTyClTyVarBinds resTyVar $ \_ ->
+ ; let resTyVar = case resultSig of
+ TyVarSig _ bndr -> [hsLTyVarName bndr]
+ _ -> []
+ ; dec <- addQTyVarBinds ReuseBoundNames tvs $ \bndrs ->
+ addSimpleTyVarBinds ReuseBoundNames resTyVar $
case info of
ClosedTypeFamily Nothing ->
notHandled (ThAbstractClosedTypeFamily decl)
@@ -645,7 +642,7 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
, cid_datafam_insts = adts
, cid_overlap_mode = overlap
})
- = addSimpleTyVarBinds tvs $
+ = addSimpleTyVarBinds FreshNamesOnly tvs $
-- We must bring the type variables into scope, so their
-- occurrences don't fail, even though the binders don't
-- appear in the resulting data structure
@@ -672,7 +669,7 @@ repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
, deriv_type = ty }))
= do { dec <- repDerivStrategy strat $ \strat' ->
- addSimpleTyVarBinds tvs $
+ addSimpleTyVarBinds FreshNamesOnly tvs $
do { cxt' <- repLContext cxt
; inst_ty' <- repLTy inst_ty
; repDeriv strat' cxt' inst_ty' }
@@ -804,16 +801,17 @@ repDefD (L loc (DefaultDecl _ tys)) = do { tys1 <- repLTys tys
repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repRuleD (L loc (HsRule { rd_name = n
, rd_act = act
- , rd_tyvs = ty_bndrs
+ , rd_tyvs = m_ty_bndrs
, rd_tmvs = tm_bndrs
, rd_lhs = lhs
, rd_rhs = rhs }))
- = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs ->
+ = do { let ty_bndrs = fromMaybe [] m_ty_bndrs
+ ; rule <- addHsTyVarBinds FreshNamesOnly ty_bndrs $ \ ex_bndrs ->
do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs
; ss <- mkGenSyms tm_bndr_names
; rule <- addBinds ss $
do { elt_ty <- wrapName tyVarBndrUnitTyConName
- ; ty_bndrs' <- return $ case ty_bndrs of
+ ; ty_bndrs' <- return $ case m_ty_bndrs of
Nothing -> coreNothing' (mkListTy elt_ty)
Just _ -> coreJust' (mkListTy elt_ty) ex_bndrs
; tm_bndrs' <- repListM ruleBndrTyConName
@@ -878,7 +876,7 @@ repC (L _ (ConDeclH98 { con_name = con
, con_ex_tvs = con_tvs
, con_mb_cxt = mcxt
, con_args = args }))
- = addHsTyVarBinds con_tvs $ \ ex_bndrs ->
+ = addHsTyVarBinds FreshNamesOnly con_tvs $ \ ex_bndrs ->
do { c' <- repH98DataCon con args
; ctxt' <- repMbContext mcxt
; if not is_existential && isNothing mcxt
@@ -1188,14 +1186,11 @@ addHsOuterFamEqnTyVarBinds outer_bndrs thing_inside = do
elt_ty <- wrapName tyVarBndrUnitTyConName
case outer_bndrs of
HsOuterImplicit{hso_ximplicit = imp_tvs} ->
- addTyClTyVarBinds (mk_qtvs imp_tvs []) $ \_th_exp_bndrs ->
+ addSimpleTyVarBinds ReuseBoundNames imp_tvs $
thing_inside $ coreNothingList elt_ty
HsOuterExplicit{hso_bndrs = exp_bndrs} ->
- addTyClTyVarBinds (mk_qtvs [] exp_bndrs) $ \th_exp_bndrs ->
+ addHsTyVarBinds FreshNamesOnly exp_bndrs $ \th_exp_bndrs ->
thing_inside $ coreJustList elt_ty th_exp_bndrs
- where
- mk_qtvs imp_tvs exp_tvs = HsQTvs { hsq_ext = imp_tvs
- , hsq_explicit = exp_tvs }
addHsOuterSigTyVarBinds ::
HsOuterSigTyVarBndrs GhcRn
@@ -1204,9 +1199,9 @@ addHsOuterSigTyVarBinds ::
addHsOuterSigTyVarBinds outer_bndrs thing_inside = case outer_bndrs of
HsOuterImplicit{hso_ximplicit = imp_tvs} ->
do th_nil <- coreListM tyVarBndrSpecTyConName []
- addSimpleTyVarBinds imp_tvs $ thing_inside th_nil
+ addSimpleTyVarBinds FreshNamesOnly imp_tvs $ thing_inside th_nil
HsOuterExplicit{hso_bndrs = exp_bndrs} ->
- addHsTyVarBinds exp_bndrs thing_inside
+ addHsTyVarBinds FreshNamesOnly exp_bndrs thing_inside
-- | If a type implicitly quantifies its outermost type variables, return
-- 'True' if the list of implicitly bound type variables is empty. If a type
@@ -1230,69 +1225,86 @@ nullOuterExplicit (HsOuterExplicit{hso_bndrs = exp_bndrs}) = null exp_bndrs
nullOuterExplicit (HsOuterImplicit{}) = True
-- Vacuously true, as there is no outermost explicit quantification
-addSimpleTyVarBinds :: [Name] -- the binders to be added
+-- Do we want to generate fresh names for type variables
+-- or reuse the ones that are already in scope?
+data FreshOrReuse
+ = FreshNamesOnly
+ -- Generate fresh names for all type variables, regardless of existing
+ -- variables in the MetaEnv.
+ --
+ -- This is the default strategy.
+
+ | ReuseBoundNames
+ -- Generate fresh names for type variables not in the MetaEnv.
+ -- Where a name is already bound in the MetaEnv, use that existing binding;
+ -- do not create a new one with a fresh name.
+ --
+ -- This is the strategy used for data/newtype declarations and type family
+ -- instances, so that the nested type variables work right:
+ --
+ -- class C a where
+ -- type W a b
+ -- instance C (T a) where
+ -- type W (T a) b = blah
+ --
+ -- The 'a' in the type instance is the one bound by the instance decl
+ --
+ -- Test cases: TH_reifyExplicitForAllFams T9081 T9199 T10811
+
+mkGenSyms' :: FreshOrReuse -> [Name] -> MetaM [GenSymBind]
+mkGenSyms' FreshNamesOnly names = mkGenSyms names
+mkGenSyms' ReuseBoundNames names =
+ -- Make fresh names for the ones that are not already in scope
+ -- This makes things work for associated types
+ do { env <- lift dsGetMetaEnv
+ ; mkGenSyms (filterOut (`elemNameEnv` env) names) }
+
+addSimpleTyVarBinds :: FreshOrReuse
+ -> [Name] -- the binders to be added
-> MetaM (Core (M a)) -- action in the ext env
-> MetaM (Core (M a))
-addSimpleTyVarBinds names thing_inside
- = do { fresh_names <- mkGenSyms names
+addSimpleTyVarBinds fresh_or_reuse names thing_inside
+ = do { fresh_names <- mkGenSyms' fresh_or_reuse names
; term <- addBinds fresh_names thing_inside
; wrapGenSyms fresh_names term }
addHsTyVarBinds :: forall flag flag' a. RepTV flag flag'
- => [LHsTyVarBndr flag GhcRn] -- the binders to be added
+ => FreshOrReuse
+ -> [LHsTyVarBndr flag GhcRn] -- the binders to be added
-> (Core [(M (TH.TyVarBndr flag'))] -> MetaM (Core (M a))) -- action in the ext env
-> MetaM (Core (M a))
-addHsTyVarBinds exp_tvs thing_inside
- = do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs)
+addHsTyVarBinds fresh_or_reuse exp_tvs thing_inside
+ = do { fresh_exp_names <- mkGenSyms' fresh_or_reuse (hsLTyVarNames exp_tvs)
; term <- addBinds fresh_exp_names $
do { kbs <- repListM (tyVarBndrName @flag @flag') repTyVarBndr
exp_tvs
; thing_inside kbs }
; wrapGenSyms fresh_exp_names term }
-addQTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added
+addQTyVarBinds :: FreshOrReuse
+ -> LHsQTyVars GhcRn -- the binders to be added
-> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a))) -- action in the ext env
-> MetaM (Core (M a))
-addQTyVarBinds (HsQTvs { hsq_ext = imp_tvs
- , hsq_explicit = exp_tvs })
- thing_inside
- = addTyVarBinds exp_tvs imp_tvs thing_inside
+addQTyVarBinds fresh_or_reuse qtvs thing_inside =
+ let HsQTvs { hsq_ext = imp_tvs
+ , hsq_explicit = exp_tvs }
+ = qtvs
+ in addTyVarBinds fresh_or_reuse exp_tvs imp_tvs thing_inside
addTyVarBinds :: RepTV flag flag'
- => [LHsTyVarBndr flag GhcRn] -- the binders to be added
+ => FreshOrReuse
+ -> [LHsTyVarBndr flag GhcRn] -- the binders to be added
-> [Name]
-> (Core [(M (TH.TyVarBndr flag'))] -> MetaM (Core (M a))) -- action in the ext env
-> MetaM (Core (M 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
-- meta environment and gets the *new* names on Core-level as an argument
-addTyVarBinds exp_tvs imp_tvs thing_inside
- = addSimpleTyVarBinds imp_tvs $
- addHsTyVarBinds exp_tvs $
+addTyVarBinds fresh_or_reuse exp_tvs imp_tvs thing_inside
+ = addSimpleTyVarBinds fresh_or_reuse imp_tvs $
+ addHsTyVarBinds fresh_or_reuse exp_tvs $
thing_inside
-addTyClTyVarBinds :: LHsQTyVars GhcRn
- -> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a)))
- -> MetaM (Core (M a))
--- Used for data/newtype declarations, and family instances,
--- so that the nested type variables work right
--- instance C (T a) where
--- type W (T a) = blah
--- The 'a' in the type instance is the one bound by the instance decl
-addTyClTyVarBinds tvs m
- = do { let tv_names = hsAllLTyVarNames tvs
- ; env <- lift $ dsGetMetaEnv
- ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)
- -- Make fresh names for the ones that are not already in scope
- -- This makes things work for family declarations
-
- ; term <- addBinds freshNames $
- do { kbs <- repListM tyVarBndrUnitTyConName repTyVarBndr
- (hsQTvExplicit tvs)
- ; m kbs }
-
- ; wrapGenSyms freshNames term }
-
-- | Represent a type variable binder
repTyVarBndr :: RepTV flag flag'
=> LHsTyVarBndr flag GhcRn -> MetaM (Core (M (TH.TyVarBndr flag')))
@@ -1341,7 +1353,7 @@ repLTy ty = repTy (unLoc ty)
repForallT :: HsType GhcRn -> MetaM (Core (M TH.Type))
repForallT ty
| (tvs, ctxt, tau) <- splitLHsSigmaTyInvis (noLocA ty)
- = addHsTyVarBinds tvs $ \bndrs ->
+ = addHsTyVarBinds FreshNamesOnly tvs $ \bndrs ->
do { ctxt1 <- repLContext ctxt
; tau1 <- repLTy tau
; repTForall bndrs ctxt1 tau1 -- forall a. C a => {...}
@@ -1352,7 +1364,7 @@ repTy ty@(HsForAllTy { hst_tele = tele, hst_body = body }) =
case tele of
HsForAllInvis{} -> repForallT ty
HsForAllVis { hsf_vis_bndrs = tvs } ->
- addHsTyVarBinds tvs $ \bndrs ->
+ addHsTyVarBinds FreshNamesOnly tvs $ \bndrs ->
do body1 <- repLTy body
repTForallVis bndrs body1
repTy ty@(HsQualTy {}) = repForallT ty
@@ -1606,7 +1618,7 @@ repE (RecordUpd { rupd_flds = Right _ })
panic "The impossible has happened!"
repE (ExprWithTySig _ e wc_ty)
- = addSimpleTyVarBinds (get_scoped_tvs_from_sig sig_ty) $
+ = addSimpleTyVarBinds FreshNamesOnly (get_scoped_tvs_from_sig sig_ty) $
do { e1 <- repLE e
; t1 <- rep_ty_sig' sig_ty
; repSigExp e1 t1 }
@@ -2516,14 +2528,17 @@ repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
repFun :: Core TH.Name -> Core [(M TH.Clause)] -> MetaM (Core (M TH.Dec))
repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
-repData :: Core (M TH.Cxt) -> Core TH.Name
+repData :: Bool -- ^ @True@ for a @type data@ declaration.
+ -- See Note [Type data declarations] in GHC.Rename.Module
+ -> Core (M TH.Cxt) -> Core TH.Name
-> Either (Core [(M (TH.TyVarBndr ()))])
(Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type))
-> Core (Maybe (M TH.Kind)) -> Core [(M TH.Con)] -> Core [M TH.DerivClause]
-> MetaM (Core (M TH.Dec))
-repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs)
- = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]
-repData (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons)
+repData type_data (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs)
+ | type_data = rep2 typeDataDName [nm, tvs, ksig, cons]
+ | otherwise = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]
+repData _ (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons)
(MkC derivs)
= rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs]
@@ -2560,7 +2575,7 @@ repDerivStrategy mds thing_inside =
StockStrategy _ -> thing_inside =<< just =<< repStockStrategy
AnyclassStrategy _ -> thing_inside =<< just =<< repAnyclassStrategy
NewtypeStrategy _ -> thing_inside =<< just =<< repNewtypeStrategy
- ViaStrategy ty -> addSimpleTyVarBinds (get_scoped_tvs_from_sig ty) $
+ ViaStrategy ty -> addSimpleTyVarBinds FreshNamesOnly (get_scoped_tvs_from_sig ty) $
do ty' <- rep_ty_sig' ty
via_strat <- repViaStrategy ty'
m_via_strat <- just via_strat
=====================================
compiler/GHC/Parser.y
=====================================
@@ -3058,34 +3058,34 @@ tup_exprs :: { forall b. DisambECP b => PV (SumOrTuple b) }
: texp commas_tup_tail
{ unECP $1 >>= \ $1 ->
$2 >>= \ $2 ->
- do { t <- amsA $1 [AddCommaAnn (EpaSpan $ rs $ fst $2)]
+ do { t <- amsA $1 [AddCommaAnn (srcSpan2e $ fst $2)]
; return (Tuple (Right t : snd $2)) } }
| commas tup_tail
{ $2 >>= \ $2 ->
- do { let {cos = map (\ll -> (Left (EpAnn (anc $ rs ll) (EpaSpan $ rs ll) emptyComments))) (fst $1) }
+ do { let {cos = map (\ll -> (Left (EpAnn (anc $ rs ll) (srcSpan2e ll) emptyComments))) (fst $1) }
; return (Tuple (cos ++ $2)) } }
| texp bars { unECP $1 >>= \ $1 -> return $
- (Sum 1 (snd $2 + 1) $1 [] (map (EpaSpan . realSrcSpan) $ fst $2)) }
+ (Sum 1 (snd $2 + 1) $1 [] (map srcSpan2e $ fst $2)) }
| bars texp bars0
{ unECP $2 >>= \ $2 -> return $
(Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2
- (map (EpaSpan . realSrcSpan) $ fst $1)
- (map (EpaSpan . realSrcSpan) $ fst $3)) }
+ (map srcSpan2e $ fst $1)
+ (map srcSpan2e $ fst $3)) }
-- Always starts with commas; always follows an expr
commas_tup_tail :: { forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn EpaLocation) (LocatedA b)]) }
commas_tup_tail : commas tup_tail
{ $2 >>= \ $2 ->
- do { let {cos = map (\l -> (Left (EpAnn (anc $ rs l) (EpaSpan $ rs l) emptyComments))) (tail $ fst $1) }
+ do { let {cos = map (\l -> (Left (EpAnn (anc $ rs l) (srcSpan2e l) emptyComments))) (tail $ fst $1) }
; return ((head $ fst $1, cos ++ $2)) } }
-- Always follows a comma
tup_tail :: { forall b. DisambECP b => PV [Either (EpAnn EpaLocation) (LocatedA b)] }
: texp commas_tup_tail { unECP $1 >>= \ $1 ->
$2 >>= \ $2 ->
- do { t <- amsA $1 [AddCommaAnn (EpaSpan $ rs $ fst $2)]
+ do { t <- amsA $1 [AddCommaAnn (srcSpan2e $ fst $2)]
; return (Right t : snd $2) } }
| texp { unECP $1 >>= \ $1 ->
return [Right $1] }
@@ -3564,10 +3564,10 @@ qcon_list : qcon { sL1N $1 [$1] }
sysdcon_nolist :: { LocatedN DataCon } -- Wired in data constructors
: '(' ')' {% amsrn (sLL $1 $> unitDataCon) (NameAnnOnly NameParens (glAA $1) (glAA $2) []) }
| '(' commas ')' {% amsrn (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1))
- (NameAnnCommas NameParens (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) }
+ (NameAnnCommas NameParens (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }
| '(#' '#)' {% amsrn (sLL $1 $> $ unboxedUnitDataCon) (NameAnnOnly NameParensHash (glAA $1) (glAA $2) []) }
| '(#' commas '#)' {% amsrn (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1))
- (NameAnnCommas NameParensHash (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) }
+ (NameAnnCommas NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }
-- See Note [Empty lists] in GHC.Hs.Expr
sysdcon :: { LocatedN DataCon }
@@ -3601,12 +3601,12 @@ ntgtycon :: { LocatedN RdrName } -- A "general" qualified tycon, excluding unit
: oqtycon { $1 }
| '(' commas ')' {% amsrn (sLL $1 $> $ getRdrName (tupleTyCon Boxed
(snd $2 + 1)))
- (NameAnnCommas NameParens (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) }
+ (NameAnnCommas NameParens (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }
| '(#' commas '#)' {% amsrn (sLL $1 $> $ getRdrName (tupleTyCon Unboxed
(snd $2 + 1)))
- (NameAnnCommas NameParensHash (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) }
+ (NameAnnCommas NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }
| '(#' bars '#)' {% amsrn (sLL $1 $> $ getRdrName (sumTyCon (snd $2 + 1)))
- (NameAnnBars NameParensHash (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) }
+ (NameAnnBars NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }
| '(' '->' ')' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
(NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }
| '[' ']' {% amsrn (sLL $1 $> $ listTyCon_RDR)
@@ -4210,27 +4210,27 @@ in GHC.Parser.Annotation
-- |Construct an AddEpAnn from the annotation keyword and the location
-- of the keyword itself
mj :: AnnKeywordId -> Located e -> AddEpAnn
-mj a l = AddEpAnn a (EpaSpan $ rs $ gl l)
+mj a l = AddEpAnn a (srcSpan2e $ gl l)
mjN :: AnnKeywordId -> LocatedN e -> AddEpAnn
-mjN a l = AddEpAnn a (EpaSpan $ rs $ glN l)
+mjN a l = AddEpAnn a (srcSpan2e $ glN l)
-- |Construct an AddEpAnn from the annotation keyword and the location
-- of the keyword itself, provided the span is not zero width
mz :: AnnKeywordId -> Located e -> [AddEpAnn]
-mz a l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn a (EpaSpan $ rs $ gl l)]
+mz a l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn a (srcSpan2e $ gl l)]
msemi :: Located e -> [TrailingAnn]
-msemi l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (EpaSpan $ rs $ gl l)]
+msemi l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (srcSpan2e $ gl l)]
msemim :: Located e -> Maybe EpaLocation
-msemim l = if isZeroWidthSpan (gl l) then Nothing else Just (EpaSpan $ rs $ gl l)
+msemim l = if isZeroWidthSpan (gl l) then Nothing else Just (srcSpan2e $ gl l)
-- |Construct an AddEpAnn from the annotation keyword and the Located Token. If
-- the token has a unicode equivalent and this has been used, provide the
-- unicode variant of the annotation.
mu :: AnnKeywordId -> Located Token -> AddEpAnn
-mu a lt@(L l t) = AddEpAnn (toUnicodeAnn a lt) (EpaSpan $ rs l)
+mu a lt@(L l t) = AddEpAnn (toUnicodeAnn a lt) (srcSpan2e l)
-- | If the 'Token' is using its unicode variant return the unicode variant of
-- the annotation
@@ -4253,7 +4253,7 @@ glR :: Located a -> Anchor
glR la = Anchor (realSrcSpan $ getLoc la) UnchangedAnchor
glAA :: Located a -> EpaLocation
-glAA = EpaSpan <$> realSrcSpan . getLoc
+glAA = srcSpan2e . getLoc
glRR :: Located a -> RealSrcSpan
glRR = realSrcSpan . getLoc
@@ -4265,7 +4265,7 @@ glNR :: LocatedN a -> Anchor
glNR ln = Anchor (realSrcSpan $ getLocA ln) UnchangedAnchor
glNRR :: LocatedN a -> EpaLocation
-glNRR = EpaSpan <$> realSrcSpan . getLocA
+glNRR = srcSpan2e . getLocA
anc :: RealSrcSpan -> Anchor
anc r = Anchor r UnchangedAnchor
@@ -4395,7 +4395,7 @@ rs _ = panic "Parser should only have RealSrcSpan"
hsDoAnn :: Located a -> LocatedAn t b -> AnnKeywordId -> AnnList
hsDoAnn (L l _) (L ll _) kw
- = AnnList (Just $ spanAsAnchor (locA ll)) Nothing Nothing [AddEpAnn kw (EpaSpan $ rs l)] []
+ = AnnList (Just $ spanAsAnchor (locA ll)) Nothing Nothing [AddEpAnn kw (srcSpan2e l)] []
listAsAnchor :: [LocatedAn t a] -> Anchor
listAsAnchor [] = spanAsAnchor noSrcSpan
@@ -4435,16 +4435,16 @@ addTrailingAnnA (L (SrcSpanAnn anns l) a) ss ta = do
let
anns' = if isZeroWidthSpan ss
then anns
- else addTrailingAnnToA l (ta (EpaSpan $ rs ss)) cs anns
+ else addTrailingAnnToA l (ta (srcSpan2e ss)) cs anns
return (L (SrcSpanAnn anns' l) a)
-- -------------------------------------
addTrailingVbarL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a)
-addTrailingVbarL la span = addTrailingAnnL la (AddVbarAnn (EpaSpan $ rs span))
+addTrailingVbarL la span = addTrailingAnnL la (AddVbarAnn (srcSpan2e span))
addTrailingCommaL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a)
-addTrailingCommaL la span = addTrailingAnnL la (AddCommaAnn (EpaSpan $ rs span))
+addTrailingCommaL la span = addTrailingAnnL la (AddCommaAnn (srcSpan2e span))
addTrailingAnnL :: MonadP m => LocatedL a -> TrailingAnn -> m (LocatedL a)
addTrailingAnnL (L (SrcSpanAnn anns l) a) ta = do
@@ -4462,7 +4462,7 @@ addTrailingCommaN (L (SrcSpanAnn anns l) a) span = do
-- AZ:TODO: generalise updating comments into an annotation
let anns' = if isZeroWidthSpan span
then anns
- else addTrailingCommaToN l anns (EpaSpan $ rs span)
+ else addTrailingCommaToN l anns (srcSpan2e span)
return (L (SrcSpanAnn anns' l) a)
addTrailingCommaS :: Located StringLiteral -> EpaLocation -> Located StringLiteral
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -51,7 +51,7 @@ module GHC.Parser.Annotation (
la2na, na2la, n2l, l2n, l2l, la2la,
reLoc, reLocA, reLocL, reLocC, reLocN,
- la2r, realSrcSpan,
+ srcSpan2e, la2e, realSrcSpan,
-- ** Building up annotations
extraToAnnList, reAnn,
@@ -403,7 +403,7 @@ data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Eq)
-- in the @'EpaDelta'@ variant captures any comments between the prior
-- output and the thing being marked here, since we cannot otherwise
-- sort the relative order.
-data EpaLocation = EpaSpan !RealSrcSpan
+data EpaLocation = EpaSpan !RealSrcSpan !(Strict.Maybe BufSpan)
| EpaDelta !DeltaPos ![LEpaComment]
deriving (Data,Eq)
@@ -447,15 +447,15 @@ getDeltaLine (DifferentLine r _) = r
-- 'EpaLocation'. The parser will never insert a 'DeltaPos', so the
-- partial function is safe.
epaLocationRealSrcSpan :: EpaLocation -> RealSrcSpan
-epaLocationRealSrcSpan (EpaSpan r) = r
+epaLocationRealSrcSpan (EpaSpan r _) = r
epaLocationRealSrcSpan (EpaDelta _ _) = panic "epaLocationRealSrcSpan"
epaLocationFromSrcAnn :: SrcAnn ann -> EpaLocation
-epaLocationFromSrcAnn (SrcSpanAnn EpAnnNotUsed l) = EpaSpan (realSrcSpan l)
-epaLocationFromSrcAnn (SrcSpanAnn (EpAnn anc _ _) _) = EpaSpan (anchor anc)
+epaLocationFromSrcAnn (SrcSpanAnn EpAnnNotUsed l) = EpaSpan (realSrcSpan l) Strict.Nothing
+epaLocationFromSrcAnn (SrcSpanAnn (EpAnn anc _ _) _) = EpaSpan (anchor anc) Strict.Nothing
instance Outputable EpaLocation where
- ppr (EpaSpan r) = text "EpaSpan" <+> ppr r
+ ppr (EpaSpan r _) = text "EpaSpan" <+> ppr r
ppr (EpaDelta d cs) = text "EpaDelta" <+> ppr d <+> ppr cs
instance Outputable AddEpAnn where
@@ -916,8 +916,12 @@ realSrcSpan _ = mkRealSrcSpan l l -- AZ temporary
where
l = mkRealSrcLoc (fsLit "foo") (-1) (-1)
-la2r :: SrcSpanAnn' a -> RealSrcSpan
-la2r l = realSrcSpan (locA l)
+srcSpan2e :: SrcSpan -> EpaLocation
+srcSpan2e (RealSrcSpan s mb) = EpaSpan s mb
+srcSpan2e span = EpaSpan (realSrcSpan span) Strict.Nothing
+
+la2e :: SrcSpanAnn' a -> EpaLocation
+la2e = srcSpan2e . locA
extraToAnnList :: AnnList -> [AddEpAnn] -> AnnList
extraToAnnList (AnnList a o c e t) as = AnnList a o c (e++as) t
@@ -976,7 +980,7 @@ widenSpan :: SrcSpan -> [AddEpAnn] -> SrcSpan
widenSpan s as = foldl combineSrcSpans s (go as)
where
go [] = []
- go (AddEpAnn _ (EpaSpan s):rest) = RealSrcSpan s Strict.Nothing : go rest
+ go (AddEpAnn _ (EpaSpan s mb):rest) = RealSrcSpan s mb : go rest
go (AddEpAnn _ (EpaDelta _ _):rest) = go rest
-- | The annotations need to all come after the anchor. Make sure
@@ -985,7 +989,7 @@ widenRealSpan :: RealSrcSpan -> [AddEpAnn] -> RealSrcSpan
widenRealSpan s as = foldl combineRealSrcSpans s (go as)
where
go [] = []
- go (AddEpAnn _ (EpaSpan s):rest) = s : go rest
+ go (AddEpAnn _ (EpaSpan s _):rest) = s : go rest
go (AddEpAnn _ (EpaDelta _ _):rest) = go rest
widenAnchor :: Anchor -> [AddEpAnn] -> Anchor
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -3646,7 +3646,7 @@ warn_unknown_prag prags span buf len buf2 = do
-- 'AddEpAnn' values for the opening and closing bordering on the start
-- and end of the span
mkParensEpAnn :: RealSrcSpan -> (AddEpAnn, AddEpAnn)
-mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan lo),AddEpAnn AnnCloseP (EpaSpan lc))
+mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan lo Strict.Nothing),AddEpAnn AnnCloseP (EpaSpan lc Strict.Nothing))
where
f = srcSpanFile ss
sl = srcSpanStartLine ss
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -471,13 +471,13 @@ annBinds a cs (HsIPBinds an bs) = (HsIPBinds (add_where a an cs) bs, Nothing)
annBinds _ cs (EmptyLocalBinds x) = (EmptyLocalBinds x, Just cs)
add_where :: AddEpAnn -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList
-add_where an@(AddEpAnn _ (EpaSpan rs)) (EpAnn a (AnnList anc o c r t) cs) cs2
+add_where an@(AddEpAnn _ (EpaSpan rs _)) (EpAnn a (AnnList anc o c r t) cs) cs2
| valid_anchor (anchor a)
= EpAnn (widenAnchor a [an]) (AnnList anc o c (an:r) t) (cs Semi.<> cs2)
| otherwise
= EpAnn (patch_anchor rs a)
(AnnList (fmap (patch_anchor rs) anc) o c (an:r) t) (cs Semi.<> cs2)
-add_where an@(AddEpAnn _ (EpaSpan rs)) EpAnnNotUsed cs
+add_where an@(AddEpAnn _ (EpaSpan rs _)) EpAnnNotUsed cs
= EpAnn (Anchor rs UnchangedAnchor)
(AnnList (Just $ Anchor rs UnchangedAnchor) Nothing Nothing [an] []) cs
add_where (AddEpAnn _ (EpaDelta _ _)) _ _ = panic "add_where"
@@ -501,7 +501,7 @@ fixValbindsAnn (EpAnn anchor (AnnList ma o c r t) cs)
-- | The 'Anchor' for a stmtlist is based on either the location or
-- the first semicolon annotion.
stmtsAnchor :: Located (OrdList AddEpAnn,a) -> Anchor
-stmtsAnchor (L l ((ConsOL (AddEpAnn _ (EpaSpan r)) _), _))
+stmtsAnchor (L l ((ConsOL (AddEpAnn _ (EpaSpan r _)) _), _))
= widenAnchorR (Anchor (realSrcSpan l) UnchangedAnchor) r
stmtsAnchor (L l _) = Anchor (realSrcSpan l) UnchangedAnchor
@@ -1039,13 +1039,13 @@ checkTyClHdr is_cls ty
newAnns (SrcSpanAnn EpAnnNotUsed l) (EpAnn as (AnnParen _ o c) cs) =
let
lr = combineRealSrcSpans (realSrcSpan l) (anchor as)
- an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (EpaSpan $ realSrcSpan l) c []) cs)
+ an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (srcSpan2e l) c []) cs)
in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing)
newAnns _ EpAnnNotUsed = panic "missing AnnParen"
newAnns (SrcSpanAnn (EpAnn ap (AnnListItem ta) csp) l) (EpAnn as (AnnParen _ o c) cs) =
let
lr = combineRealSrcSpans (anchor ap) (anchor as)
- an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (EpaSpan $ realSrcSpan l) c ta) (csp Semi.<> cs))
+ an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (srcSpan2e l) c ta) (csp Semi.<> cs))
in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing)
-- | Yield a parse error if we have a function applied directly to a do block
@@ -2855,7 +2855,7 @@ checkImportSpec ie@(L _ specs) =
mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ([AddEpAnn], ImpExpSubSpec)
mkImpExpSubSpec [] = return ([], ImpExpList [])
mkImpExpSubSpec [L la ImpExpQcWildcard] =
- return ([AddEpAnn AnnDotdot (EpaSpan $ la2r la)], ImpExpAll)
+ return ([AddEpAnn AnnDotdot (la2e la)], ImpExpAll)
mkImpExpSubSpec xs =
if (any (isImpExpQcWildcard . unLoc) xs)
then return $ ([], ImpExpAllWith xs)
@@ -3124,14 +3124,14 @@ mkMultTy pct t arr = HsExplicitMult pct t arr
mkTokenLocation :: SrcSpan -> TokenLocation
mkTokenLocation (UnhelpfulSpan _) = NoTokenLoc
-mkTokenLocation (RealSrcSpan r _) = TokenLoc (EpaSpan r)
+mkTokenLocation (RealSrcSpan r mb) = TokenLoc (EpaSpan r mb)
-- Precondition: the TokenLocation has EpaSpan, never EpaDelta.
token_location_widenR :: TokenLocation -> SrcSpan -> TokenLocation
token_location_widenR NoTokenLoc _ = NoTokenLoc
token_location_widenR tl (UnhelpfulSpan _) = tl
-token_location_widenR (TokenLoc (EpaSpan r1)) (RealSrcSpan r2 _) =
- (TokenLoc (EpaSpan (combineRealSrcSpans r1 r2)))
+token_location_widenR (TokenLoc (EpaSpan r1 mb1)) (RealSrcSpan r2 mb2) =
+ (TokenLoc (EpaSpan (combineRealSrcSpans r1 r2) (liftA2 combineBufSpans mb1 mb2)))
token_location_widenR (TokenLoc (EpaDelta _ _)) _ =
-- Never happens because the parser does not produce EpaDelta.
panic "token_location_widenR: EpaDelta"
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -2130,6 +2130,10 @@ The main parts of the implementation are:
of the `IfDataTyCon` constructor of `IfaceConDecls` by
GHC.Iface.Make.tyConToIfaceDecl.
+* The Template Haskell `Dec` type has an constructor `TypeDataD` for
+ `type data` declarations. When these are converted back to Hs types
+ in a splice, the constructors are placed in the TcCls namespace.
+
-}
warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn)
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -2011,14 +2011,14 @@ printMinimalImports hsc_src imports_w_usage
to_ie_post_rn_var :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn
to_ie_post_rn_var (L l n)
- | isDataOcc $ occName n = L l (IEPattern (EpaSpan $ la2r l) (L (la2na l) n))
- | otherwise = L l (IEName noExtField (L (la2na l) n))
+ | isDataOcc $ occName n = L l (IEPattern (la2e l) (L (la2na l) n))
+ | otherwise = L l (IEName noExtField (L (la2na l) n))
to_ie_post_rn :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn
to_ie_post_rn (L l n)
- | isTcOcc occ && isSymOcc occ = L l (IEType (EpaSpan $ la2r l) (L (la2na l) n))
- | otherwise = L l (IEName noExtField (L (la2na l) n))
+ | isTcOcc occ && isSymOcc occ = L l (IEType (la2e l) (L (la2na l) n))
+ | otherwise = L l (IEName noExtField (L (la2na l) n))
where occ = occName n
{-
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -2681,7 +2681,7 @@ reify_tc_app tc tys
| tc `hasKey` heqTyConKey = TH.EqualityT
| tc `hasKey` eqPrimTyConKey = TH.EqualityT
| tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon)
- | isPromotedDataCon tc = TH.PromotedT (reifyName tc)
+ | isDataKindsPromotedDataCon tc = TH.PromotedT (reifyName tc)
| otherwise = TH.ConT (reifyName tc)
-- See Note [When does a tycon application need an explicit kind
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -270,36 +270,12 @@ cvtDec (TySynD tc tvs rhs)
, tcdRhs = rhs' } }
cvtDec (DataD ctxt tc tvs ksig constrs derivs)
- = do { let isGadtCon (GadtC _ _ _) = True
- isGadtCon (RecGadtC _ _ _) = True
- isGadtCon (ForallC _ _ c) = isGadtCon c
- isGadtCon _ = False
- isGadtDecl = all isGadtCon constrs
- isH98Decl = all (not . isGadtCon) constrs
- ; unless (isGadtDecl || isH98Decl)
- (failWith CannotMixGADTConsWith98Cons)
- ; unless (isNothing ksig || isGadtDecl)
- (failWith KindSigsOnlyAllowedOnGADTs)
- ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
- ; ksig' <- cvtKind `traverse` ksig
- ; cons' <- mapM cvtConstr constrs
- ; derivs' <- cvtDerivs derivs
- ; let defn = HsDataDefn { dd_ext = noExtField
- , dd_cType = Nothing
- , dd_ctxt = mkHsContextMaybe ctxt'
- , dd_kindSig = ksig'
- , dd_cons = DataTypeCons False cons'
- , dd_derivs = derivs' }
- ; returnJustLA $ TyClD noExtField $
- DataDecl { tcdDExt = noAnn
- , tcdLName = tc', tcdTyVars = tvs'
- , tcdFixity = Prefix
- , tcdDataDefn = defn } }
+ = cvtDataDec ctxt tc tvs ksig constrs derivs
cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
= do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
; ksig' <- cvtKind `traverse` ksig
- ; con' <- cvtConstr constr
+ ; con' <- cvtConstr cNameN constr
; derivs' <- cvtDerivs derivs
; let defn = HsDataDefn { dd_ext = noExtField
, dd_cType = Nothing
@@ -313,6 +289,9 @@ cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
, tcdFixity = Prefix
, tcdDataDefn = defn } }
+cvtDec (TypeDataD tc tvs ksig constrs)
+ = cvtTypeDataDec tc tvs ksig constrs
+
cvtDec (ClassD ctxt cl tvs fds decs)
= do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
; fds' <- mapM cvt_fundep fds
@@ -368,7 +347,7 @@ cvtDec (DataFamilyD tc tvs kind)
cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)
= do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys
; ksig' <- cvtKind `traverse` ksig
- ; cons' <- mapM cvtConstr constrs
+ ; cons' <- mapM (cvtConstr cNameN) constrs
; derivs' <- cvtDerivs derivs
; let defn = HsDataDefn { dd_ext = noExtField
, dd_cType = Nothing
@@ -390,7 +369,7 @@ cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)
cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs)
= do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys
; ksig' <- cvtKind `traverse` ksig
- ; con' <- cvtConstr constr
+ ; con' <- cvtConstr cNameN constr
; derivs' <- cvtDerivs derivs
; let defn = HsDataDefn { dd_ext = noExtField
, dd_cType = Nothing
@@ -484,6 +463,59 @@ cvtDec (TH.PatSynSigD nm ty)
cvtDec (TH.ImplicitParamBindD _ _)
= failWith InvalidImplicitParamBinding
+-- Convert a @data@ declaration.
+cvtDataDec :: TH.Cxt -> TH.Name -> [TH.TyVarBndr ()]
+ -> Maybe TH.Kind -> [TH.Con] -> [TH.DerivClause]
+ -> CvtM (Maybe (LHsDecl GhcPs))
+cvtDataDec = cvtGenDataDec False
+
+-- Convert a @type data@ declaration.
+-- These have neither contexts nor derived clauses.
+-- See Note [Type data declarations] in GHC.Rename.Module.
+cvtTypeDataDec :: TH.Name -> [TH.TyVarBndr ()] -> Maybe TH.Kind -> [TH.Con]
+ -> CvtM (Maybe (LHsDecl GhcPs))
+cvtTypeDataDec tc tvs ksig constrs
+ = cvtGenDataDec True [] tc tvs ksig constrs []
+
+-- Convert a @data@ or @type data@ declaration (flagged by the Bool arg).
+-- See Note [Type data declarations] in GHC.Rename.Module.
+cvtGenDataDec :: Bool -> TH.Cxt -> TH.Name -> [TH.TyVarBndr ()]
+ -> Maybe TH.Kind -> [TH.Con] -> [TH.DerivClause]
+ -> CvtM (Maybe (LHsDecl GhcPs))
+cvtGenDataDec type_data ctxt tc tvs ksig constrs derivs
+ = do { let isGadtCon (GadtC _ _ _) = True
+ isGadtCon (RecGadtC _ _ _) = True
+ isGadtCon (ForallC _ _ c) = isGadtCon c
+ isGadtCon _ = False
+ isGadtDecl = all isGadtCon constrs
+ isH98Decl = all (not . isGadtCon) constrs
+ -- A constructor in a @data@ or @newtype@ declaration is
+ -- a data constructor. A constructor in a @type data@
+ -- declaration is a type constructor.
+ -- See Note [Type data declarations] in GHC.Rename.Module.
+ con_name
+ | type_data = tconNameN
+ | otherwise = cNameN
+ ; unless (isGadtDecl || isH98Decl)
+ (failWith CannotMixGADTConsWith98Cons)
+ ; unless (isNothing ksig || isGadtDecl)
+ (failWith KindSigsOnlyAllowedOnGADTs)
+ ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
+ ; ksig' <- cvtKind `traverse` ksig
+ ; cons' <- mapM (cvtConstr con_name) constrs
+ ; derivs' <- cvtDerivs derivs
+ ; let defn = HsDataDefn { dd_ext = noExtField
+ , dd_cType = Nothing
+ , dd_ctxt = mkHsContextMaybe ctxt'
+ , dd_kindSig = ksig'
+ , dd_cons = DataTypeCons type_data cons'
+ , dd_derivs = derivs' }
+ ; returnJustLA $ TyClD noExtField $
+ DataDecl { tcdDExt = noAnn
+ , tcdLName = tc', tcdTyVars = tvs'
+ , tcdFixity = Prefix
+ , tcdDataDefn = defn } }
+
----------------
cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn (TySynEqn mb_bndrs lhs rhs)
@@ -617,30 +649,31 @@ is_ip_bind decl = Right decl
-- Data types
---------------------------------------------------
-cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs)
+cvtConstr :: (TH.Name -> CvtM (LocatedN RdrName)) -- ^ convert constructor name
+ -> TH.Con -> CvtM (LConDecl GhcPs)
-cvtConstr (NormalC c strtys)
- = do { c' <- cNameN c
+cvtConstr con_name (NormalC c strtys)
+ = do { c' <- con_name c
; tys' <- mapM cvt_arg strtys
; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing (PrefixCon noTypeArgs (map hsLinear tys')) }
-cvtConstr (RecC c varstrtys)
- = do { c' <- cNameN c
+cvtConstr con_name (RecC c varstrtys)
+ = do { c' <- con_name c
; args' <- mapM cvt_id_arg varstrtys
; con_decl <- wrapParLA (mkConDeclH98 noAnn c' Nothing Nothing . RecCon) args'
; returnLA con_decl }
-cvtConstr (InfixC st1 c st2)
- = do { c' <- cNameN c
+cvtConstr con_name (InfixC st1 c st2)
+ = do { c' <- con_name c
; st1' <- cvt_arg st1
; st2' <- cvt_arg st2
; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing
(InfixCon (hsLinear st1') (hsLinear st2')) }
-cvtConstr (ForallC tvs ctxt con)
+cvtConstr con_name (ForallC tvs ctxt con)
= do { tvs' <- cvtTvs tvs
; ctxt' <- cvtContext funPrec ctxt
- ; L _ con' <- cvtConstr con
+ ; L _ con' <- cvtConstr con_name con
; returnLA $ add_forall tvs' ctxt' con' }
where
add_cxt lcxt Nothing = mkHsContextMaybe lcxt
@@ -668,18 +701,18 @@ cvtConstr (ForallC tvs ctxt con)
where
all_tvs = tvs' ++ ex_tvs
-cvtConstr (GadtC c strtys ty) = case nonEmpty c of
+cvtConstr con_name (GadtC c strtys ty) = case nonEmpty c of
Nothing -> failWith GadtNoCons
Just c -> do
- { c' <- mapM cNameN c
+ { c' <- mapM con_name c
; args <- mapM cvt_arg strtys
; ty' <- cvtType ty
; mk_gadt_decl c' (PrefixConGADT $ map hsLinear args) ty'}
-cvtConstr (RecGadtC c varstrtys ty) = case nonEmpty c of
+cvtConstr con_name (RecGadtC c varstrtys ty) = case nonEmpty c of
Nothing -> failWith RecGadtNoCons
Just c -> do
- { c' <- mapM cNameN c
+ { c' <- mapM con_name c
; ty' <- cvtType ty
; rec_flds <- mapM cvt_id_arg varstrtys
; lrec_flds <- returnLA rec_flds
=====================================
compiler/GHC/Types/SrcLoc.hs
=====================================
@@ -70,6 +70,7 @@ module GHC.Types.SrcLoc (
BufSpan(..),
getBufSpan,
removeBufSpan,
+ combineBufSpans,
-- * Located
Located,
=====================================
libraries/template-haskell/Language/Haskell/TH/Lib.hs
=====================================
@@ -86,7 +86,7 @@ module Language.Haskell.TH.Lib (
-- *** Top Level Declarations
-- **** Data
- valD, funD, tySynD, dataD, newtypeD,
+ valD, funD, tySynD, dataD, newtypeD, typeDataD,
derivClause, DerivClause(..),
stockStrategy, anyclassStrategy, newtypeStrategy,
viaStrategy, DerivStrategy(..),
@@ -131,8 +131,8 @@ module Language.Haskell.TH.Lib (
thisModule,
-- ** Documentation
- withDecDoc, withDecsDoc, funD_doc, dataD_doc, newtypeD_doc, dataInstD_doc,
- newtypeInstD_doc, patSynD_doc
+ withDecDoc, withDecsDoc, funD_doc, dataD_doc, newtypeD_doc,
+ typeDataD_doc, dataInstD_doc, newtypeInstD_doc, patSynD_doc
) where
@@ -140,6 +140,7 @@ import Language.Haskell.TH.Lib.Internal hiding
( tySynD
, dataD
, newtypeD
+ , typeDataD
, classD
, pragRuleD
, dataInstD
@@ -212,6 +213,13 @@ newtypeD ctxt tc tvs ksig con derivs =
derivs1 <- sequenceA derivs
return (NewtypeD ctxt1 tc tvs ksig con1 derivs1)
+typeDataD :: Quote m => Name -> [TyVarBndr ()] -> Maybe Kind -> [m Con]
+ -> m Dec
+typeDataD tc tvs ksig cons =
+ do
+ cons1 <- sequenceA cons
+ return (TypeDataD tc tvs ksig cons1)
+
classD :: Quote m => m Cxt -> Name -> [TyVarBndr ()] -> [FunDep] -> [m Dec] -> m Dec
classD ctxt cls tvs fds decs =
do
=====================================
libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
=====================================
@@ -441,6 +441,15 @@ newtypeD ctxt tc tvs ksig con derivs =
derivs1 <- sequenceA derivs
pure (NewtypeD ctxt1 tc tvs1 ksig1 con1 derivs1)
+typeDataD :: Quote m => Name -> [m (TyVarBndr ())] -> Maybe (m Kind) -> [m Con]
+ -> m Dec
+typeDataD tc tvs ksig cons =
+ do
+ tvs1 <- sequenceA tvs
+ ksig1 <- sequenceA ksig
+ cons1 <- sequenceA cons
+ pure (TypeDataD tc tvs1 ksig1 cons1)
+
classD :: Quote m => m Cxt -> Name -> [m (TyVarBndr ())] -> [FunDep] -> [m Dec] -> m Dec
classD ctxt cls tvs fds decs =
do
@@ -1033,6 +1042,7 @@ withDecDoc doc dec = do
doc_loc (ValD (VarP n) _ _) = Just $ DeclDoc n
doc_loc (DataD _ n _ _ _ _) = Just $ DeclDoc n
doc_loc (NewtypeD _ n _ _ _ _) = Just $ DeclDoc n
+ doc_loc (TypeDataD n _ _ _) = Just $ DeclDoc n
doc_loc (TySynD n _ _) = Just $ DeclDoc n
doc_loc (ClassD _ n _ _ _) = Just $ DeclDoc n
doc_loc (SigD n _) = Just $ DeclDoc n
@@ -1108,6 +1118,19 @@ newtypeD_doc ctxt tc tvs ksig con_with_docs@(con, _, _) derivs mdoc = do
let dec = newtypeD ctxt tc tvs ksig con derivs
maybe dec (flip withDecDoc dec) mdoc
+-- | Variant of 'typeDataD' that attaches Haddock documentation.
+typeDataD_doc :: Name -> [Q (TyVarBndr ())] -> Maybe (Q Kind)
+ -> [(Q Con, Maybe String, [Maybe String])]
+ -- ^ List of constructors, documentation for the constructor, and
+ -- documentation for the arguments
+ -> Maybe String
+ -- ^ Documentation to attach to the data declaration
+ -> Q Dec
+typeDataD_doc tc tvs ksig cons_with_docs mdoc = do
+ qAddModFinalizer $ mapM_ docCons cons_with_docs
+ let dec = typeDataD tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs)
+ maybe dec (flip withDecDoc dec) mdoc
+
-- | Variant of 'dataInstD' that attaches Haddock documentation.
dataInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type -> Maybe (Q Kind)
-> [(Q Con, Maybe String, [Maybe String])]
=====================================
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
=====================================
@@ -399,6 +399,8 @@ ppr_dec _ (DataD ctxt t xs ksig cs decs)
= ppr_data empty ctxt (Just t) (hsep (map ppr xs)) ksig cs decs
ppr_dec _ (NewtypeD ctxt t xs ksig c decs)
= ppr_newtype empty ctxt (Just t) (sep (map ppr xs)) ksig c decs
+ppr_dec _ (TypeDataD t xs ksig cs)
+ = ppr_type_data empty [] (Just t) (hsep (map ppr xs)) ksig cs []
ppr_dec _ (ClassD ctxt c xs fds ds)
= text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds
$$ where_clause ds
@@ -495,6 +497,10 @@ ppr_newtype :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivCla
-> Doc
ppr_newtype maybeInst ctxt t argsDoc ksig c decs = ppr_typedef "newtype" maybeInst ctxt t argsDoc ksig [c] decs
+ppr_type_data :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]
+ -> Doc
+ppr_type_data = ppr_typedef "type data"
+
ppr_typedef :: String -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc
ppr_typedef data_or_newtype maybeInst ctxt t argsDoc ksig cs decs
= sep [text data_or_newtype <+> maybeInst
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -2399,6 +2399,9 @@ data Dec
Con [DerivClause] -- ^ @{ newtype Cxt x => T x = A (B x)
-- deriving (Z,W Q)
-- deriving stock Eq }@
+ | TypeDataD Name [TyVarBndr ()]
+ (Maybe Kind) -- Kind signature (allowed only for GADTs)
+ [Con] -- ^ @{ type data T x = A x | B (T x) }@
| TySynD Name [TyVarBndr ()] Type -- ^ @{ type T x = (x,x) }@
| ClassD Cxt Name [TyVarBndr ()]
[FunDep] [Dec] -- ^ @{ class Eq a => Ord a where ds }@
=====================================
libraries/template-haskell/changelog.md
=====================================
@@ -5,6 +5,9 @@
* The `Ppr.pprInfixT` function has gained a `Precedence` argument.
* The values of named precedence levels like `Ppr.appPrec` have changed.
+ * Add `TypeDataD` constructor to the `Dec` type for `type data`
+ declarations (GHC proposal #106).
+
## 2.19.0.0
* Add `DefaultD` constructor to support Haskell `default` declarations.
=====================================
testsuite/tests/lib/base/all.T
=====================================
@@ -1,7 +1,7 @@
test('DataTypeOrd', normal, compile_and_run, [''])
test('T16586', normal, compile_and_run, ['-O2'])
# Event-manager not supported on Windows
-test('T16916', [when(opsys('mingw32'), skip), js_broken(22261)], compile_and_run, ['-O2 -threaded -with-rtsopts="-I0" -rtsopts'])
+test('T16916', [when(opsys('mingw32'), skip), js_broken(22261), fragile(16966)], compile_and_run, ['-O2 -threaded -with-rtsopts="-I0" -rtsopts'])
test('T17310', normal, compile, [''])
test('T19691', normal, compile, [''])
test('executablePath', [extra_run_opts(config.os), js_broken(22261)], compile_and_run, [''])
=====================================
testsuite/tests/type-data/should_compile/TD_TH_splice.hs
=====================================
@@ -0,0 +1,18 @@
+-- Check that splicing in a quoted declaration has the same effect as
+-- giving the declaration directly.
+{-# LANGUAGE TemplateHaskell, TypeData, GADTs #-}
+
+module TD_TH_splice where
+
+import Data.Kind (Type)
+
+-- splice should be equivalent to giving the declaration directly
+$( [d| type data Nat = Zero | Succ Nat |] )
+
+data Vec :: Nat -> Type -> Type where
+ VNil :: Vec Zero a
+ VCons :: a -> Vec n a -> Vec (Succ n) a
+
+instance Functor (Vec n) where
+ fmap _ VNil = VNil
+ fmap f (VCons x xs) = VCons (f x) (fmap f xs)
=====================================
testsuite/tests/type-data/should_compile/all.T
=====================================
@@ -3,4 +3,5 @@ test('TDExistential', normal, compile, [''])
test('TDGADT', normal, compile, [''])
test('TDGoodConsConstraints', normal, compile, [''])
test('TDVector', normal, compile, [''])
+test('TD_TH_splice', normal, compile, [''])
test('T22315a', [extra_files(['T22315a/'])], multimod_compile, ['T22315a.Lib T22315a.Main', '-v0'])
=====================================
testsuite/tests/type-data/should_run/T22500.hs
=====================================
@@ -0,0 +1,9 @@
+-- Check that a quoted data type declaration is printed correctly
+{-# LANGUAGE TemplateHaskellQuotes, TypeData #-}
+
+module Main where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Ppr
+
+main = putStrLn . pprint =<< runQ [d| type data Nat = Zero | Succ Nat |]
=====================================
testsuite/tests/type-data/should_run/T22500.stdout
=====================================
@@ -0,0 +1,3 @@
+type data Nat_0
+ = Zero_1
+ | Succ_2 Nat_0
=====================================
testsuite/tests/type-data/should_run/all.T
=====================================
@@ -1,2 +1,3 @@
test('T22332a', exit_code(1), compile_and_run, [''])
test('T22315b', extra_files(['T22315b.hs']), ghci_script, ['T22315b.script'])
+test('T22500', normal, compile_and_run, [''])
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -543,7 +543,7 @@ printStringAtAAL (EpAnn anc an cs) l str = do
printStringAtAAC :: (Monad m, Monoid w)
=> CaptureComments -> EpaLocation -> String -> EP w m EpaLocation
-printStringAtAAC capture (EpaSpan r) s = printStringAtRsC capture r s
+printStringAtAAC capture (EpaSpan r _) s = printStringAtRsC capture r s
printStringAtAAC capture (EpaDelta d cs) s = do
mapM_ (printOneComment . tokComment) cs
pe1 <- getPriorEndD
@@ -4108,7 +4108,7 @@ printUnicode anc n = do
s -> s
loc <- printStringAtAAC NoCaptureComments (EpaDelta (SameLine 0) []) str
case loc of
- EpaSpan _ -> return anc
+ EpaSpan _ _ -> return anc
EpaDelta dp [] -> return anc { anchor_op = MovedAnchor dp }
EpaDelta _ _cs -> error "printUnicode should not capture comments"
=====================================
utils/check-exact/Parsers.hs
=====================================
@@ -285,7 +285,7 @@ fixModuleTrailingComments (GHC.L l p) = GHC.L l p'
rebalance al cs = cs'
where
cs' = case GHC.al_close al of
- Just (GHC.AddEpAnn _ (GHC.EpaSpan ss)) ->
+ Just (GHC.AddEpAnn _ (GHC.EpaSpan ss _)) ->
let
pc = GHC.priorComments cs
fc = GHC.getFollowingComments cs
=====================================
utils/check-exact/Transform.hs
=====================================
@@ -213,7 +213,7 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc rs') cs) ns (H
L (SrcSpanAnn EpAnnNotUsed ll) _ -> realSrcSpan ll
L (SrcSpanAnn (EpAnn anc' _ _) _) _ -> anchor anc' -- TODO MovedAnchor?
dc' = case dca of
- EpaSpan r -> AddEpAnn kw (EpaDelta (ss2delta (ss2posEnd rd) r) [])
+ EpaSpan r _ -> AddEpAnn kw (EpaDelta (ss2delta (ss2posEnd rd) r) [])
EpaDelta _ _ -> AddEpAnn kw dca
-- ---------------------------------
@@ -223,7 +223,7 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc rs') cs) ns (H
(L (SrcSpanAnn EpAnnNotUsed ll) b)
-> let
op = case dca of
- EpaSpan r -> MovedAnchor (ss2delta (ss2posEnd r) (realSrcSpan ll))
+ EpaSpan r _ -> MovedAnchor (ss2delta (ss2posEnd r) (realSrcSpan ll))
EpaDelta _ _ -> MovedAnchor (SameLine 1)
in (L (SrcSpanAnn (EpAnn (Anchor (realSrcSpan ll) op) mempty emptyComments) ll) b)
(L (SrcSpanAnn (EpAnn (Anchor r op) a c) ll) b)
@@ -231,7 +231,7 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc rs') cs) ns (H
op' = case op of
MovedAnchor _ -> op
_ -> case dca of
- EpaSpan dcr -> MovedAnchor (ss2delta (ss2posEnd dcr) r)
+ EpaSpan dcr _ -> MovedAnchor (ss2delta (ss2posEnd dcr) r)
EpaDelta _ _ -> MovedAnchor (SameLine 1)
in (L (SrcSpanAnn (EpAnn (Anchor r op') a c) ll) b)
@@ -341,13 +341,13 @@ getEntryDP _ = SameLine 1
addEpaLocationDelta :: LayoutStartCol -> RealSrcSpan -> EpaLocation -> EpaLocation
addEpaLocationDelta _off _anc (EpaDelta d cs) = EpaDelta d cs
-addEpaLocationDelta off anc (EpaSpan r)
+addEpaLocationDelta off anc (EpaSpan r _)
= EpaDelta (adjustDeltaForOffset off (ss2deltaEnd anc r)) []
-- Set the entry DP for an element coming after an existing keyword annotation
setEntryDPFromAnchor :: LayoutStartCol -> EpaLocation -> LocatedA t -> LocatedA t
setEntryDPFromAnchor _off (EpaDelta _ _) (L la a) = L la a
-setEntryDPFromAnchor off (EpaSpan anc) ll@(L la _) = setEntryDP ll dp'
+setEntryDPFromAnchor off (EpaSpan anc _) ll@(L la _) = setEntryDP ll dp'
where
r = case la of
(SrcSpanAnn EpAnnNotUsed l) -> realSrcSpan l
@@ -944,7 +944,7 @@ instance HasDecls (LocatedA (HsExpr GhcPs)) where
(L (TokenLoc l) ls, L (TokenLoc i) is) ->
let
off = case l of
- (EpaSpan r) -> LayoutStartCol $ snd $ ss2pos r
+ (EpaSpan r _) -> LayoutStartCol $ snd $ ss2pos r
(EpaDelta (SameLine _) _) -> LayoutStartCol 0
(EpaDelta (DifferentLine _ c) _) -> LayoutStartCol c
ex'' = setEntryDPFromAnchor off i ex
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -119,7 +119,7 @@ undelta (l,_) (DifferentLine dl dc) (LayoutStartCol co) = (fl,fc)
fc = co + dc
undeltaSpan :: RealSrcSpan -> AnnKeywordId -> DeltaPos -> AddEpAnn
-undeltaSpan anchor kw dp = AddEpAnn kw (EpaSpan sp)
+undeltaSpan anchor kw dp = AddEpAnn kw (EpaSpan sp Strict.Nothing)
where
(l,c) = undelta (ss2pos anchor) dp (LayoutStartCol 0)
len = length (keywordToString kw)
@@ -256,7 +256,7 @@ sortEpaComments cs = sortBy cmp cs
-- | Makes a comment which originates from a specific keyword.
mkKWComment :: AnnKeywordId -> EpaLocation -> Comment
-mkKWComment kw (EpaSpan ss)
+mkKWComment kw (EpaSpan ss _)
= Comment (keywordToString kw) (Anchor ss UnchangedAnchor) ss (Just kw)
mkKWComment kw (EpaDelta dp _)
= Comment (keywordToString kw) (Anchor placeholderRealSpan (MovedAnchor dp)) placeholderRealSpan (Just kw)
@@ -373,7 +373,7 @@ addEpAnnLoc (AddEpAnn _ l) = l
-- TODO: move this to GHC
anchorToEpaLocation :: Anchor -> EpaLocation
-anchorToEpaLocation (Anchor r UnchangedAnchor) = EpaSpan r
+anchorToEpaLocation (Anchor r UnchangedAnchor) = EpaSpan r Strict.Nothing
anchorToEpaLocation (Anchor _ (MovedAnchor dp)) = EpaDelta dp []
-- ---------------------------------------------------------------------
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b47331023cc5ae0e112f7eaec90d6461dcd186fa...1edc25795ae09bfd39e5c0e5e185c64553f290c3
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b47331023cc5ae0e112f7eaec90d6461dcd186fa...1edc25795ae09bfd39e5c0e5e185c64553f290c3
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221205/92ef06cb/attachment-0001.html>
More information about the ghc-commits
mailing list