[Git][ghc/ghc][wip/az/epa-remove-addepann-4] 6 commits: EPA: Remove [AddEpAnn] for FunDep
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Wed Oct 16 22:33:05 UTC 2024
Alan Zimmerman pushed to branch wip/az/epa-remove-addepann-4 at Glasgow Haskell Compiler / GHC
Commits:
d0ff68e9 by Alan Zimmerman at 2024-10-15T21:15:24+01:00
EPA: Remove [AddEpAnn] for FunDep
- - - - -
9679181e by Alan Zimmerman at 2024-10-16T19:31:04+01:00
EPA: Remove [AddEpann] from FamilyDecl
- - - - -
62dbf4de by Alan Zimmerman at 2024-10-16T20:09:33+01:00
EPA: Remove [AddEpAnn] From InjectivityAnn
- - - - -
e719f43e by Alan Zimmerman at 2024-10-16T21:09:32+01:00
EPA: Remove [AddEpAnn] from DefaultDecl
- - - - -
17d54803 by Alan Zimmerman at 2024-10-16T22:06:40+01:00
EPA: Remove [AddEpAnn] from RuleDecls
- - - - -
70243684 by Alan Zimmerman at 2024-10-16T22:53:24+01:00
EPA: Remove [AddEpAnn] from Warnings
- - - - -
11 changed files:
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/KindSigs.stderr
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
Changes:
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -34,6 +34,7 @@ module GHC.Hs.Decls (
AnnDataDefn(..),
AnnClassDecl(..),
AnnSynDecl(..),
+ AnnFamilyDecl(..),
TyClGroup(..),
tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,
tyClGroupKindSigs,
@@ -578,7 +579,7 @@ pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = nd } })
instance OutputableBndrId p => Outputable (FunDep (GhcPass p)) where
ppr = pprFunDep
-type instance XCFunDep (GhcPass _) = [AddEpAnn]
+type instance XCFunDep (GhcPass _) = TokRarrow
type instance XXFunDep (GhcPass _) = DataConCantHappen
pprFundeps :: OutputableBndrId p => [FunDep (GhcPass p)] -> SDoc
@@ -612,9 +613,27 @@ type instance XCKindSig (GhcPass _) = NoExtField
type instance XTyVarSig (GhcPass _) = NoExtField
type instance XXFamilyResultSig (GhcPass _) = DataConCantHappen
-type instance XCFamilyDecl (GhcPass _) = [AddEpAnn]
+type instance XCFamilyDecl (GhcPass _) = AnnFamilyDecl
type instance XXFamilyDecl (GhcPass _) = DataConCantHappen
+data AnnFamilyDecl
+ = AnnFamilyDecl {
+ afd_openp :: [EpToken "("],
+ afd_closep :: [EpToken ")"],
+ afd_type :: EpToken "type",
+ afd_data :: EpToken "data",
+ afd_family :: EpToken "family",
+ afd_dcolon :: TokDcolon,
+ afd_equal :: EpToken "=",
+ afd_vbar :: EpToken "|",
+ afd_where :: EpToken "where",
+ afd_openc :: EpToken "{",
+ afd_dotdot :: EpToken "..",
+ afd_closec :: EpToken "}"
+ } deriving Data
+
+instance NoAnn AnnFamilyDecl where
+ noAnn = AnnFamilyDecl noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn
------------- Functions over FamilyDecls -----------
@@ -639,7 +658,7 @@ resultVariableName _ = Nothing
------------- Pretty printing FamilyDecls -----------
-type instance XCInjectivityAnn (GhcPass _) = [AddEpAnn]
+type instance XCInjectivityAnn (GhcPass _) = TokRarrow
type instance XXInjectivityAnn (GhcPass _) = DataConCantHappen
instance OutputableBndrId p
@@ -1164,7 +1183,7 @@ mapDerivStrategy f ds = foldDerivStrategy ds (ViaStrategy . f) ds
************************************************************************
-}
-type instance XCDefaultDecl GhcPs = [AddEpAnn]
+type instance XCDefaultDecl GhcPs = (EpToken "default", EpToken "(", EpToken ")")
type instance XCDefaultDecl GhcRn = NoExtField
type instance XCDefaultDecl GhcTc = NoExtField
@@ -1252,7 +1271,7 @@ instance OutputableBndrId p
************************************************************************
-}
-type instance XCRuleDecls GhcPs = ([AddEpAnn], SourceText)
+type instance XCRuleDecls GhcPs = ((EpaLocation, EpaLocation), SourceText)
type instance XCRuleDecls GhcRn = SourceText
type instance XCRuleDecls GhcTc = SourceText
@@ -1337,7 +1356,7 @@ pprFullRuleName st (L _ n) = pprWithSourceText st (doubleQuotes $ ftext n)
************************************************************************
-}
-type instance XWarnings GhcPs = ([AddEpAnn], SourceText)
+type instance XWarnings GhcPs = ((EpaLocation, EpaLocation), SourceText)
type instance XWarnings GhcRn = SourceText
type instance XWarnings GhcTc = SourceText
=====================================
compiler/GHC/Hs/Dump.hs
=====================================
@@ -80,6 +80,7 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
`extQ` annClassDecl
`extQ` annSynDecl
`extQ` annDataDefn
+ `extQ` annFamilyDecl
`extQ` lit `extQ` litr `extQ` litt
`extQ` sourceText
`extQ` deltaPos
@@ -251,6 +252,16 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
showAstData' g, showAstData' h, showAstData' i,
showAstData' j, showAstData' k]
+ annFamilyDecl :: AnnFamilyDecl -> SDoc
+ annFamilyDecl (AnnFamilyDecl a b c d e f g h i j k l) = case ba of
+ BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnFamilyDecl"
+ NoBlankEpAnnotations ->
+ parens $ text "AnnFamilyDecl"
+ $$ vcat [showAstData' a, showAstData' b, showAstData' c,
+ showAstData' d, showAstData' e, showAstData' f,
+ showAstData' g, showAstData' h, showAstData' i,
+ showAstData' j, showAstData' k, showAstData' l]
+
addEpAnn :: AddEpAnn -> SDoc
addEpAnn (AddEpAnn a s) = case ba of
BlankEpAnnotations -> parens
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1275,9 +1275,9 @@ topdecl :: { LHsDecl GhcPs }
| role_annot { L (getLoc $1) (RoleAnnotD noExtField (unLoc $1)) }
| default_decl { L (getLoc $1) (DefD noExtField (unLoc $1)) }
| 'foreign' fdecl {% amsA' (sLL $1 $> ((snd $ unLoc $2) (mj AnnForeign $1:(fst $ unLoc $2)))) }
- | '{-# DEPRECATED' deprecations '#-}' {% amsA' (sLL $1 $> $ WarningD noExtField (Warnings ([mo $1,mc $3], (getDEPRECATED_PRAGs $1)) (fromOL $2))) }
- | '{-# WARNING' warnings '#-}' {% amsA' (sLL $1 $> $ WarningD noExtField (Warnings ([mo $1,mc $3], (getWARNING_PRAGs $1)) (fromOL $2))) }
- | '{-# RULES' rules '#-}' {% amsA' (sLL $1 $> $ RuleD noExtField (HsRules ([mo $1,mc $3], (getRULES_PRAGs $1)) (reverse $2))) }
+ | '{-# DEPRECATED' deprecations '#-}' {% amsA' (sLL $1 $> $ WarningD noExtField (Warnings ((glR $1,glR $3), (getDEPRECATED_PRAGs $1)) (fromOL $2))) }
+ | '{-# WARNING' warnings '#-}' {% amsA' (sLL $1 $> $ WarningD noExtField (Warnings ((glR $1,glR $3), (getWARNING_PRAGs $1)) (fromOL $2))) }
+ | '{-# RULES' rules '#-}' {% amsA' (sLL $1 $> $ RuleD noExtField (HsRules ((glR $1,glR $3), (getRULES_PRAGs $1)) (reverse $2))) }
| annotation { $1 }
| decl_no_th { $1 }
@@ -1300,7 +1300,7 @@ cl_decl :: { LTyClDecl GhcPs }
--
default_decl :: { LDefaultDecl GhcPs }
: 'default' opt_class '(' comma_types0 ')'
- {% amsA' (sLL $1 $> (DefaultDecl [mj AnnDefault $1,mop $3,mcp $5] $2 $4)) }
+ {% amsA' (sLL $1 $> (DefaultDecl (epTok $1,epTok $3,epTok $5) $2 $4)) }
-- Type declarations (toplevel)
@@ -1322,10 +1322,12 @@ ty_decl :: { LTyClDecl GhcPs }
where_type_family
-- Note the use of type for the head; this allows
-- infix type constructors to be declared
- {% mkFamDecl (comb5 $1 $3 $4 $5 $6) (snd $ unLoc $6) TopLevel $3
+ {% do { let { (tdcolon, tequal) = fst $ unLoc $4 }
+ ; let { tvbar = fst $ unLoc $5 }
+ ; let { (twhere, (toc, tdd, tcc)) = fst $ unLoc $6 }
+ ; mkFamDecl (comb5 $1 $3 $4 $5 $6) (snd $ unLoc $6) TopLevel $3
(snd $ unLoc $4) (snd $ unLoc $5)
- (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)
- ++ (fst $ unLoc $5) ++ (fst $ unLoc $6)) }
+ (AnnFamilyDecl [] [] (epTok $1) noAnn (epTok $2) tdcolon tequal tvbar twhere toc tdd tcc) }}
-- ordinary data type or newtype declaration
| type_data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings
@@ -1355,9 +1357,10 @@ ty_decl :: { LTyClDecl GhcPs }
-- data/newtype family
| 'data' 'family' type opt_datafam_kind_sig
- {% mkFamDecl (comb4 $1 $2 $3 $4) DataFamily TopLevel $3
+ {% do { let { tdcolon = fst $ unLoc $4 }
+ ; mkFamDecl (comb4 $1 $2 $3 $4) DataFamily TopLevel $3
(snd $ unLoc $4) Nothing
- (mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) }
+ (AnnFamilyDecl [] [] noAnn (epTok $1) (epTok $2) tdcolon noAnn noAnn noAnn noAnn noAnn noAnn) }}
-- standalone kind signature
standalone_kind_sig :: { LStandaloneKindSig GhcPs }
@@ -1449,14 +1452,14 @@ opt_class :: { Maybe (LIdP GhcPs) }
-- Injective type families
-opt_injective_info :: { Located ([AddEpAnn], Maybe (LInjectivityAnn GhcPs)) }
- : {- empty -} { noLoc ([], Nothing) }
- | '|' injectivity_cond { sLL $1 $> ([mj AnnVbar $1]
+opt_injective_info :: { Located (EpToken "|", Maybe (LInjectivityAnn GhcPs)) }
+ : {- empty -} { noLoc (noAnn, Nothing) }
+ | '|' injectivity_cond { sLL $1 $> ((epTok $1)
, Just ($2)) }
injectivity_cond :: { LInjectivityAnn GhcPs }
: tyvarid '->' inj_varids
- {% amsA' (sLL $1 $> (InjectivityAnn [mu AnnRarrow $2] $1 (reverse (unLoc $3)))) }
+ {% amsA' (sLL $1 $> (InjectivityAnn (epUniTok $2) $1 (reverse (unLoc $3)))) }
inj_varids :: { Located [LocatedN RdrName] }
: inj_varids tyvarid { sLL $1 $> ($2 : unLoc $1) }
@@ -1464,21 +1467,20 @@ inj_varids :: { Located [LocatedN RdrName] }
-- Closed type families
-where_type_family :: { Located ([AddEpAnn],FamilyInfo GhcPs) }
- : {- empty -} { noLoc ([],OpenTypeFamily) }
+where_type_family :: { Located ((EpToken "where", (EpToken "{", EpToken "..", EpToken "}")),FamilyInfo GhcPs) }
+ : {- empty -} { noLoc (noAnn,OpenTypeFamily) }
| 'where' ty_fam_inst_eqn_list
- { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2)
+ { sLL $1 $> ((epTok $1,(fst $ unLoc $2))
,ClosedTypeFamily (fmap reverse $ snd $ unLoc $2)) }
-ty_fam_inst_eqn_list :: { Located ([AddEpAnn],Maybe [LTyFamInstEqn GhcPs]) }
- : '{' ty_fam_inst_eqns '}' { sLL $1 $> ([moc $1,mcc $3]
+ty_fam_inst_eqn_list :: { Located ((EpToken "{", EpToken "..", EpToken "}"),Maybe [LTyFamInstEqn GhcPs]) }
+ : '{' ty_fam_inst_eqns '}' { sLL $1 $> ((epTok $1,noAnn, epTok $3)
,Just (unLoc $2)) }
| vocurly ty_fam_inst_eqns close { let (L loc _) = $2 in
- L loc ([],Just (unLoc $2)) }
- | '{' '..' '}' { sLL $1 $> ([moc $1,mj AnnDotdot $2
- ,mcc $3],Nothing) }
+ L loc (noAnn,Just (unLoc $2)) }
+ | '{' '..' '}' { sLL $1 $> ((epTok $1,epTok $2 ,epTok $3),Nothing) }
| vocurly '..' close { let (L loc _) = $2 in
- L loc ([mj AnnDotdot $2],Nothing) }
+ L loc ((noAnn,epTok $2, noAnn),Nothing) }
ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }
: ty_fam_inst_eqns ';' ty_fam_inst_eqn
@@ -1520,25 +1522,27 @@ ty_fam_inst_eqn :: { LTyFamInstEqn GhcPs }
at_decl_cls :: { LHsDecl GhcPs }
: -- data family declarations, with optional 'family' keyword
'data' opt_family type opt_datafam_kind_sig
- {% liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) DataFamily NotTopLevel $3
+ {% do { let { tdcolon = fst $ unLoc $4 }
+ ; liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) DataFamily NotTopLevel $3
(snd $ unLoc $4) Nothing
- (mj AnnData $1:$2++(fst $ unLoc $4))) }
+ (AnnFamilyDecl [] [] noAnn (epTok $1) $2 tdcolon noAnn noAnn noAnn noAnn noAnn noAnn)) }}
-- type family declarations, with optional 'family' keyword
-- (can't use opt_instance because you get shift/reduce errors
| 'type' type opt_at_kind_inj_sig
- {% liftM mkTyClD
+ {% do { let { (tdcolon, tequal, tvbar) = fst $ unLoc $3 }
+ ; liftM mkTyClD
(mkFamDecl (comb3 $1 $2 $3) OpenTypeFamily NotTopLevel $2
(fst . snd $ unLoc $3)
(snd . snd $ unLoc $3)
- (mj AnnType $1:(fst $ unLoc $3)) )}
+ (AnnFamilyDecl [] [] (epTok $1) noAnn noAnn tdcolon tequal tvbar noAnn noAnn noAnn noAnn)) }}
| 'type' 'family' type opt_at_kind_inj_sig
- {% liftM mkTyClD
+ {% do { let { (tdcolon, tequal, tvbar) = fst $ unLoc $4 }
+ ; liftM mkTyClD
(mkFamDecl (comb3 $1 $3 $4) OpenTypeFamily NotTopLevel $3
(fst . snd $ unLoc $4)
(snd . snd $ unLoc $4)
- (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)))}
-
+ (AnnFamilyDecl [] [] (epTok $1) noAnn (epTok $2) tdcolon tequal tvbar noAnn noAnn noAnn noAnn)) }}
-- default type instances, with optional 'instance' keyword
| 'type' ty_fam_inst_eqn
{% liftM mkInstD (mkTyFamInst (comb2 $1 $2) (unLoc $2)
@@ -1547,9 +1551,9 @@ at_decl_cls :: { LHsDecl GhcPs }
{% liftM mkInstD (mkTyFamInst (comb2 $1 $3) (unLoc $3)
(epTok $1) (epTok $2) )}
-opt_family :: { [AddEpAnn] }
- : {- empty -} { [] }
- | 'family' { [mj AnnFamily $1] }
+opt_family :: { EpToken "family" }
+ : {- empty -} { noAnn }
+ | 'family' { (epTok $1) }
opt_instance :: { EpToken "instance" }
: {- empty -} { NoEpTok }
@@ -1602,24 +1606,24 @@ opt_kind_sig :: { Located (TokDcolon, Maybe (LHsKind GhcPs)) }
: { noLoc (NoEpUniTok , Nothing) }
| '::' kind { sLL $1 $> (epUniTok $1, Just $2) }
-opt_datafam_kind_sig :: { Located ([AddEpAnn], LFamilyResultSig GhcPs) }
- : { noLoc ([] , noLocA (NoSig noExtField) )}
- | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLLa $1 $> (KindSig noExtField $2))}
+opt_datafam_kind_sig :: { Located (TokDcolon, LFamilyResultSig GhcPs) }
+ : { noLoc (noAnn, noLocA (NoSig noExtField) )}
+ | '::' kind { sLL $1 $> (epUniTok $1, sLLa $1 $> (KindSig noExtField $2))}
-opt_tyfam_kind_sig :: { Located ([AddEpAnn], LFamilyResultSig GhcPs) }
- : { noLoc ([] , noLocA (NoSig noExtField) )}
- | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLLa $1 $> (KindSig noExtField $2))}
+opt_tyfam_kind_sig :: { Located ((TokDcolon, EpToken "="), LFamilyResultSig GhcPs) }
+ : { noLoc (noAnn , noLocA (NoSig noExtField) )}
+ | '::' kind { sLL $1 $> ((epUniTok $1, noAnn), sLLa $1 $> (KindSig noExtField $2))}
| '=' tv_bndr {% do { tvb <- fromSpecTyVarBndr $2
- ; return $ sLL $1 $> ([mj AnnEqual $1], sLLa $1 $> (TyVarSig noExtField tvb))} }
+ ; return $ sLL $1 $> ((noAnn, epTok $1), sLLa $1 $> (TyVarSig noExtField tvb))} }
-opt_at_kind_inj_sig :: { Located ([AddEpAnn], ( LFamilyResultSig GhcPs
+opt_at_kind_inj_sig :: { Located ((TokDcolon, EpToken "=", EpToken "|"), ( LFamilyResultSig GhcPs
, Maybe (LInjectivityAnn GhcPs)))}
- : { noLoc ([], (noLocA (NoSig noExtField), Nothing)) }
- | '::' kind { sLL $1 $> ( [mu AnnDcolon $1]
+ : { noLoc (noAnn, (noLocA (NoSig noExtField), Nothing)) }
+ | '::' kind { sLL $1 $> ( (epUniTok $1, noAnn, noAnn)
, (sL1a $> (KindSig noExtField $2), Nothing)) }
| '=' tv_bndr_no_braces '|' injectivity_cond
{% do { tvb <- fromSpecTyVarBndr $2
- ; return $ sLL $1 $> ([mj AnnEqual $1, mj AnnVbar $3]
+ ; return $ sLL $1 $> ((noAnn, epTok $1, epTok $3)
, (sLLa $1 $2 (TyVarSig noExtField tvb), Just $4))} }
-- tycl_hdr parses the header of a class or data type decl,
@@ -2450,7 +2454,7 @@ fds1 :: { Located [LHsFunDep GhcPs] }
fd :: { LHsFunDep GhcPs }
: varids0 '->' varids0 {% amsA' (L (comb3 $1 $2 $3)
- (FunDep [mu AnnRarrow $2]
+ (FunDep (epUniTok $2)
(reverse (unLoc $1))
(reverse (unLoc $3)))) }
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -11,7 +11,7 @@ module GHC.Parser.Annotation (
AnnKeywordId(..),
EpToken(..), EpUniToken(..),
getEpTokenSrcSpan, getEpTokenLocs, getEpTokenLoc,
- TokDcolon,
+ TokDcolon, TokRarrow,
EpLayout(..),
EpaComment(..), EpaCommentTok(..),
IsUnicodeSyntax(..),
@@ -411,6 +411,7 @@ getEpTokenLoc NoEpTok = noAnn
getEpTokenLoc (EpTok l) = l
type TokDcolon = EpUniToken "::" "∷"
+type TokRarrow = EpUniToken "->" "→"
-- | Layout information for declarations.
data EpLayout =
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -247,15 +247,6 @@ mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr))
tcdFixity = fixity,
tcdDataDefn = defn })) }
--- TODO:AZ:temporary
-openParen2AddEpAnn :: EpToken "(" -> [AddEpAnn]
-openParen2AddEpAnn (EpTok l) = [AddEpAnn AnnOpenP l]
-openParen2AddEpAnn NoEpTok = []
-
-closeParen2AddEpAnn :: EpToken ")" -> [AddEpAnn]
-closeParen2AddEpAnn (EpTok l) = [AddEpAnn AnnCloseP l]
-closeParen2AddEpAnn NoEpTok = []
-
mkDataDefn :: Maybe (LocatedP CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsKind GhcPs)
@@ -371,14 +362,13 @@ mkFamDecl :: SrcSpan
-> LHsType GhcPs -- LHS
-> LFamilyResultSig GhcPs -- Optional result signature
-> Maybe (LInjectivityAnn GhcPs) -- Injectivity annotation
- -> [AddEpAnn]
+ -> AnnFamilyDecl
-> P (LTyClDecl GhcPs)
mkFamDecl loc info topLevel lhs ksig injAnn annsIn
= do { (tc, tparams, fixity, ops, cps, cs) <- checkTyClHdr False lhs
; tyvars <- checkTyVars (ppr info) equals_or_where tc tparams
; let loc' = EpAnn (spanAsAnchor loc) noAnn cs
- ; let anns' = annsIn Semi.<>
- concatMap openParen2AddEpAnn ops Semi.<> concatMap closeParen2AddEpAnn cps
+ ; let anns' = annsIn { afd_openp = ops, afd_closep = cps }
; return (L loc' (FamDecl noExtField (FamilyDecl
{ fdExt = anns'
, fdTopLevel = topLevel
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
=====================================
@@ -891,7 +891,20 @@
(EpaComments
[]))
(FamilyDecl
- [(AddEpAnn AnnData (EpaSpan { T17544.hs:22:20-23 }))]
+ (AnnFamilyDecl
+ []
+ []
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { T17544.hs:22:20-23 }))
+ (NoEpTok)
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok))
(DataFamily)
(NotTopLevel)
(L
@@ -1254,7 +1267,20 @@
(EpaComments
[]))
(FamilyDecl
- [(AddEpAnn AnnData (EpaSpan { T17544.hs:28:20-23 }))]
+ (AnnFamilyDecl
+ []
+ []
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { T17544.hs:28:20-23 }))
+ (NoEpTok)
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok))
(DataFamily)
(NotTopLevel)
(L
@@ -1617,7 +1643,20 @@
(EpaComments
[]))
(FamilyDecl
- [(AddEpAnn AnnData (EpaSpan { T17544.hs:34:20-23 }))]
+ (AnnFamilyDecl
+ []
+ []
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { T17544.hs:34:20-23 }))
+ (NoEpTok)
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok))
(DataFamily)
(NotTopLevel)
(L
@@ -1980,7 +2019,20 @@
(EpaComments
[]))
(FamilyDecl
- [(AddEpAnn AnnData (EpaSpan { T17544.hs:40:20-23 }))]
+ (AnnFamilyDecl
+ []
+ []
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { T17544.hs:40:20-23 }))
+ (NoEpTok)
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok))
(DataFamily)
(NotTopLevel)
(L
@@ -2343,7 +2395,20 @@
(EpaComments
[]))
(FamilyDecl
- [(AddEpAnn AnnData (EpaSpan { T17544.hs:46:20-23 }))]
+ (AnnFamilyDecl
+ []
+ []
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { T17544.hs:46:20-23 }))
+ (NoEpTok)
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok))
(DataFamily)
(NotTopLevel)
(L
@@ -2706,7 +2771,20 @@
(EpaComments
[]))
(FamilyDecl
- [(AddEpAnn AnnData (EpaSpan { T17544.hs:52:21-24 }))]
+ (AnnFamilyDecl
+ []
+ []
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { T17544.hs:52:21-24 }))
+ (NoEpTok)
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok))
(DataFamily)
(NotTopLevel)
(L
=====================================
testsuite/tests/parser/should_compile/DumpParsedAst.stderr
=====================================
@@ -298,10 +298,24 @@
(FamDecl
(NoExtField)
(FamilyDecl
- [(AddEpAnn AnnType (EpaSpan { DumpParsedAst.hs:10:1-4 }))
- ,(AddEpAnn AnnFamily (EpaSpan { DumpParsedAst.hs:10:6-11 }))
- ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:10:32-33 }))
- ,(AddEpAnn AnnWhere (EpaSpan { DumpParsedAst.hs:10:41-45 }))]
+ (AnnFamilyDecl
+ []
+ []
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:10:1-4 }))
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:10:6-11 }))
+ (EpUniTok
+ (EpaSpan { DumpParsedAst.hs:10:32-33 })
+ (NormalSyntax))
+ (NoEpTok)
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:10:41-45 }))
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok))
(ClosedTypeFamily
(Just
[(L
@@ -1032,10 +1046,24 @@
(FamDecl
(NoExtField)
(FamilyDecl
- [(AddEpAnn AnnType (EpaSpan { DumpParsedAst.hs:18:1-4 }))
- ,(AddEpAnn AnnFamily (EpaSpan { DumpParsedAst.hs:18:6-11 }))
- ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:18:42-43 }))
- ,(AddEpAnn AnnWhere (EpaSpan { DumpParsedAst.hs:18:50-54 }))]
+ (AnnFamilyDecl
+ []
+ []
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:18:1-4 }))
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:18:6-11 }))
+ (EpUniTok
+ (EpaSpan { DumpParsedAst.hs:18:42-43 })
+ (NormalSyntax))
+ (NoEpTok)
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:18:50-54 }))
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok))
(ClosedTypeFamily
(Just
[(L
@@ -1414,9 +1442,23 @@
(FamDecl
(NoExtField)
(FamilyDecl
- [(AddEpAnn AnnData (EpaSpan { DumpParsedAst.hs:21:1-4 }))
- ,(AddEpAnn AnnFamily (EpaSpan { DumpParsedAst.hs:21:6-11 }))
- ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:21:17-18 }))]
+ (AnnFamilyDecl
+ []
+ []
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:21:1-4 }))
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:21:6-11 }))
+ (EpUniTok
+ (EpaSpan { DumpParsedAst.hs:21:17-18 })
+ (NormalSyntax))
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok))
(DataFamily)
(TopLevel)
(L
=====================================
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
=====================================
@@ -256,7 +256,19 @@
(FamDecl
(NoExtField)
(FamilyDecl
- []
+ (AnnFamilyDecl
+ []
+ []
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok))
(ClosedTypeFamily
(Just
[(L
@@ -688,7 +700,19 @@
(FamDecl
(NoExtField)
(FamilyDecl
- []
+ (AnnFamilyDecl
+ []
+ []
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok))
(DataFamily)
(TopLevel)
(L
@@ -1494,7 +1518,19 @@
(FamDecl
(NoExtField)
(FamilyDecl
- []
+ (AnnFamilyDecl
+ []
+ []
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok))
(ClosedTypeFamily
(Just
[(L
@@ -2051,7 +2087,19 @@
(EpaComments
[]))
(FamilyDecl
- []
+ (AnnFamilyDecl
+ []
+ []
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok))
(OpenTypeFamily)
(NotTopLevel)
(L
=====================================
testsuite/tests/parser/should_compile/KindSigs.stderr
=====================================
@@ -84,9 +84,22 @@
(FamDecl
(NoExtField)
(FamilyDecl
- [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:11:1-4 }))
- ,(AddEpAnn AnnFamily (EpaSpan { KindSigs.hs:11:6-11 }))
- ,(AddEpAnn AnnWhere (EpaSpan { KindSigs.hs:11:19-23 }))]
+ (AnnFamilyDecl
+ []
+ []
+ (EpTok
+ (EpaSpan { KindSigs.hs:11:1-4 }))
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { KindSigs.hs:11:6-11 }))
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { KindSigs.hs:11:19-23 }))
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok))
(ClosedTypeFamily
(Just
[(L
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -2154,11 +2154,11 @@ instance ExactPrint (WarnDecls GhcPs) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (Warnings (an,src) warns) = do
- an0 <- markAnnOpen an src "{-# WARNING" -- Note: might be {-# DEPRECATED
+ exact (Warnings ((o,c),src) warns) = do
+ o' <- markAnnOpen'' o src "{-# WARNING" -- Note: might be {-# DEPRECATED
warns' <- markAnnotated warns
- an1 <- markEpAnnLMS'' an0 lidl AnnClose (Just "#-}")
- return (Warnings (an1,src) warns')
+ c' <- printStringAtAA c "#-}"
+ return (Warnings ((o',c'),src) warns')
-- ---------------------------------------------------------------------
@@ -2220,14 +2220,14 @@ instance ExactPrint FastString where
instance ExactPrint (RuleDecls GhcPs) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (HsRules (an, src) rules) = do
- an0 <-
+ exact (HsRules ((o,c), src) rules) = do
+ o' <-
case src of
- NoSourceText -> markEpAnnLMS'' an lidl AnnOpen (Just "{-# RULES")
- SourceText srcTxt -> markEpAnnLMS'' an lidl AnnOpen (Just $ unpackFS srcTxt)
+ NoSourceText -> printStringAtAA o "{-# RULES"
+ SourceText srcTxt -> printStringAtAA o (unpackFS srcTxt)
rules' <- markAnnotated rules
- an1 <- markEpAnnLMS'' an0 lidl AnnClose (Just "#-}")
- return (HsRules (an1,src) rules')
+ c' <- printStringAtAA c "#-}"
+ return (HsRules ((o',c'),src) rules')
-- ---------------------------------------------------------------------
@@ -2979,13 +2979,13 @@ instance ExactPrint (DefaultDecl GhcPs) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (DefaultDecl an cl tys) = do
- an0 <- markEpAnnL an lidl AnnDefault
- an1 <- markEpAnnL an0 lidl AnnOpenP
+ exact (DefaultDecl (d,op,cp) cl tys) = do
+ d' <- markEpToken d
+ op' <- markEpToken op
cl' <- markAnnotated cl
tys' <- markAnnotated tys
- an2 <- markEpAnnL an1 lidl AnnCloseP
- return (DefaultDecl an2 cl' tys')
+ cp' <- markEpToken cp
+ return (DefaultDecl (d',op',cp') cl' tys')
-- ---------------------------------------------------------------------
@@ -3864,7 +3864,7 @@ instance ExactPrint (FunDep GhcPs) where
exact (FunDep an ls rs') = do
ls' <- markAnnotated ls
- an0 <- markEpAnnL an lidl AnnRarrow
+ an0 <- markEpUniToken an
rs'' <- markAnnotated rs'
return (FunDep an0 ls' rs'')
@@ -3874,7 +3874,7 @@ instance ExactPrint (FamilyDecl GhcPs) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (FamilyDecl { fdExt = an
+ exact (FamilyDecl { fdExt = AnnFamilyDecl ops cps t d f dc eq vb w oc dd cc
, fdInfo = info
, fdTopLevel = top_level
, fdLName = ltycon
@@ -3882,35 +3882,37 @@ instance ExactPrint (FamilyDecl GhcPs) where
, fdFixity = fixity
, fdResultSig = L lr result
, fdInjectivityAnn = mb_inj }) = do
- an0 <- exactFlavour an info
- an1 <- exact_top_level an0
- an2 <- annotationsToComments an1 lidl [AnnOpenP,AnnCloseP]
+ (d',t') <- exactFlavour (d,t) info
+ f' <- exact_top_level f
+
+ epTokensToComments AnnOpenP ops
+ epTokensToComments AnnCloseP cps
(_, ltycon', tyvars',_,_) <- exactVanillaDeclHead ltycon tyvars fixity Nothing
- (an3, result') <- exact_kind an2
- (an4, mb_inj') <-
+ (dc', eq', result') <- exact_kind (dc, eq)
+ (vb', mb_inj') <-
case mb_inj of
- Nothing -> return (an3, mb_inj)
+ Nothing -> return (vb, mb_inj)
Just inj -> do
- an4 <- markEpAnnL an3 lidl AnnVbar
+ vb' <- markEpToken vb
inj' <- markAnnotated inj
- return (an4, Just inj')
- (an5, info') <-
+ return (vb', Just inj')
+ (w', oc', dd', cc', info') <-
case info of
ClosedTypeFamily mb_eqns -> do
- an5 <- markEpAnnL an4 lidl AnnWhere
- an6 <- markEpAnnL an5 lidl AnnOpenC
- (an7, mb_eqns') <-
+ w' <- markEpToken w
+ oc' <- markEpToken oc
+ (dd', mb_eqns') <-
case mb_eqns of
Nothing -> do
- an7 <- markEpAnnL an6 lidl AnnDotdot
- return (an7, mb_eqns)
+ dd' <- markEpToken dd
+ return (dd', mb_eqns)
Just eqns -> do
eqns' <- markAnnotated eqns
- return (an6, Just eqns')
- an8 <- markEpAnnL an7 lidl AnnCloseC
- return (an8, ClosedTypeFamily mb_eqns')
- _ -> return (an4, info)
- return (FamilyDecl { fdExt = an5
+ return (dd, Just eqns')
+ cc' <- markEpToken cc
+ return (w',oc',dd',cc', ClosedTypeFamily mb_eqns')
+ _ -> return (w,oc,dd,cc, info)
+ return (FamilyDecl { fdExt = AnnFamilyDecl [] [] t' d' f' dc' eq' vb' w' oc' dd' cc'
, fdInfo = info'
, fdTopLevel = top_level
, fdLName = ltycon'
@@ -3919,32 +3921,32 @@ instance ExactPrint (FamilyDecl GhcPs) where
, fdResultSig = L lr result'
, fdInjectivityAnn = mb_inj' })
where
- exact_top_level an' =
+ exact_top_level tfamily =
case top_level of
- TopLevel -> markEpAnnL an' lidl AnnFamily
+ TopLevel -> markEpToken tfamily
NotTopLevel -> do
-- It seems that in some kind of legacy
-- mode the 'family' keyword is still
-- accepted.
- markEpAnnL an' lidl AnnFamily
+ markEpToken tfamily
- exact_kind an' =
+ exact_kind (tdcolon, tequal) =
case result of
- NoSig _ -> return (an', result)
+ NoSig _ -> return (tdcolon, tequal, result)
KindSig x kind -> do
- an0 <- markEpAnnL an' lidl AnnDcolon
+ tdcolon' <- markEpUniToken tdcolon
kind' <- markAnnotated kind
- return (an0, KindSig x kind')
+ return (tdcolon', tequal, KindSig x kind')
TyVarSig x tv_bndr -> do
- an0 <- markEpAnnL an' lidl AnnEqual
+ tequal' <- markEpToken tequal
tv_bndr' <- markAnnotated tv_bndr
- return (an0, TyVarSig x tv_bndr')
+ return (tdcolon, tequal', TyVarSig x tv_bndr')
-exactFlavour :: (Monad m, Monoid w) => [AddEpAnn] -> FamilyInfo GhcPs -> EP w m [AddEpAnn]
-exactFlavour an DataFamily = markEpAnnL an lidl AnnData
-exactFlavour an OpenTypeFamily = markEpAnnL an lidl AnnType
-exactFlavour an (ClosedTypeFamily {}) = markEpAnnL an lidl AnnType
+exactFlavour :: (Monad m, Monoid w) => (EpToken "data", EpToken "type") -> FamilyInfo GhcPs -> EP w m (EpToken "data", EpToken "type")
+exactFlavour (td,tt) DataFamily = (\td' -> (td',tt)) <$> markEpToken td
+exactFlavour (td,tt) OpenTypeFamily = (td,) <$> markEpToken tt
+exactFlavour (td,tt) (ClosedTypeFamily {}) = (td,) <$> markEpToken tt
-- ---------------------------------------------------------------------
@@ -4049,12 +4051,11 @@ exactVanillaDeclHead thing tvs@(HsQTvs { hsq_explicit = tyvars }) fixity context
instance ExactPrint (InjectivityAnn GhcPs) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (InjectivityAnn an lhs rhs) = do
- an0 <- markEpAnnL an lidl AnnVbar
+ exact (InjectivityAnn rarrow lhs rhs) = do
lhs' <- markAnnotated lhs
- an1 <- markEpAnnL an0 lidl AnnRarrow
+ rarrow' <- markEpUniToken rarrow
rhs' <- mapM markAnnotated rhs
- return (InjectivityAnn an1 lhs' rhs')
+ return (InjectivityAnn rarrow' lhs' rhs')
-- ---------------------------------------------------------------------
=====================================
utils/check-exact/Main.hs
=====================================
@@ -94,7 +94,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/printer/Ppr002.hs" Nothing
-- "../../testsuite/tests/printer/Ppr002a.hs" Nothing
-- "../../testsuite/tests/printer/Ppr003.hs" Nothing
- "../../testsuite/tests/printer/Ppr004.hs" Nothing
+ -- "../../testsuite/tests/printer/Ppr004.hs" Nothing
-- "../../testsuite/tests/printer/Ppr005.hs" Nothing
-- "../../testsuite/tests/printer/Ppr006.hs" Nothing
-- "../../testsuite/tests/printer/Ppr007.hs" Nothing
@@ -212,7 +212,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/printer/Test21355.hs" Nothing
-- "../../testsuite/tests/printer/Test22765.hs" Nothing
-- "../../testsuite/tests/printer/Test22771.hs" Nothing
- -- "../../testsuite/tests/printer/Test23465.hs" Nothing
+ "../../testsuite/tests/printer/Test23465.hs" Nothing
-- cloneT does not need a test, function can be retired
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f4c2b3bd6a7ffe280a31fac7d0eef34c9934f9ba...702436846e62fe35f25edddfe7ff86ea7694b43c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f4c2b3bd6a7ffe280a31fac7d0eef34c9934f9ba...702436846e62fe35f25edddfe7ff86ea7694b43c
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/20241016/40b88287/attachment-0001.html>
More information about the ghc-commits
mailing list