[Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: use EpToken in HsAppKindTy, HsArg, HsBndrVis
Vladislav Zavialov (@int-index)
gitlab at gitlab.haskell.org
Wed Dec 6 21:17:25 UTC 2023
Vladislav Zavialov pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC
Commits:
1ac43f97 by Vladislav Zavialov at 2023-12-07T00:15:04+03:00
EPA: use EpToken in HsAppKindTy, HsArg, HsBndrVis
- - - - -
25 changed files:
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/ThToHs.hs
- compiler/Language/Haskell/Syntax/Type.hs
- testsuite/tests/ghc-api/exactprint/Test20239.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/parser/should_compile/KindSigs.stderr
- testsuite/tests/parser/should_compile/T15323.stderr
- testsuite/tests/parser/should_compile/T20452.stderr
- utils/check-exact/ExactPrint.hs
- utils/haddock
Changes:
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -101,7 +101,6 @@ import Language.Haskell.Syntax.Type
import {-# SOURCE #-} GHC.Hs.Expr ( pprUntypedSplice, HsUntypedSpliceResult(..) )
-import Language.Haskell.Syntax.Concrete
import Language.Haskell.Syntax.Extension
import GHC.Core.DataCon( SrcStrictness(..), SrcUnpackedness(..), HsImplBang(..) )
import GHC.Hs.Extension
@@ -340,6 +339,14 @@ instance NamedThing (HsTyVarBndr flag GhcRn) where
getName (UserTyVar _ _ v) = unLoc v
getName (KindedTyVar _ _ v _) = unLoc v
+type instance XBndrRequired (GhcPass _) = NoExtField
+
+type instance XBndrInvisible GhcPs = EpToken "@"
+type instance XBndrInvisible GhcRn = NoExtField
+type instance XBndrInvisible GhcTc = NoExtField
+
+type instance XXBndrVis (GhcPass _) = DataConCantHappen
+
type instance XForAllTy (GhcPass _) = NoExtField
type instance XQualTy (GhcPass _) = NoExtField
type instance XTyVar (GhcPass _) = EpAnn [AddEpAnn]
@@ -354,7 +361,9 @@ type instance XIParamTy (GhcPass _) = EpAnn [AddEpAnn]
type instance XStarTy (GhcPass _) = NoExtField
type instance XKindSig (GhcPass _) = EpAnn [AddEpAnn]
-type instance XAppKindTy (GhcPass _) = NoExtField
+type instance XAppKindTy GhcPs = EpToken "@"
+type instance XAppKindTy GhcRn = NoExtField
+type instance XAppKindTy GhcTc = NoExtField
type instance XSpliceTy GhcPs = NoExtField
type instance XSpliceTy GhcRn = HsUntypedSpliceResult (LHsType GhcRn)
@@ -546,10 +555,10 @@ mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)]
-> LHsType (GhcPass p)
mkHsAppTys = foldl' mkHsAppTy
-mkHsAppKindTy :: LHsType (GhcPass p) -> LHsToken "@" (GhcPass p) -> LHsType (GhcPass p)
+mkHsAppKindTy :: XAppKindTy (GhcPass p)
+ -> LHsType (GhcPass p) -> LHsType (GhcPass p)
-> LHsType (GhcPass p)
-mkHsAppKindTy ty at k
- = addCLocA ty k (HsAppKindTy noExtField ty at k)
+mkHsAppKindTy x ty k = addCLocA ty k (HsAppKindTy x ty k)
{-
************************************************************************
@@ -598,7 +607,7 @@ hsTyGetAppHead_maybe = go
where
go (L _ (HsTyVar _ _ ln)) = Just ln
go (L _ (HsAppTy _ l _)) = go l
- go (L _ (HsAppKindTy _ t _ _)) = go t
+ go (L _ (HsAppKindTy _ t _)) = go t
go (L _ (HsOpTy _ _ _ ln _)) = Just ln
go (L _ (HsParTy _ t)) = go t
go (L _ (HsKindSig _ t _)) = go t
@@ -606,19 +615,29 @@ hsTyGetAppHead_maybe = go
------------------------------------------------------------
+type instance XValArg (GhcPass _) = NoExtField
+
+type instance XTypeArg GhcPs = EpToken "@"
+type instance XTypeArg GhcRn = NoExtField
+type instance XTypeArg GhcTc = NoExtField
+
+type instance XArgPar (GhcPass _) = SrcSpan
+
+type instance XXArg (GhcPass _) = DataConCantHappen
+
-- | Compute the 'SrcSpan' associated with an 'LHsTypeArg'.
-lhsTypeArgSrcSpan :: LHsTypeArg (GhcPass pass) -> SrcSpan
+lhsTypeArgSrcSpan :: LHsTypeArg GhcPs -> SrcSpan
lhsTypeArgSrcSpan arg = case arg of
- HsValArg tm -> getLocA tm
- HsTypeArg at ty -> getTokenSrcSpan (getLoc at) `combineSrcSpans` getLocA ty
+ HsValArg _ tm -> getLocA tm
+ HsTypeArg at ty -> getEpTokenSrcSpan at `combineSrcSpans` getLocA ty
HsArgPar sp -> sp
--------------------------------
numVisibleArgs :: [HsArg p tm ty] -> Arity
numVisibleArgs = count is_vis
- where is_vis (HsValArg _) = True
- is_vis _ = False
+ where is_vis (HsValArg _ _) = True
+ is_vis _ = False
--------------------------------
@@ -633,7 +652,7 @@ numVisibleArgs = count is_vis
-- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double, HsVarArg Ordering] = (Char ++ Double) Ordering
-- @
pprHsArgsApp :: (OutputableBndr id, Outputable tm, Outputable ty)
- => id -> LexicalFixity -> [HsArg p tm ty] -> SDoc
+ => id -> LexicalFixity -> [HsArg (GhcPass p) tm ty] -> SDoc
pprHsArgsApp thing fixity (argl:argr:args)
| Infix <- fixity
= let pp_op_app = hsep [ ppr_single_hs_arg argl
@@ -648,7 +667,7 @@ pprHsArgsApp thing _fixity args
-- | Pretty-print a prefix identifier to a list of 'HsArg's.
ppr_hs_args_prefix_app :: (Outputable tm, Outputable ty)
- => SDoc -> [HsArg p tm ty] -> SDoc
+ => SDoc -> [HsArg (GhcPass p) tm ty] -> SDoc
ppr_hs_args_prefix_app acc [] = acc
ppr_hs_args_prefix_app acc (arg:args) =
case arg of
@@ -658,8 +677,8 @@ ppr_hs_args_prefix_app acc (arg:args) =
-- | Pretty-print an 'HsArg' in isolation.
ppr_single_hs_arg :: (Outputable tm, Outputable ty)
- => HsArg p tm ty -> SDoc
-ppr_single_hs_arg (HsValArg tm) = ppr tm
+ => HsArg (GhcPass p) tm ty -> SDoc
+ppr_single_hs_arg (HsValArg _ tm) = ppr tm
ppr_single_hs_arg (HsTypeArg _ ty) = char '@' <> ppr ty
-- GHC shouldn't be constructing ASTs such that this case is ever reached.
-- Still, it's possible some wily user might construct their own AST that
@@ -669,8 +688,8 @@ ppr_single_hs_arg (HsArgPar{}) = empty
-- | This instance is meant for debug-printing purposes. If you wish to
-- pretty-print an application of 'HsArg's, use 'pprHsArgsApp' instead.
instance (Outputable tm, Outputable ty) => Outputable (HsArg (GhcPass p) tm ty) where
- ppr (HsValArg tm) = text "HsValArg" <+> ppr tm
- ppr (HsTypeArg at ty) = text "HsTypeArg" <+> ppr at <+> ppr ty
+ ppr (HsValArg _ tm) = text "HsValArg" <+> ppr tm
+ ppr (HsTypeArg _ ty) = text "HsTypeArg" <+> ppr ty
ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp
--------------------------------
@@ -1041,13 +1060,13 @@ instance OutputableBndrFlag Specificity p where
pprTyVarBndr (KindedTyVar _ SpecifiedSpec n k) = parens $ hsep [ppr n, dcolon, ppr k]
pprTyVarBndr (KindedTyVar _ InferredSpec n k) = braces $ hsep [ppr n, dcolon, ppr k]
-instance OutputableBndrFlag (HsBndrVis p') p where
+instance OutputableBndrFlag (HsBndrVis (GhcPass p')) p where
pprTyVarBndr (UserTyVar _ vis n) = pprHsBndrVis vis $ ppr n
pprTyVarBndr (KindedTyVar _ vis n k) =
pprHsBndrVis vis $ parens $ hsep [ppr n, dcolon, ppr k]
-pprHsBndrVis :: HsBndrVis pass -> SDoc -> SDoc
-pprHsBndrVis HsBndrRequired d = d
+pprHsBndrVis :: HsBndrVis (GhcPass p) -> SDoc -> SDoc
+pprHsBndrVis (HsBndrRequired _) d = d
pprHsBndrVis (HsBndrInvisible _) d = char '@' <> d
instance OutputableBndrId p => Outputable (HsSigType (GhcPass p)) where
@@ -1273,7 +1292,7 @@ ppr_mono_ty (HsStarTy _ isUni) = char (if isUni then '★' else '*')
ppr_mono_ty (HsAppTy _ fun_ty arg_ty)
= hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty]
-ppr_mono_ty (HsAppKindTy _ ty _ k)
+ppr_mono_ty (HsAppKindTy _ ty k)
= ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k
ppr_mono_ty (HsOpTy _ prom ty1 (L _ op) ty2)
= sep [ ppr_mono_lty ty1
@@ -1388,7 +1407,7 @@ lhsTypeHasLeadingPromotionQuote ty
go (HsWildCardTy{}) = False
go (HsStarTy{}) = False
go (HsAppTy _ t _) = goL t
- go (HsAppKindTy _ t _ _) = goL t
+ go (HsAppKindTy _ t _) = goL t
go (HsParTy{}) = False
go (HsDocTy _ t _) = goL t
go (XHsType{}) = False
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -633,28 +633,32 @@ nlHsTyVar p x = noLocA (HsTyVar noAnn p (noLocA x))
nlHsFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) a b)
nlHsParTy t = noLocA (HsParTy noAnn t)
-nlHsTyConApp :: IsSrcSpanAnn p a
+nlHsTyConApp :: forall p a. IsSrcSpanAnn p a
=> PromotionFlag
-> LexicalFixity -> IdP (GhcPass p)
-> [LHsTypeArg (GhcPass p)] -> LHsType (GhcPass p)
nlHsTyConApp prom fixity tycon tys
| Infix <- fixity
- , HsValArg ty1 : HsValArg ty2 : rest <- tys
+ , HsValArg _ ty1 : HsValArg _ ty2 : rest <- tys
= foldl' mk_app (noLocA $ HsOpTy noAnn prom ty1 (noLocA tycon) ty2) rest
| otherwise
= foldl' mk_app (nlHsTyVar prom tycon) tys
where
mk_app :: LHsType (GhcPass p) -> LHsTypeArg (GhcPass p) -> LHsType (GhcPass p)
- mk_app fun@(L _ (HsOpTy {})) arg = mk_app (noLocA $ HsParTy noAnn fun) arg
+ mk_app fun@(L _ (HsOpTy {})) arg = mk_app (nlHsParTy fun) arg
-- parenthesize things like `(A + B) C`
- mk_app fun (HsValArg ty) = noLocA (HsAppTy noExtField fun ty)
- mk_app fun (HsTypeArg at ki) = noLocA (HsAppKindTy noExtField fun at ki)
- mk_app fun (HsArgPar _) = noLocA (HsParTy noAnn fun)
+ mk_app fun (HsValArg _ ty) = nlHsAppTy fun ty
+ mk_app fun (HsTypeArg _ ki) = nlHsAppKindTy fun ki
+ mk_app fun (HsArgPar _) = nlHsParTy fun
-nlHsAppKindTy ::
+nlHsAppKindTy :: forall p. IsPass p =>
LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p)
-nlHsAppKindTy f k
- = noLocA (HsAppKindTy noExtField f noHsTok k)
+nlHsAppKindTy f k = noLocA (HsAppKindTy x f k)
+ where
+ x = case ghcPass @p of
+ GhcPs -> noAnn
+ GhcRn -> noExtField
+ GhcTc -> noExtField
{-
Tuples. All these functions are *pre-typechecker* because they lack
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -693,21 +693,21 @@ repTyFamEqn (FamEqn { feqn_tycon = tc_name
; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs ->
do { tys1 <- case fixity of
Prefix -> repTyArgs (repNamedTyCon tc) tys
- Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
+ Infix -> do { (HsValArg _ t1: HsValArg _ t2: args) <- checkTys tys
; t1' <- repLTy t1
; t2' <- repLTy t2
; repTyArgs (repTInfix t1' tc t2') args }
; rhs1 <- repLTy rhs
; repTySynEqn mb_exp_bndrs tys1 rhs1 } }
where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]
- checkTys tys@(HsValArg _:HsValArg _:_) = return tys
+ checkTys tys@(HsValArg _ _:HsValArg _ _:_) = return tys
checkTys _ = panic "repTyFamEqn:checkTys"
repTyArgs :: MetaM (Core (M TH.Type)) -> [LHsTypeArg GhcRn] -> MetaM (Core (M TH.Type))
repTyArgs f [] = f
-repTyArgs f (HsValArg ty : as) = do { f' <- f
- ; ty' <- repLTy ty
- ; repTyArgs (repTapp f' ty') as }
+repTyArgs f (HsValArg _ ty : as) = do { f' <- f
+ ; ty' <- repLTy ty
+ ; repTyArgs (repTapp f' ty') as }
repTyArgs f (HsTypeArg _ ki : as) = do { f' <- f
; ki' <- repLTy ki
; repTyArgs (repTappKind f' ki') as }
@@ -724,14 +724,14 @@ repDataFamInstD (DataFamInstDecl { dfid_eqn =
; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs ->
do { tys1 <- case fixity of
Prefix -> repTyArgs (repNamedTyCon tc) tys
- Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
+ Infix -> do { (HsValArg _ t1: HsValArg _ t2: args) <- checkTys tys
; t1' <- repLTy t1
; t2' <- repLTy t2
; repTyArgs (repTInfix t1' tc t2') args }
; repDataDefn tc (Right (mb_exp_bndrs, tys1)) defn } }
where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]
- checkTys tys@(HsValArg _: HsValArg _: _) = return tys
+ checkTys tys@(HsValArg _ _: HsValArg _ _: _) = return tys
checkTys _ = panic "repDataFamInstD:checkTys"
repForD :: LForeignDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
@@ -1187,7 +1187,7 @@ instance RepTV (HsBndrVis GhcRn) TH.BndrVis where
; rep2 kindedBndrTVName [nm, vis', ki] }
rep_bndr_vis :: HsBndrVis GhcRn -> MetaM (Core TH.BndrVis)
-rep_bndr_vis HsBndrRequired = rep2_nw bndrReqName []
+rep_bndr_vis (HsBndrRequired _) = rep2_nw bndrReqName []
rep_bndr_vis (HsBndrInvisible _) = rep2_nw bndrInvisName []
addHsOuterFamEqnTyVarBinds ::
@@ -1400,7 +1400,7 @@ repTy (HsAppTy _ f a) = do
f1 <- repLTy f
a1 <- repLTy a
repTapp f1 a1
-repTy (HsAppKindTy _ ty _ ki) = do
+repTy (HsAppKindTy _ ty ki) = do
ty1 <- repLTy ty
ki1 <- repLTy ki
repTappKind ty1 ki1
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -555,8 +555,8 @@ instance (HasLoc a, HiePass p) => HasLoc (FamEqn (GhcPass p) a) where
HsOuterExplicit{hso_bndrs = tvs} ->
foldl1' combineSrcSpans [getHasLoc a, getHasLocList tvs, getHasLocList b, getHasLoc c]
-instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg p tm ty) where
- getHasLoc (HsValArg tm) = getHasLoc tm
+instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg (GhcPass p) tm ty) where
+ getHasLoc (HsValArg _ tm) = getHasLoc tm
getHasLoc (HsTypeArg _ ty) = getHasLoc ty
getHasLoc (HsArgPar sp) = sp
@@ -1839,7 +1839,7 @@ instance ToHie (LocatedA (HsType GhcRn)) where
[ toHie a
, toHie b
]
- HsAppKindTy _ ty _ ki ->
+ HsAppKindTy _ ty ki ->
[ toHie ty
, toHie ki
]
@@ -1897,8 +1897,8 @@ instance ToHie (LocatedA (HsType GhcRn)) where
HsStarTy _ _ -> []
XHsType _ -> []
-instance (ToHie tm, ToHie ty) => ToHie (HsArg p tm ty) where
- toHie (HsValArg tm) = toHie tm
+instance (ToHie tm, ToHie ty) => ToHie (HsArg (GhcPass p) tm ty) where
+ toHie (HsValArg _ tm) = toHie tm
toHie (HsTypeArg _ ty) = toHie ty
toHie (HsArgPar sp) = locOnly sp
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2242,7 +2242,7 @@ ftype :: { forall b. DisambTD b => PV (LocatedA b) }
| ftype tyarg { $1 >>= \ $1 ->
mkHsAppTyPV $1 $2 }
| ftype PREFIX_AT atype { $1 >>= \ $1 ->
- mkHsAppKindTyPV $1 (hsTok $2) $3 }
+ mkHsAppKindTyPV $1 (epTok $2) $3 }
tyarg :: { LHsType GhcPs }
: atype { $1 }
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -9,7 +9,9 @@
module GHC.Parser.Annotation (
-- * Core Exact Print Annotation types
AnnKeywordId(..),
- EpToken(..), EpUniToken(..), EpLayout(..),
+ EpToken(..), EpUniToken(..),
+ getEpTokenSrcSpan,
+ EpLayout(..),
EpaComment(..), EpaCommentTok(..),
IsUnicodeSyntax(..),
unicodeAnn,
@@ -382,6 +384,11 @@ deriving instance Eq (EpToken tok)
deriving instance KnownSymbol tok => Data (EpToken tok)
deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (EpUniToken tok utok)
+getEpTokenSrcSpan :: EpToken tok -> SrcSpan
+getEpTokenSrcSpan NoEpTok = noSrcSpan
+getEpTokenSrcSpan (EpTok EpaDelta{}) = noSrcSpan
+getEpTokenSrcSpan (EpTok (EpaSpan span)) = span
+
-- | Layout information for declarations.
data EpLayout =
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -946,7 +946,7 @@ checkTyVars pp_what equals_or_where tc tparms
; return (mkHsQTvs tvs) }
where
check (HsTypeArg at ki) = chkParens [] [] emptyComments (HsBndrInvisible at) ki
- check (HsValArg ty) = chkParens [] [] emptyComments HsBndrRequired ty
+ check (HsValArg _ ty) = chkParens [] [] emptyComments (HsBndrRequired noExtField) ty
check (HsArgPar sp) = addFatalError $ mkPlainErrorMsgEnvelope sp $
(PsErrMalformedDecl pp_what (unLoc tc))
-- Keep around an action for adjusting the annotations of extra parens
@@ -983,11 +983,11 @@ checkTyVars pp_what equals_or_where tc tparms
-- Return an AddEpAnn for use in widenLocatedAn. The AnnKeywordId is not used.
for_widening :: HsBndrVis GhcPs -> AddEpAnn
- for_widening (HsBndrInvisible (L (TokenLoc loc) _)) = AddEpAnn AnnAnyclass loc
- for_widening _ = AddEpAnn AnnAnyclass (EpaDelta (SameLine 0) [])
+ for_widening (HsBndrInvisible (EpTok loc)) = AddEpAnn AnnAnyclass loc
+ for_widening _ = AddEpAnn AnnAnyclass (EpaDelta (SameLine 0) [])
for_widening_ann :: HsBndrVis GhcPs -> EpAnn [AddEpAnn]
- for_widening_ann (HsBndrInvisible (L (TokenLoc (EpaSpan (RealSrcSpan r _mb))) _))
+ for_widening_ann (HsBndrInvisible (EpTok (EpaSpan (RealSrcSpan r _mb))))
= EpAnn (realSpanAsAnchor r) [] emptyComments
for_widening_ann _ = noAnn
@@ -1081,15 +1081,17 @@ checkTyClHdr is_cls ty
go _ (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix
| isRdrTc tc = return (ltc, acc, fix, (reverse ops) ++ cps)
go _ (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix
- | isRdrTc tc = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, (reverse ops) ++ cps)
+ | isRdrTc tc = return (ltc, lhs:rhs:acc, Infix, (reverse ops) ++ cps)
+ where lhs = HsValArg noExtField t1
+ rhs = HsValArg noExtField t2
go l (HsParTy _ ty) acc ops cps fix = goL ty acc (o:ops) (c:cps) fix
where
(o,c) = mkParensEpAnn (realSrcSpan l)
- go _ (HsAppTy _ t1 t2) acc ops cps fix = goL t1 (HsValArg t2:acc) ops cps fix
- go _ (HsAppKindTy _ ty at ki) acc ops cps fix = goL ty (HsTypeArg at ki:acc) ops cps fix
+ go _ (HsAppTy _ t1 t2) acc ops cps fix = goL t1 (HsValArg noExtField t2:acc) ops cps fix
+ go _ (HsAppKindTy at ty ki) acc ops cps fix = goL ty (HsTypeArg at ki:acc) ops cps fix
go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix
= return (L (noAnnSrcSpan l) (nameRdrName tup_name)
- , map HsValArg ts, fix, (reverse ops)++cps)
+ , map (HsValArg noExtField) ts, fix, (reverse ops)++cps)
where
arity = length ts
tup_name | is_cls = cTupleTyConName arity
@@ -2014,7 +2016,7 @@ class DisambTD b where
-- | Disambiguate @f x@ (function application or prefix data constructor).
mkHsAppTyPV :: LocatedA b -> LHsType GhcPs -> PV (LocatedA b)
-- | Disambiguate @f \@t@ (visible kind application)
- mkHsAppKindTyPV :: LocatedA b -> LHsToken "@" GhcPs -> LHsType GhcPs -> PV (LocatedA b)
+ mkHsAppKindTyPV :: LocatedA b -> EpToken "@" -> LHsType GhcPs -> PV (LocatedA b)
-- | Disambiguate @f \# x@ (infix operator)
mkHsOpTyPV :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> PV (LocatedA b)
-- | Disambiguate @{-\# UNPACK \#-} t@ (unpack/nounpack pragma)
@@ -2023,7 +2025,7 @@ class DisambTD b where
instance DisambTD (HsType GhcPs) where
mkHsAppTyHeadPV = return
mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2)
- mkHsAppKindTyPV t at ki = return (mkHsAppKindTy t at ki)
+ mkHsAppKindTyPV t at ki = return (mkHsAppKindTy at t ki)
mkHsOpTyPV prom t1 op t2 = return (mkLHsOpTy prom t1 op t2)
mkUnpackednessPV = addUnpackednessP
@@ -2060,7 +2062,7 @@ instance DisambTD DataConBuilder where
panic "mkHsAppTyPV: InfixDataConBuilder"
mkHsAppKindTyPV lhs at ki =
- addFatalError $ mkPlainErrorMsgEnvelope (getTokenSrcSpan (getLoc at)) $
+ addFatalError $ mkPlainErrorMsgEnvelope (getEpTokenSrcSpan at) $
(PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki))
mkHsOpTyPV prom lhs tc rhs = do
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -467,12 +467,12 @@ rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind
-- renaming a type only, not a kind
rnLHsTypeArg :: HsDocContext -> LHsTypeArg GhcPs
-> RnM (LHsTypeArg GhcRn, FreeVars)
-rnLHsTypeArg ctxt (HsValArg ty)
+rnLHsTypeArg ctxt (HsValArg _ ty)
= do { (tys_rn, fvs) <- rnLHsType ctxt ty
- ; return (HsValArg tys_rn, fvs) }
-rnLHsTypeArg ctxt (HsTypeArg l ki)
+ ; return (HsValArg noExtField tys_rn, fvs) }
+rnLHsTypeArg ctxt (HsTypeArg _ ki)
= do { (kis_rn, fvs) <- rnLHsKind ctxt ki
- ; return (HsTypeArg l kis_rn, fvs) }
+ ; return (HsTypeArg noExtField kis_rn, fvs) }
rnLHsTypeArg _ (HsArgPar sp)
= return (HsArgPar sp, emptyFVs)
@@ -638,12 +638,12 @@ rnHsTyKi env (HsAppTy _ ty1 ty2)
; (ty2', fvs2) <- rnLHsTyKi env ty2
; return (HsAppTy noExtField ty1' ty2', fvs1 `plusFV` fvs2) }
-rnHsTyKi env (HsAppKindTy _ ty at k)
+rnHsTyKi env (HsAppKindTy _ ty k)
= do { kind_app <- xoptM LangExt.TypeApplications
; unless kind_app (addErr (typeAppErr KindLevel k))
; (ty', fvs1) <- rnLHsTyKi env ty
; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k
- ; return (HsAppKindTy noExtField ty' at k', fvs1 `plusFV` fvs2) }
+ ; return (HsAppKindTy noExtField ty' k', fvs1 `plusFV` fvs2) }
rnHsTyKi env t@(HsIParamTy x n ty)
= do { notInKinds env t
@@ -1201,12 +1201,10 @@ rnLHsTyVarBndrVisFlag (L loc bndr) = do
addErr (TcRnIllegalInvisTyVarBndr lbndr)
return lbndr
--- rnHsBndrVis is a no-op. We could use 'coerce' in an ideal world,
--- but GHC can't crack this nut because type families are involved:
--- HsBndrInvisible stores (LHsToken "@" pass), which is defined via XRec.
+-- rnHsBndrVis is almost a no-op, it simply discards the token for "@".
rnHsBndrVis :: HsBndrVis GhcPs -> HsBndrVis GhcRn
-rnHsBndrVis HsBndrRequired = HsBndrRequired
-rnHsBndrVis (HsBndrInvisible at) = HsBndrInvisible at
+rnHsBndrVis (HsBndrRequired _) = HsBndrRequired noExtField
+rnHsBndrVis (HsBndrInvisible _at) = HsBndrInvisible noExtField
newTyVarNameRn, newTyVarNameRnImplicit
:: Maybe a -- associated class
@@ -1956,7 +1954,7 @@ To account for that, we introduce another helper, `filterInScopeNonClassM`,
which acts much like `filterInScopeM` but leaves class variables intact. -}
extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVars -> FreeKiTyVars
-extract_tyarg (HsValArg ty) acc = extract_lty ty acc
+extract_tyarg (HsValArg _ ty) acc = extract_lty ty acc
extract_tyarg (HsTypeArg _ ki) acc = extract_lty ki acc
extract_tyarg (HsArgPar _) acc = acc
@@ -2055,7 +2053,7 @@ extract_lty (L _ ty) acc
flds
HsAppTy _ ty1 ty2 -> extract_lty ty1 $
extract_lty ty2 acc
- HsAppKindTy _ ty _ k -> extract_lty ty $
+ HsAppKindTy _ ty k -> extract_lty ty $
extract_lty k acc
HsListTy _ ty -> extract_lty ty acc
HsTupleTy _ _ tys -> extract_ltys tys acc
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -1297,12 +1297,12 @@ rn_ty_pat (HsAppTy _ fun_ty arg_ty) = do
arg_ty' <- rn_lty_pat arg_ty
pure (HsAppTy noExtField fun_ty' arg_ty')
-rn_ty_pat (HsAppKindTy _ ty at ki) = do
+rn_ty_pat (HsAppKindTy _ ty ki) = do
kind_app <- liftRn $ xoptM LangExt.TypeApplications
unless kind_app (liftRn $ addErr (typeAppErr KindLevel ki))
ty' <- rn_lty_pat ty
ki' <- rn_lty_pat ki
- pure (HsAppKindTy noExtField ty' at ki')
+ pure (HsAppKindTy noExtField ty' ki')
rn_ty_pat (HsFunTy an mult lhs rhs) = do
lhs' <- rn_lty_pat lhs
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -846,7 +846,7 @@ expr_to_type earg =
go (L l (HsAppType _ lhs rhs)) =
do { lhs' <- go lhs
; rhs' <- unwrap_wc rhs
- ; return (L l (HsAppKindTy noExtField lhs' noHsTok rhs')) }
+ ; return (L l (HsAppKindTy noExtField lhs' rhs')) }
go (L l e@(OpApp _ lhs op rhs)) =
do { lhs' <- go lhs
; op' <- go op
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -1551,12 +1551,12 @@ splitHsAppTys hs_ty
-> [HsArg GhcRn (LHsType GhcRn) (LHsKind GhcRn)]
-> (LHsType GhcRn,
[HsArg GhcRn (LHsType GhcRn) (LHsKind GhcRn)]) -- AZ temp
- go (L _ (HsAppTy _ f a)) as = go f (HsValArg a : as)
- go (L _ (HsAppKindTy _ ty at k)) as = go ty (HsTypeArg at k : as)
+ go (L _ (HsAppTy _ f a)) as = go f (HsValArg noExtField a : as)
+ go (L _ (HsAppKindTy _ ty k)) as = go ty (HsTypeArg noExtField k : as)
go (L sp (HsParTy _ f)) as = go f (HsArgPar (locA sp) : as)
go (L _ (HsOpTy _ prom l op@(L sp _) r)) as
= ( L (l2l sp) (HsTyVar noAnn prom op)
- , HsValArg l : HsValArg r : as )
+ , HsValArg noExtField l : HsValArg noExtField r : as )
go f as = (f, as)
---------------------------
@@ -1672,7 +1672,7 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args
ty_app_err ki_arg substed_fun_ki
---------------- HsValArg: a normal argument (fun ty)
- (HsValArg arg : args, Just (ki_binder, inner_ki))
+ (HsValArg _ arg : args, Just (ki_binder, inner_ki))
-- next binder is invisible; need to instantiate it
| Named (Bndr kv flag) <- ki_binder
, isInvisibleForAllTyFlag flag -- ForAllTy with Inferred or Specified
@@ -1693,7 +1693,7 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args
; go (n+1) fun' subst' inner_ki args }
-- no binder; try applying the substitution, or infer another arrow in fun kind
- (HsValArg _ : _, Nothing)
+ (HsValArg _ _ : _, Nothing)
-> try_again_after_substing_or $
do { let arrows_needed = n_initial_val_args all_args
; co <- matchExpectedFunKind (HsTypeRnThing $ unLoc hs_ty) arrows_needed substed_fun_ki
@@ -1920,10 +1920,10 @@ unsaturated arguments: see #11246. Hence doing this in tcInferApps.
appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn
appTypeToArg f [] = f
-appTypeToArg f (HsValArg arg : args) = appTypeToArg (mkHsAppTy f arg) args
+appTypeToArg f (HsValArg _ arg : args) = appTypeToArg (mkHsAppTy f arg) args
appTypeToArg f (HsArgPar _ : args) = appTypeToArg f args
-appTypeToArg f (HsTypeArg at arg : args)
- = appTypeToArg (mkHsAppKindTy f at arg) args
+appTypeToArg f (HsTypeArg _ arg : args)
+ = appTypeToArg (mkHsAppKindTy noExtField f arg) args
{- *********************************************************************
@@ -2470,7 +2470,7 @@ mkExplicitTyConBinder :: TyCoVarSet -- variables that are used dependently
-> TyConBinder
mkExplicitTyConBinder dep_set (Bndr tv flag) =
case flag of
- HsBndrRequired -> mkRequiredTyConBinder dep_set tv
+ HsBndrRequired{} -> mkRequiredTyConBinder dep_set tv
HsBndrInvisible{} -> mkNamedTyConBinder Specified tv
-- | Kind-check a 'LHsQTyVars'. Used in 'inferInitialKind' (for tycon kinds and
@@ -2741,7 +2741,7 @@ matchUpSigWithDecl name sig_tcbs sig_res_kind hs_bndrs thing_inside
-- See GHC Proposal #425, section "Kind checking",
-- where zippable and skippable are defined.
zippable :: TyConBndrVis -> HsBndrVis GhcRn -> Bool
- zippable vis HsBndrRequired = isVisibleTcbVis vis
+ zippable vis (HsBndrRequired _) = isVisibleTcbVis vis
zippable vis (HsBndrInvisible _) = isInvisSpecTcbVis vis
-- See GHC Proposal #425, section "Kind checking",
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -298,7 +298,7 @@ no_anon_wc_ty lty = go lty
go (L _ ty) = case ty of
HsWildCardTy _ -> False
HsAppTy _ ty1 ty2 -> go ty1 && go ty2
- HsAppKindTy _ ty _ ki -> go ty && go ki
+ HsAppKindTy _ ty ki -> go ty && go ki
HsFunTy _ w ty1 ty2 -> go ty1 && go ty2 && go (arrowToHsType w)
HsListTy _ ty -> go ty
HsTupleTy _ _ tys -> gos tys
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -562,7 +562,7 @@ cvtTySynEqn (TySynEqn mb_bndrs lhs rhs)
, feqn_tycon = nm'
, feqn_bndrs = outer_bndrs
, feqn_pats =
- (map HsValArg args') ++ args
+ (map (HsValArg noExtField) args') ++ args
, feqn_fixity = Hs.Infix
, feqn_rhs = rhs' } }
_ -> failWith $ InvalidTyFamInstLHS lhs
@@ -617,7 +617,7 @@ cvt_datainst_hdr cxt bndrs tys
InfixT t1 nm t2 -> do { nm' <- tconNameN nm
; args' <- mapM cvtType [t1,t2]
; return (cxt', nm', outer_bndrs,
- ((map HsValArg args') ++ args)) }
+ ((map (HsValArg noExtField) args') ++ args)) }
_ -> failWith $ InvalidTypeInstanceHeader tys }
----------------
@@ -1528,8 +1528,8 @@ instance CvtFlag TH.Specificity Hs.Specificity where
cvtFlag TH.InferredSpec = Hs.InferredSpec
instance CvtFlag TH.BndrVis (HsBndrVis GhcPs) where
- cvtFlag TH.BndrReq = HsBndrRequired
- cvtFlag TH.BndrInvis = HsBndrInvisible noHsTok
+ cvtFlag TH.BndrReq = HsBndrRequired noExtField
+ cvtFlag TH.BndrInvis = HsBndrInvisible noAnn
cvtTvs :: CvtFlag flag flag' => [TH.TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs]
cvtTvs tvs = mapM cvt_tv tvs
@@ -1605,7 +1605,7 @@ cvtTypeKind :: TypeOrKind -> TH.Type -> CvtM (LHsType GhcPs)
cvtTypeKind typeOrKind ty
= do { (head_ty, tys') <- split_ty_app ty
; let m_normals = mapM extract_normal tys'
- where extract_normal (HsValArg ty) = Just ty
+ where extract_normal (HsValArg _ ty) = Just ty
extract_normal _ = Nothing
; case head_ty of
@@ -1718,7 +1718,7 @@ cvtTypeKind typeOrKind ty
; ls' <- returnLA s'
; mk_apps
(HsTyVar noAnn prom ls')
- ([HsValArg t1', HsValArg t2'] ++ tys')
+ ([HsValArg noExtField t1', HsValArg noExtField t2'] ++ tys')
}
UInfixT t1 s t2
@@ -1734,7 +1734,7 @@ cvtTypeKind typeOrKind ty
; t2' <- cvtType t2
; mk_apps
(HsTyVar noAnn IsPromoted s')
- ([HsValArg t1', HsValArg t2'] ++ tys')
+ ([HsValArg noExtField t1', HsValArg noExtField t2'] ++ tys')
}
PromotedUInfixT t1 s t2
@@ -1836,11 +1836,12 @@ mk_apps head_ty type_args = do
go [] = pure head_ty'
go (arg:args) =
case arg of
- HsValArg ty -> do p_ty <- add_parens ty
+ HsValArg _ ty ->
+ do p_ty <- add_parens ty
mk_apps (HsAppTy noExtField phead_ty p_ty) args
HsTypeArg at ki ->
do p_ki <- add_parens ki
- mk_apps (HsAppKindTy noExtField phead_ty at p_ki) args
+ mk_apps (HsAppKindTy at phead_ty p_ki) args
HsArgPar _ -> mk_apps (HsParTy noAnn phead_ty) args
go type_args
@@ -1851,7 +1852,7 @@ mk_apps head_ty type_args = do
| otherwise = return lt
wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs
-wrap_tyarg (HsValArg ty) = HsValArg $ parenthesizeHsType appPrec ty
+wrap_tyarg (HsValArg x ty) = HsValArg x $ parenthesizeHsType appPrec ty
wrap_tyarg (HsTypeArg l ki) = HsTypeArg l $ parenthesizeHsType appPrec ki
wrap_tyarg ta@(HsArgPar {}) = ta -- Already parenthesized
@@ -1883,9 +1884,9 @@ See (among other closed issues) https://gitlab.haskell.org/ghc/ghc/issues/14289
split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs])
split_ty_app ty = go ty []
where
- go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg a':as') }
+ go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg noExtField a':as') }
go (AppKindT ty ki) as' = do { ki' <- cvtKind ki
- ; go ty (HsTypeArg noHsTok ki' : as') }
+ ; go ty (HsTypeArg noAnn ki' : as') }
go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') }
go f as = return (f,as)
=====================================
compiler/Language/Haskell/Syntax/Type.hs
=====================================
@@ -26,7 +26,8 @@ module Language.Haskell.Syntax.Type (
HsLinearArrowTokens(..),
HsType(..), LHsType, HsKind, LHsKind,
- HsBndrVis(..), isHsBndrInvisible,
+ HsBndrVis(..), XBndrRequired, XBndrInvisible, XXBndrVis,
+ isHsBndrInvisible,
HsForAllTelescope(..), HsTyVarBndr(..), LHsTyVarBndr,
LHsQTyVars(..),
HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs,
@@ -38,7 +39,8 @@ module Language.Haskell.Syntax.Type (
HsContext, LHsContext,
HsTyLit(..),
HsIPName(..), hsIPNameFS,
- HsArg(..),
+ HsArg(..), XValArg, XTypeArg, XArgPar, XXArg,
+
LHsTypeArg,
LBangType, BangType,
@@ -66,7 +68,6 @@ import Language.Haskell.Syntax.Extension
import GHC.Types.Name.Reader ( RdrName )
import GHC.Core.DataCon( HsSrcBang(..) )
import GHC.Core.Type (Specificity)
-import GHC.Types.SrcLoc (SrcSpan)
import GHC.Types.Basic (Arity)
import GHC.Hs.Doc (LHsDoc)
@@ -726,19 +727,26 @@ data HsTyVarBndr flag pass
!(XXTyVarBndr pass)
data HsBndrVis pass
- = HsBndrRequired
+ = HsBndrRequired !(XBndrRequired pass)
-- Binder for a visible (required) variable:
-- type Dup a = (a, a)
-- ^^^
- | HsBndrInvisible (LHsToken "@" pass)
+ | HsBndrInvisible !(XBndrInvisible pass)
-- Binder for an invisible (specified) variable:
-- type KindOf @k (a :: k) = k
-- ^^^
+ | XXBndrVis !(XXBndrVis pass)
+
+type family XBndrRequired p
+type family XBndrInvisible p
+type family XXBndrVis p
+
isHsBndrInvisible :: HsBndrVis pass -> Bool
isHsBndrInvisible HsBndrInvisible{} = True
-isHsBndrInvisible HsBndrRequired = False
+isHsBndrInvisible HsBndrRequired{} = False
+isHsBndrInvisible (XXBndrVis _) = False
-- | Does this 'HsTyVarBndr' come with an explicit kind annotation?
isHsKindedTyVar :: HsTyVarBndr flag pass -> Bool
@@ -783,7 +791,6 @@ data HsType pass
| HsAppKindTy (XAppKindTy pass) -- type level type app
(LHsType pass)
- !(LHsToken "@" pass)
(LHsKind pass)
| HsFunTy (XFunTy pass)
@@ -1227,9 +1234,15 @@ do not bring any type variables into scope over the body of a function at all.
-- | Arguments in an expression/type after splitting
data HsArg p tm ty
- = HsValArg tm -- Argument is an ordinary expression (f arg)
- | HsTypeArg !(LHsToken "@" p) ty -- Argument is a visible type application (f @ty)
- | HsArgPar SrcSpan -- See Note [HsArgPar]
+ = HsValArg !(XValArg p) tm -- Argument is an ordinary expression (f arg)
+ | HsTypeArg !(XTypeArg p) ty -- Argument is a visible type application (f @ty)
+ | HsArgPar !(XArgPar p) -- See Note [HsArgPar]
+ | XArg !(XXArg p)
+
+type family XValArg p
+type family XTypeArg p
+type family XArgPar p
+type family XXArg p
-- type level equivalent
type LHsTypeArg p = HsArg p (LHsType p) (LHsKind p)
=====================================
testsuite/tests/ghc-api/exactprint/Test20239.stderr
=====================================
@@ -90,6 +90,7 @@
(HsOuterImplicit
(NoExtField))
[(HsValArg
+ (NoExtField)
(L
(EpAnn
(EpaSpan { Test20239.hs:5:22-32 })
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
=====================================
@@ -78,7 +78,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T17544.hs:5:10 })
@@ -265,7 +266,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T17544.hs:9:10 })
@@ -446,7 +448,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T17544.hs:13:10 })
@@ -630,7 +633,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T17544.hs:17:10 })
@@ -897,7 +901,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T17544.hs:22:10 })
@@ -951,7 +956,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T17544.hs:22:28 })
@@ -1091,6 +1097,7 @@
(HsOuterImplicit
(NoExtField))
[(HsValArg
+ (NoExtField)
(L
(EpAnn
(EpaSpan { T17544.hs:24:11-13 })
@@ -1270,7 +1277,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T17544.hs:28:10 })
@@ -1324,7 +1332,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T17544.hs:28:28 })
@@ -1464,6 +1473,7 @@
(HsOuterImplicit
(NoExtField))
[(HsValArg
+ (NoExtField)
(L
(EpAnn
(EpaSpan { T17544.hs:30:11-13 })
@@ -1643,7 +1653,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T17544.hs:34:10 })
@@ -1697,7 +1708,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T17544.hs:34:28 })
@@ -1837,6 +1849,7 @@
(HsOuterImplicit
(NoExtField))
[(HsValArg
+ (NoExtField)
(L
(EpAnn
(EpaSpan { T17544.hs:36:11-13 })
@@ -2016,7 +2029,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T17544.hs:40:10 })
@@ -2070,7 +2084,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T17544.hs:40:28 })
@@ -2210,6 +2225,7 @@
(HsOuterImplicit
(NoExtField))
[(HsValArg
+ (NoExtField)
(L
(EpAnn
(EpaSpan { T17544.hs:42:11-13 })
@@ -2389,7 +2405,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T17544.hs:46:10 })
@@ -2443,7 +2460,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T17544.hs:46:28 })
@@ -2583,6 +2601,7 @@
(HsOuterImplicit
(NoExtField))
[(HsValArg
+ (NoExtField)
(L
(EpAnn
(EpaSpan { T17544.hs:48:11-13 })
@@ -2762,7 +2781,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T17544.hs:52:11 })
@@ -2816,7 +2836,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T17544.hs:52:30 })
@@ -2956,6 +2977,7 @@
(HsOuterImplicit
(NoExtField))
[(HsValArg
+ (NoExtField)
(L
(EpAnn
(EpaSpan { T17544.hs:54:12-14 })
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
=====================================
@@ -338,7 +338,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T17544_kw.hs:21:11 })
=====================================
testsuite/tests/parser/should_compile/DumpParsedAst.stderr
=====================================
@@ -358,6 +358,7 @@
(HsOuterImplicit
(NoExtField))
[(HsValArg
+ (NoExtField)
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:11:10-17 })
@@ -572,6 +573,7 @@
(HsOuterImplicit
(NoExtField))
[(HsValArg
+ (NoExtField)
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:12:10-12 })
@@ -640,7 +642,8 @@
,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:10:30 }))]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:10:21-22 })
@@ -762,7 +765,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:15:8 })
@@ -787,7 +791,8 @@
,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:15:17 }))]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:15:11 })
@@ -1182,10 +1187,8 @@
(HsOuterImplicit
(NoExtField))
[(HsTypeArg
- (L
- (TokenLoc
- (EpaSpan { DumpParsedAst.hs:19:6 }))
- (HsTok))
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:19:6 }))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:19:7-11 })
@@ -1210,6 +1213,7 @@
(Unqual
{OccName: Peano})))))
,(HsValArg
+ (NoExtField)
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:19:13 })
@@ -1234,6 +1238,7 @@
(Unqual
{OccName: a})))))
,(HsValArg
+ (NoExtField)
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:19:15 })
@@ -1284,7 +1289,8 @@
(EpaComments
[]))
(HsAppKindTy
- (NoExtField)
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:19:21 }))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:19:19 })
@@ -1308,10 +1314,6 @@
[]))
(Unqual
{OccName: T}))))
- (L
- (TokenLoc
- (EpaSpan { DumpParsedAst.hs:19:21 }))
- (HsTok))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:19:22-26 })
@@ -1408,7 +1410,8 @@
,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:18:23 }))]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:18:17 })
@@ -1456,7 +1459,8 @@
,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:18:40 }))]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:18:26 })
@@ -1744,6 +1748,7 @@
(HsOuterImplicit
(NoExtField))
[(HsValArg
+ (NoExtField)
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:22:22-37 })
=====================================
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
=====================================
@@ -302,6 +302,7 @@
[{Name: a}
,{Name: as}])
[(HsValArg
+ (NoExtField)
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:13:10-17 })
@@ -509,6 +510,7 @@
(HsOuterImplicit
[])
[(HsValArg
+ (NoExtField)
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:14:10-12 })
@@ -569,7 +571,8 @@
,(AddEpAnn AnnCloseP (EpaSpan { DumpRenamedAst.hs:12:30 }))]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:12:21-22 })
@@ -928,6 +931,7 @@
[{Name: a}
,{Name: k}])
[(HsValArg
+ (NoExtField)
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:19:22-37 })
@@ -1514,7 +1518,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:22:8 })
@@ -1538,7 +1543,8 @@
,(AddEpAnn AnnCloseP (EpaSpan { DumpRenamedAst.hs:22:17 }))]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:22:11 })
@@ -1730,10 +1736,7 @@
[{Name: a}
,{Name: f}])
[(HsTypeArg
- (L
- (TokenLoc
- (EpaSpan { DumpRenamedAst.hs:26:6 }))
- (HsTok))
+ (NoExtField)
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:26:7-11 })
@@ -1757,6 +1760,7 @@
[]))
{Name: DumpRenamedAst.Peano}))))
,(HsValArg
+ (NoExtField)
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:26:13 })
@@ -1780,6 +1784,7 @@
[]))
{Name: a}))))
,(HsValArg
+ (NoExtField)
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:26:15 })
@@ -1852,10 +1857,6 @@
(EpaComments
[]))
{Name: DumpRenamedAst.T})))
- (L
- (TokenLoc
- (EpaSpan { DumpRenamedAst.hs:26:21 }))
- (HsTok))
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:26:22-26 })
@@ -1948,7 +1949,8 @@
,(AddEpAnn AnnCloseP (EpaSpan { DumpRenamedAst.hs:25:23 }))]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:25:17 })
@@ -1994,7 +1996,8 @@
,(AddEpAnn AnnCloseP (EpaSpan { DumpRenamedAst.hs:25:40 }))]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:25:26 })
@@ -2321,7 +2324,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:28:9 })
@@ -2373,7 +2377,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:29:10 })
@@ -2395,7 +2400,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:29:12 })
@@ -2542,6 +2548,7 @@
(HsOuterImplicit
[{Name: b}])
[(HsValArg
+ (NoExtField)
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:32:10-12 })
@@ -2581,6 +2588,7 @@
[]))
{Name: a}))))))
,(HsValArg
+ (NoExtField)
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:32:14 })
=====================================
testsuite/tests/parser/should_compile/DumpSemis.stderr
=====================================
@@ -1367,7 +1367,8 @@
,(AddEpAnn AnnCloseP (EpaSpan { DumpSemis.hs:28:38 }))]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { DumpSemis.hs:28:24-28 })
=====================================
testsuite/tests/parser/should_compile/KindSigs.stderr
=====================================
@@ -114,6 +114,7 @@
(HsOuterImplicit
(NoExtField))
[(HsValArg
+ (NoExtField)
(L
(EpAnn
(EpaSpan { KindSigs.hs:12:7 })
@@ -222,7 +223,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { KindSigs.hs:11:17 })
@@ -282,7 +284,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { KindSigs.hs:15:10 })
@@ -525,7 +528,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { KindSigs.hs:16:11 })
@@ -1499,7 +1503,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { KindSigs.hs:28:12 })
=====================================
testsuite/tests/parser/should_compile/T15323.stderr
=====================================
@@ -73,7 +73,8 @@
[]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T15323.hs:5:19 })
=====================================
testsuite/tests/parser/should_compile/T20452.stderr
=====================================
@@ -75,7 +75,8 @@
,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:5:21 }))]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T20452.hs:5:15 })
@@ -190,7 +191,8 @@
,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:6:22 }))]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T20452.hs:6:15 })
@@ -313,7 +315,8 @@
,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:8:26 }))]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T20452.hs:8:16-18 })
@@ -361,7 +364,8 @@
,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:8:45 }))]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T20452.hs:8:31-34 })
@@ -409,7 +413,8 @@
,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:8:75 }))]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T20452.hs:8:50-52 })
@@ -561,7 +566,8 @@
,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:9:27 }))]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T20452.hs:9:16-18 })
@@ -611,7 +617,8 @@
,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:9:46 }))]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T20452.hs:9:31-34 })
@@ -661,7 +668,8 @@
,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:9:76 }))]
(EpaComments
[]))
- (HsBndrRequired)
+ (HsBndrRequired
+ (NoExtField))
(L
(EpAnn
(EpaSpan { T20452.hs:9:50-52 })
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -2221,9 +2221,9 @@ instance (ExactPrint tm, ExactPrint ty, Outputable tm, Outputable ty)
getAnnotationEntry = const NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact a@(HsValArg tm) = markAnnotated tm >> return a
- exact a@(HsTypeArg at ty) = markToken at >> markAnnotated ty >> return a
- exact x@(HsArgPar _sp) = withPpr x -- Does not appear in original source
+ exact a@(HsValArg _ tm) = markAnnotated tm >> return a
+ exact a@(HsTypeArg at ty) = markEpToken at >> markAnnotated ty >> return a
+ exact x@(HsArgPar _sp) = withPpr x -- Does not appear in original source
-- ---------------------------------------------------------------------
@@ -3974,8 +3974,8 @@ instance ExactPrintTVFlag Specificity where
instance ExactPrintTVFlag (HsBndrVis GhcPs) where
exactTVDelimiters an0 bvis thing_inside = do
case bvis of
- HsBndrRequired -> return ()
- HsBndrInvisible at -> markToken at >> return ()
+ HsBndrRequired _ -> return ()
+ HsBndrInvisible at -> markEpToken at >> return ()
an1 <- markEpAnnAllL an0 lid AnnOpenP
r <- thing_inside
an2 <- markEpAnnAllL an1 lid AnnCloseP
@@ -4012,7 +4012,7 @@ instance ExactPrint (HsType GhcPs) where
getAnnotationEntry (HsQualTy _ _ _) = NoEntryVal
getAnnotationEntry (HsTyVar an _ _) = fromAnn an
getAnnotationEntry (HsAppTy _ _ _) = NoEntryVal
- getAnnotationEntry (HsAppKindTy _ _ _ _) = NoEntryVal
+ getAnnotationEntry (HsAppKindTy _ _ _) = NoEntryVal
getAnnotationEntry (HsFunTy an _ _ _) = fromAnn an
getAnnotationEntry (HsListTy an _) = fromAnn an
getAnnotationEntry (HsTupleTy an _ _) = fromAnn an
@@ -4036,7 +4036,7 @@ instance ExactPrint (HsType GhcPs) where
setAnnotationAnchor a@(HsQualTy _ _ _) _ _ _s = a
setAnnotationAnchor (HsTyVar an a b) anc ts cs = (HsTyVar (setAnchorEpa an anc ts cs) a b)
setAnnotationAnchor a@(HsAppTy _ _ _) _ _ _s = a
- setAnnotationAnchor a@(HsAppKindTy _ _ _ _) _ _ _s = a
+ setAnnotationAnchor a@(HsAppKindTy _ _ _) _ _ _s = a
setAnnotationAnchor (HsFunTy an a b c) anc ts cs = (HsFunTy (setAnchorEpa an anc ts cs) a b c)
setAnnotationAnchor (HsListTy an a) anc ts cs = (HsListTy (setAnchorEpa an anc ts cs) a)
setAnnotationAnchor (HsTupleTy an a b) anc ts cs = (HsTupleTy (setAnchorEpa an anc ts cs) a b)
@@ -4077,11 +4077,11 @@ instance ExactPrint (HsType GhcPs) where
t1' <- markAnnotated t1
t2' <- markAnnotated t2
return (HsAppTy an t1' t2')
- exact (HsAppKindTy ss ty at ki) = do
+ exact (HsAppKindTy at ty ki) = do
ty' <- markAnnotated ty
- at' <- markToken at
+ at' <- markEpToken at
ki' <- markAnnotated ki
- return (HsAppKindTy ss ty' at' ki')
+ return (HsAppKindTy at' ty' ki')
exact (HsFunTy an mult ty1 ty2) = do
ty1' <- markAnnotated ty1
mult' <- markArrow mult
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 7e8f11af63262fdc43e94059574fb1193b13e5b1
+Subproject commit ec8837db80afb9ee19cdf95e0f9ad2f37e5e6bf2
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1ac43f974beaf71a56ac3bd348fb5def8ca6406a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1ac43f974beaf71a56ac3bd348fb5def8ca6406a
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/20231206/045c3afc/attachment-0001.html>
More information about the ghc-commits
mailing list