[Git][ghc/ghc][wip/az/epa-remove-addepann-8] EPA: Remove NameAdornment from NameAnn
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Sat Oct 26 16:55:31 UTC 2024
Alan Zimmerman pushed to branch wip/az/epa-remove-addepann-8 at Glasgow Haskell Compiler / GHC
Commits:
1a41de9c by Alan Zimmerman at 2024-10-26T17:53:22+01:00
EPA: Remove NameAdornment from NameAnn
Also rework AnnContext to use EpToken, and AnnParen
- - - - -
17 changed files:
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- testsuite/tests/ghc-api/exactprint/Test20239.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
- testsuite/tests/parser/should_compile/T20846.stderr
- testsuite/tests/parser/should_compile/T23315/T23315.stderr
- testsuite/tests/printer/Test24533.stdout
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
Changes:
=====================================
compiler/GHC/Hs/Dump.hs
=====================================
@@ -216,11 +216,13 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
BlankSrcSpanFile -> braces $ char ' ' <> (pprUserRealSpan False ss) <> char ' '
annParen :: AnnParen -> SDoc
- annParen (AnnParen a o c) = case ba of
+ annParen ap = case ba of
BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnParen"
- NoBlankEpAnnotations ->
- parens $ text "AnnParen"
- $$ vcat [ppr a, epaLocation o, epaLocation c]
+ NoBlankEpAnnotations -> parens (case ap of
+ (AnnParens o c) -> text "AnnParens" $$ vcat [showAstData' o, showAstData' c]
+ (AnnParensHash o c) -> text "AnnParensHash" $$ vcat [showAstData' o, showAstData' c]
+ (AnnParensSquare o c) -> text "AnnParensSquare" $$ vcat [showAstData' o, showAstData' c]
+ )
annClassDecl :: AnnClassDecl -> SDoc
annClassDecl (AnnClassDecl c ops cps v w oc cc s) = case ba of
=====================================
compiler/GHC/Parser.y
=====================================
@@ -791,7 +791,7 @@ identifier :: { LocatedN RdrName }
| qvarop { $1 }
| qconop { $1 }
| '->' {% amsr (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
- (NameAnnRArrow (isUnicode $1) Nothing (glR $1) Nothing []) }
+ (NameAnnRArrow Nothing (epUniTok $1) Nothing []) }
-----------------------------------------------------------------------------
-- Backpack stuff
@@ -2330,16 +2330,16 @@ atype :: { LHsType GhcPs }
-- Constructor sigs only
-- List and tuple syntax whose interpretation depends on the extension ListTuplePuns.
- | '(' ')' {% amsA' . sLL $1 $> =<< (mkTupleSyntaxTy (glR $1) [] (glR $>)) }
+ | '(' ')' {% amsA' . sLL $1 $> =<< (mkTupleSyntaxTy (epTok $1) [] (epTok $>)) }
| '(' ktype ',' comma_types1 ')' {% do { h <- addTrailingCommaA $2 (gl $3)
- ; amsA' . sLL $1 $> =<< (mkTupleSyntaxTy (glR $1) (h : $4) (glR $>)) }}
+ ; amsA' . sLL $1 $> =<< (mkTupleSyntaxTy (epTok $1) (h : $4) (epTok $>)) }}
| '(#' '#)' {% do { requireLTPuns PEP_TupleSyntaxType $1 $>
- ; amsA' (sLL $1 $> $ HsTupleTy (AnnParen AnnParensHash (glR $1) (glR $2)) HsUnboxedTuple []) } }
+ ; amsA' (sLL $1 $> $ HsTupleTy (AnnParensHash (epTok $1) (epTok $2)) HsUnboxedTuple []) } }
| '(#' comma_types1 '#)' {% do { requireLTPuns PEP_TupleSyntaxType $1 $>
- ; amsA' (sLL $1 $> $ HsTupleTy (AnnParen AnnParensHash (glR $1) (glR $3)) HsUnboxedTuple $2) } }
+ ; amsA' (sLL $1 $> $ HsTupleTy (AnnParensHash (epTok $1) (epTok $3)) HsUnboxedTuple $2) } }
| '(#' bar_types2 '#)' {% do { requireLTPuns PEP_SumSyntaxType $1 $>
- ; amsA' (sLL $1 $> $ HsSumTy (AnnParen AnnParensHash (glR $1) (glR $3)) $2) } }
- | '[' ktype ']' {% amsA' . sLL $1 $> =<< (mkListSyntaxTy1 (glR $1) $2 (glR $3)) }
+ ; amsA' (sLL $1 $> $ HsSumTy (AnnParensHash (epTok $1) (epTok $3)) $2) } }
+ | '[' ktype ']' {% amsA' . sLL $1 $> =<< (mkListSyntaxTy1 (epTok $1) $2 (epTok $3)) }
| '(' ktype ')' {% amsA' (sLL $1 $> $ HsParTy (epTok $1, epTok $3) $2) }
-- see Note [Promotion] for the followings
| SIMPLEQUOTE '(' ')' {% do { requireLTPuns PEP_QuoteDisambiguation $1 $>
@@ -2351,7 +2351,7 @@ atype :: { LHsType GhcPs }
{% do { requireLTPuns PEP_QuoteDisambiguation $1 $>
; h <- addTrailingCommaA $3 (gl $4)
; amsA' (sLL $1 $> $ HsExplicitTupleTy (epTok $1,epTok $2,epTok $6) (h : $5)) }}
- | '[' ']' {% withCombinedComments $1 $> (mkListSyntaxTy0 (glR $1) (glR $2)) }
+ | '[' ']' {% withCombinedComments $1 $> (mkListSyntaxTy0 (epTok $1) (epTok $2)) }
| SIMPLEQUOTE '[' comma_types0 ']' {% do { requireLTPuns PEP_QuoteDisambiguation $1 $>
; amsA' (sLL $1 $> $ HsExplicitListTy (epTok $1, epTok $2, epTok $4) IsPromoted $3) }}
| SIMPLEQUOTE var {% amsA' (sLL $1 $> $ HsTyVar (epTok $1) IsPromoted $2) }
@@ -2630,9 +2630,9 @@ deriv_clause_types :: { LDerivClauseTys GhcPs }
sL1a $1 $ HsTyVar noAnn NotPromoted $1 } in
sL1a $1 (DctSingle noExtField tc) }
| '(' ')' {% amsr (sLL $1 $> (DctMulti noExtField []))
- (AnnContext Nothing [glR $1] [glR $2]) }
+ (AnnContext Nothing [epTok $1] [epTok $2]) }
| '(' deriv_types ')' {% amsr (sLL $1 $> (DctMulti noExtField $2))
- (AnnContext Nothing [glR $1] [glR $3])}
+ (AnnContext Nothing [epTok $1] [epTok $3])}
-----------------------------------------------------------------------------
-- Value definitions
@@ -3759,12 +3759,12 @@ qcon :: { LocatedN RdrName }
gen_qcon :: { LocatedN RdrName }
: qconid { $1 }
| '(' qconsym ')' {% amsr (sLL $1 $> (unLoc $2))
- (NameAnn NameParens (glR $1) (glR $2) (glR $3) []) }
+ (NameAnn (NameParens (epTok $1) (epTok $3)) (glR $2) []) }
con :: { LocatedN RdrName }
: conid { $1 }
| '(' consym ')' {% amsr (sLL $1 $> (unLoc $2))
- (NameAnn NameParens (glR $1) (glR $2) (glR $3) []) }
+ (NameAnn (NameParens (epTok $1) (epTok $3)) (glR $2) []) }
| syscon { $1 }
con_list :: { Located (NonEmpty (LocatedN RdrName)) }
@@ -3779,31 +3779,31 @@ qcon_list : qcon { [$1] }
-- See Note [ExplicitTuple] in GHC.Hs.Expr
sysdcon_nolist :: { LocatedN DataCon } -- Wired in data constructors
: '(' commas ')' {% amsr (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1))
- (NameAnnCommas NameParens (glR $1) (map srcSpan2e (fst $2)) (glR $3) []) }
- | '(#' '#)' {% amsr (sLL $1 $> $ unboxedUnitDataCon) (NameAnnOnly NameParensHash (glR $1) (glR $2) []) }
+ (NameAnnCommas (NameParens (epTok $1) (epTok $3)) (map srcSpan2e (fst $2)) []) }
+ | '(#' '#)' {% amsr (sLL $1 $> $ unboxedUnitDataCon) (NameAnnOnly (NameParensHash (epTok $1) (epTok $2)) []) }
| '(#' commas '#)' {% amsr (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1))
- (NameAnnCommas NameParensHash (glR $1) (map srcSpan2e (fst $2)) (glR $3) []) }
+ (NameAnnCommas (NameParensHash (epTok $1) (epTok $3)) (map srcSpan2e (fst $2)) []) }
syscon :: { LocatedN RdrName }
: sysdcon { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) }
| '(' '->' ')' {% amsr (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
- (NameAnnRArrow (isUnicode $2) (Just $ glR $1) (glR $2) (Just $ glR $3) []) }
+ (NameAnnRArrow (Just $ epTok $1) (epUniTok $2) (Just $ epTok $3) []) }
-- See Note [Empty lists] in GHC.Hs.Expr
sysdcon :: { LocatedN DataCon }
: sysdcon_nolist { $1 }
- | '(' ')' {% amsr (sLL $1 $> unitDataCon) (NameAnnOnly NameParens (glR $1) (glR $2) []) }
- | '[' ']' {% amsr (sLL $1 $> nilDataCon) (NameAnnOnly NameSquare (glR $1) (glR $2) []) }
+ | '(' ')' {% amsr (sLL $1 $> unitDataCon) (NameAnnOnly (NameParens (epTok $1) (epTok $2)) []) }
+ | '[' ']' {% amsr (sLL $1 $> nilDataCon) (NameAnnOnly (NameSquare (epTok $1) (epTok $2)) []) }
conop :: { LocatedN RdrName }
: consym { $1 }
| '`' conid '`' {% amsr (sLL $1 $> (unLoc $2))
- (NameAnn NameBackquotes (glR $1) (glR $2) (glR $3) []) }
+ (NameAnn (NameBackquotes (epTok $1) (epTok $3)) (glR $2) []) }
qconop :: { LocatedN RdrName }
: qconsym { $1 }
| '`' qconid '`' {% amsr (sLL $1 $> (unLoc $2))
- (NameAnn NameBackquotes (glR $1) (glR $2) (glR $3) []) }
+ (NameAnn (NameBackquotes (epTok $1) (epTok $3)) (glR $2) []) }
----------------------------------------------------------------------------
-- Type constructors
@@ -3814,29 +3814,29 @@ qconop :: { LocatedN RdrName }
gtycon :: { LocatedN RdrName } -- A "general" qualified tycon, including unit tuples
: ntgtycon { $1 }
| '(' ')' {% amsr (sLL $1 $> $ getRdrName unitTyCon)
- (NameAnnOnly NameParens (glR $1) (glR $2) []) }
+ (NameAnnOnly (NameParens (epTok $1) (epTok $2)) []) }
| '(#' '#)' {% amsr (sLL $1 $> $ getRdrName unboxedUnitTyCon)
- (NameAnnOnly NameParensHash (glR $1) (glR $2) []) }
+ (NameAnnOnly (NameParensHash (epTok $1) (epTok $2)) []) }
| '[' ']' {% amsr (sLL $1 $> $ listTyCon_RDR)
- (NameAnnOnly NameSquare (glR $1) (glR $2) []) }
+ (NameAnnOnly (NameSquare (epTok $1) (epTok $2)) []) }
ntgtycon :: { LocatedN RdrName } -- A "general" qualified tycon, excluding unit tuples
: oqtycon { $1 }
| '(' commas ')' {% do { n <- mkTupleSyntaxTycon Boxed (snd $2 + 1)
- ; amsr (sLL $1 $> n) (NameAnnCommas NameParens (glR $1) (map srcSpan2e (fst $2)) (glR $3) []) }}
+ ; amsr (sLL $1 $> n) (NameAnnCommas (NameParens (epTok $1) (epTok $3)) (map srcSpan2e (fst $2)) []) }}
| '(#' commas '#)' {% do { n <- mkTupleSyntaxTycon Unboxed (snd $2 + 1)
- ; amsr (sLL $1 $> n) (NameAnnCommas NameParensHash (glR $1) (map srcSpan2e (fst $2)) (glR $3) []) }}
+ ; amsr (sLL $1 $> n) (NameAnnCommas (NameParensHash (epTok $1) (epTok $3)) (map srcSpan2e (fst $2)) []) }}
| '(#' bars '#)' {% do { requireLTPuns PEP_SumSyntaxType $1 $>
; amsr (sLL $1 $> $ (getRdrName (sumTyCon (snd $2 + 1))))
- (NameAnnBars NameParensHash (glR $1) (map srcSpan2e (fst $2)) (glR $3) []) } }
+ (NameAnnBars (epTok $1, epTok $3) (map srcSpan2e (fst $2)) []) } }
| '(' '->' ')' {% amsr (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
- (NameAnnRArrow (isUnicode $2) (Just $ glR $1) (glR $2) (Just $ glR $3) []) }
+ (NameAnnRArrow (Just $ epTok $1) (epUniTok $2) (Just $ epTok $3) []) }
oqtycon :: { LocatedN RdrName } -- An "ordinary" qualified tycon;
-- These can appear in export lists
: qtycon { $1 }
| '(' qtyconsym ')' {% amsr (sLL $1 $> (unLoc $2))
- (NameAnn NameParens (glR $1) (glR $2) (glR $3) []) }
+ (NameAnn (NameParens (epTok $1) (epTok $3)) (glR $2) []) }
oqtycon_no_varcon :: { LocatedN RdrName } -- Type constructor which cannot be mistaken
-- for variable constructor in export lists
@@ -3844,13 +3844,13 @@ oqtycon_no_varcon :: { LocatedN RdrName } -- Type constructor which cannot be m
: qtycon { $1 }
| '(' QCONSYM ')' {% let { name :: Located RdrName
; name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2) }
- in amsr (sLL $1 $> (unLoc name)) (NameAnn NameParens (glR $1) (glR $2) (glR $3) []) }
+ in amsr (sLL $1 $> (unLoc name)) (NameAnn (NameParens (epTok $1) (epTok $3)) (glR $2) []) }
| '(' CONSYM ')' {% let { name :: Located RdrName
; name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2) }
- in amsr (sLL $1 $> (unLoc name)) (NameAnn NameParens (glR $1) (glR $2) (glR $3) []) }
+ in amsr (sLL $1 $> (unLoc name)) (NameAnn (NameParens (epTok $1) (epTok $3)) (glR $2) []) }
| '(' ':' ')' {% let { name :: Located RdrName
; name = sL1 $2 $! consDataCon_RDR }
- in amsr (sLL $1 $> (unLoc name)) (NameAnn NameParens (glR $1) (glR $2) (glR $3) []) }
+ in amsr (sLL $1 $> (unLoc name)) (NameAnn (NameParens (epTok $1) (epTok $3)) (glR $2) []) }
{- Note [Type constructors in export list]
~~~~~~~~~~~~~~~~~~~~~
@@ -3876,7 +3876,7 @@ qtyconop :: { LocatedN RdrName } -- Qualified or unqualified
-- See Note [%shift: qtyconop -> qtyconsym]
: qtyconsym %shift { $1 }
| '`' qtycon '`' {% amsr (sLL $1 $> (unLoc $2))
- (NameAnn NameBackquotes (glR $1) (glR $2) (glR $3) []) }
+ (NameAnn (NameBackquotes (epTok $1) (epTok $3)) (glR $2) []) }
qtycon :: { LocatedN RdrName } -- Qualified or unqualified
: QCONID { sL1n $1 $! mkQual tcClsName (getQCONID $1) }
@@ -3902,7 +3902,7 @@ tyconsym :: { LocatedN RdrName }
otycon :: { LocatedN RdrName }
: tycon { $1 }
| '(' tyconsym ')' {% amsr (sLL $1 $> (unLoc $2))
- (NameAnn NameParens (glR $1) (glR $2) (glR $3) []) }
+ (NameAnn (NameParens (epTok $1) (epTok $3)) (glR $2) []) }
-----------------------------------------------------------------------------
-- Operators
@@ -3911,12 +3911,12 @@ op :: { LocatedN RdrName } -- used in infix decls
: varop { $1 }
| conop { $1 }
| '->' {% amsr (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
- (NameAnnRArrow (isUnicode $1) Nothing (glR $1) Nothing []) }
+ (NameAnnRArrow Nothing (epUniTok $1) Nothing []) }
varop :: { LocatedN RdrName }
: varsym { $1 }
| '`' varid '`' {% amsr (sLL $1 $> (unLoc $2))
- (NameAnn NameBackquotes (glR $1) (glR $2) (glR $3) []) }
+ (NameAnn (NameBackquotes (epTok $1) (epTok $3)) (glR $2) []) }
qop :: { forall b. DisambInfixOp b => PV (LocatedN b) } -- used in sections
: qvarop { mkHsVarOpPV $1 }
@@ -3934,12 +3934,12 @@ hole_op : '`' '_' '`' { sLLa $1 $> (hsHoleExpr (Just $ EpAnnUnboundVar
qvarop :: { LocatedN RdrName }
: qvarsym { $1 }
| '`' qvarid '`' {% amsr (sLL $1 $> (unLoc $2))
- (NameAnn NameBackquotes (glR $1) (glR $2) (glR $3) []) }
+ (NameAnn (NameBackquotes (epTok $1) (epTok $3)) (glR $2) []) }
qvaropm :: { LocatedN RdrName }
: qvarsym_no_minus { $1 }
| '`' qvarid '`' {% amsr (sLL $1 $> (unLoc $2))
- (NameAnn NameBackquotes (glR $1) (glR $2) (glR $3) []) }
+ (NameAnn (NameBackquotes (epTok $1) (epTok $3)) (glR $2) []) }
-----------------------------------------------------------------------------
-- Type variables
@@ -3949,7 +3949,7 @@ tyvar : tyvarid { $1 }
tyvarop :: { LocatedN RdrName }
tyvarop : '`' tyvarid '`' {% amsr (sLL $1 $> (unLoc $2))
- (NameAnn NameBackquotes (glR $1) (glR $2) (glR $3) []) }
+ (NameAnn (NameBackquotes (epTok $1) (epTok $3)) (glR $2) []) }
tyvarid :: { LocatedN RdrName }
: VARID { sL1n $1 $! mkUnqual tvName (getVARID $1) }
@@ -3967,14 +3967,14 @@ tyvarid :: { LocatedN RdrName }
var :: { LocatedN RdrName }
: varid { $1 }
| '(' varsym ')' {% amsr (sLL $1 $> (unLoc $2))
- (NameAnn NameParens (glR $1) (glR $2) (glR $3) []) }
+ (NameAnn (NameParens (epTok $1) (epTok $3)) (glR $2) []) }
qvar :: { LocatedN RdrName }
: qvarid { $1 }
| '(' varsym ')' {% amsr (sLL $1 $> (unLoc $2))
- (NameAnn NameParens (glR $1) (glR $2) (glR $3) []) }
+ (NameAnn (NameParens (epTok $1) (epTok $3)) (glR $2) []) }
| '(' qvarsym1 ')' {% amsr (sLL $1 $> (unLoc $2))
- (NameAnn NameParens (glR $1) (glR $2) (glR $3) []) }
+ (NameAnn (NameParens (epTok $1) (epTok $3)) (glR $2) []) }
-- We've inlined qvarsym here so that the decision about
-- whether it's a qvar or a var can be postponed until
-- *after* we see the close paren.
@@ -4730,7 +4730,7 @@ addTrailingDarrowC :: LocatedC a -> Located Token -> EpAnnComments -> LocatedC a
addTrailingDarrowC (L (EpAnn lr (AnnContext _ o c) csc) a) lt cs =
let
u = if (isUnicode lt) then UnicodeSyntax else NormalSyntax
- in L (EpAnn lr (AnnContext (Just (u,glR lt)) o c) (cs Semi.<> csc)) a
+ in L (EpAnn lr (AnnContext (Just (epUniTok lt)) o c) (cs Semi.<> csc)) a
-- -------------------------------------
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -48,7 +48,7 @@ module GHC.Parser.Annotation (
-- ** Annotation data types used in 'GenLocated'
AnnListItem(..), AnnList(..), AnnListBrackets(..),
- AnnParen(..), ParenType(..), parenTypeKws,
+ AnnParen(..),
AnnPragma(..),
AnnContext(..),
NameAnn(..), NameAdornment(..),
@@ -726,35 +726,20 @@ data AnnListBrackets
-- | exact print annotation for an item having surrounding "brackets", such as
-- tuples or lists
data AnnParen
- = AnnParen {
- ap_adornment :: ParenType,
- ap_open :: EpaLocation,
- ap_close :: EpaLocation
- } deriving (Data)
-
--- | Detail of the "brackets" used in an 'AnnParen' exact print annotation.
-data ParenType
- = AnnParens -- ^ '(', ')'
- | AnnParensHash -- ^ '(#', '#)'
- | AnnParensSquare -- ^ '[', ']'
- deriving (Eq, Ord, Data, Show)
-
--- | Maps the 'ParenType' to the related opening and closing
--- AnnKeywordId. Used when actually printing the item.
-parenTypeKws :: ParenType -> (AnnKeywordId, AnnKeywordId)
-parenTypeKws AnnParens = (AnnOpenP, AnnCloseP)
-parenTypeKws AnnParensHash = (AnnOpenPH, AnnClosePH)
-parenTypeKws AnnParensSquare = (AnnOpenS, AnnCloseS)
+ = AnnParens (EpToken "(") (EpToken ")") -- ^ '(', ')'
+ | AnnParensHash (EpToken "(#") (EpToken "#)") -- ^ '(#', '#)'
+ | AnnParensSquare (EpToken "[") (EpToken "]") -- ^ '[', ']'
+ deriving Data
-- ---------------------------------------------------------------------
-- | Exact print annotation for the 'Context' data type.
data AnnContext
= AnnContext {
- ac_darrow :: Maybe (IsUnicodeSyntax, EpaLocation),
- -- ^ location and encoding of the '=>', if present.
- ac_open :: [EpaLocation], -- ^ zero or more opening parentheses.
- ac_close :: [EpaLocation] -- ^ zero or more closing parentheses.
+ ac_darrow :: Maybe TokDarrow,
+ -- ^ location of the '=>', if present.
+ ac_open :: [EpToken "("], -- ^ zero or more opening parentheses.
+ ac_close :: [EpToken ")"] -- ^ zero or more closing parentheses.
} deriving (Data)
@@ -769,40 +754,31 @@ data NameAnn
-- | Used for a name with an adornment, so '`foo`', '(bar)'
= NameAnn {
nann_adornment :: NameAdornment,
- nann_open :: EpaLocation,
nann_name :: EpaLocation,
- nann_close :: EpaLocation,
nann_trailing :: [TrailingAnn]
}
-- | Used for @(,,,)@, or @(#,,,#)@
| NameAnnCommas {
nann_adornment :: NameAdornment,
- nann_open :: EpaLocation,
nann_commas :: [EpaLocation],
- nann_close :: EpaLocation,
nann_trailing :: [TrailingAnn]
}
-- | Used for @(# | | #)@
| NameAnnBars {
- nann_adornment :: NameAdornment,
- nann_open :: EpaLocation,
+ nann_parensh :: (EpToken "(#", EpToken "#)"),
nann_bars :: [EpaLocation],
- nann_close :: EpaLocation,
nann_trailing :: [TrailingAnn]
}
-- | Used for @()@, @(##)@, @[]@
| NameAnnOnly {
nann_adornment :: NameAdornment,
- nann_open :: EpaLocation,
- nann_close :: EpaLocation,
nann_trailing :: [TrailingAnn]
}
-- | Used for @->@, as an identifier
| NameAnnRArrow {
- nann_unicode :: Bool,
- nann_mopen :: Maybe EpaLocation,
- nann_name :: EpaLocation,
- nann_mclose :: Maybe EpaLocation,
+ nann_mopen :: Maybe (EpToken "("),
+ nann_arrow :: TokRarrow,
+ nann_mclose :: Maybe (EpToken ")"),
nann_trailing :: [TrailingAnn]
}
-- | Used for an item with a leading @'@. The annotation for
@@ -823,11 +799,13 @@ data NameAnn
-- such as parens or backquotes. This data type identifies what
-- particular pair are being used.
data NameAdornment
- = NameParens -- ^ '(' ')'
- | NameParensHash -- ^ '(#' '#)'
- | NameBackquotes -- ^ '`'
- | NameSquare -- ^ '[' ']'
- deriving (Eq, Ord, Data)
+ = NameParens (EpToken "(") (EpToken ")") -- ^ '(' ')'
+ | NameParensHash (EpToken "(#") (EpToken "#)")-- ^ '(#' '#)'
+ | NameBackquotes (EpToken "`") (EpToken "`")-- ^ '`'
+ | NameSquare (EpToken "[") (EpToken "]")-- ^ '[' ']'
+ | NameNoAdornment
+ deriving (Eq, Data)
+
-- ---------------------------------------------------------------------
@@ -1374,7 +1352,7 @@ instance NoAnn AnnPragma where
noAnn = AnnPragma noAnn noAnn noAnn noAnn noAnn noAnn noAnn
instance NoAnn AnnParen where
- noAnn = AnnParen AnnParens noAnn noAnn
+ noAnn = AnnParens noAnn noAnn
instance NoAnn (EpToken s) where
noAnn = NoEpTok
@@ -1432,29 +1410,32 @@ instance (Outputable e)
=> Outputable (GenLocated EpaLocation e) where
ppr = pprLocated
-instance Outputable ParenType where
- ppr t = text (show t)
+instance Outputable AnnParen where
+ ppr (AnnParens o c) = text "AnnParens" <+> ppr o <+> ppr c
+ ppr (AnnParensHash o c) = text "AnnParensHash" <+> ppr o <+> ppr c
+ ppr (AnnParensSquare o c) = text "AnnParensSquare" <+> ppr o <+> ppr c
instance Outputable AnnListItem where
ppr (AnnListItem ts) = text "AnnListItem" <+> ppr ts
instance Outputable NameAdornment where
- ppr NameParens = text "NameParens"
- ppr NameParensHash = text "NameParensHash"
- ppr NameBackquotes = text "NameBackquotes"
- ppr NameSquare = text "NameSquare"
+ ppr (NameParens o c) = text "NameParens" <+> ppr o <+> ppr c
+ ppr (NameParensHash o c) = text "NameParensHash" <+> ppr o <+> ppr c
+ ppr (NameBackquotes o c) = text "NameBackquotes" <+> ppr o <+> ppr c
+ ppr (NameSquare o c) = text "NameSquare" <+> ppr o <+> ppr c
+ ppr NameNoAdornment = text "NameNoAdornment"
instance Outputable NameAnn where
- ppr (NameAnn a o n c t)
- = text "NameAnn" <+> ppr a <+> ppr o <+> ppr n <+> ppr c <+> ppr t
- ppr (NameAnnCommas a o n c t)
- = text "NameAnnCommas" <+> ppr a <+> ppr o <+> ppr n <+> ppr c <+> ppr t
- ppr (NameAnnBars a o n b t)
- = text "NameAnnBars" <+> ppr a <+> ppr o <+> ppr n <+> ppr b <+> ppr t
- ppr (NameAnnOnly a o c t)
- = text "NameAnnOnly" <+> ppr a <+> ppr o <+> ppr c <+> ppr t
- ppr (NameAnnRArrow u o n c t)
- = text "NameAnnRArrow" <+> ppr u <+> ppr o <+> ppr n <+> ppr c <+> ppr t
+ ppr (NameAnn a n t)
+ = text "NameAnn" <+> ppr a <+> ppr n <+> ppr t
+ ppr (NameAnnCommas a n t)
+ = text "NameAnnCommas" <+> ppr a <+> ppr n <+> ppr t
+ ppr (NameAnnBars a n t)
+ = text "NameAnnBars" <+> ppr a <+> ppr n <+> ppr t
+ ppr (NameAnnOnly a t)
+ = text "NameAnnOnly" <+> ppr a <+> ppr t
+ ppr (NameAnnRArrow o n c t)
+ = text "NameAnnRArrow" <+> ppr o <+> ppr n <+> ppr c <+> ppr t
ppr (NameAnnQuote q n t)
= text "NameAnnQuote" <+> ppr q <+> ppr n <+> ppr t
ppr (NameAnnTrailing t)
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1102,7 +1102,7 @@ checkTyClHdr is_cls ty
let
lr = combineSrcSpans (locA l1) (locA l)
in
- EpAnn (EpaSpan lr) (NameAnn NameParens (getEpTokenLoc o) ap (getEpTokenLoc c) ta) (csp0 Semi.<> csp)
+ EpAnn (EpaSpan lr) (NameAnn (NameParens o c) ap ta) (csp0 Semi.<> csp)
-- | Yield a parse error if we have a function applied directly to a do block
-- etc. and BlockArguments is not enabled.
@@ -1148,13 +1148,13 @@ checkContext :: LHsType GhcPs -> P (LHsContext GhcPs)
checkContext orig_t@(L (EpAnn l _ cs) _orig_t) =
check ([],[],cs) orig_t
where
- check :: ([EpaLocation],[EpaLocation],EpAnnComments)
+ check :: ([EpToken "("],[EpToken ")"],EpAnnComments)
-> LHsType GhcPs -> P (LHsContext GhcPs)
- check (oparens,cparens,cs) (L _l (HsTupleTy ann' HsBoxedOrConstraintTuple ts))
+ check (oparens,cparens,cs) (L _l (HsTupleTy (AnnParens o c) HsBoxedOrConstraintTuple ts))
-- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can
-- be used as context constraints.
-- Ditto ()
- = mkCTuple (oparens ++ [ap_open ann'], ap_close ann' : cparens, cs) ts
+ = mkCTuple (oparens ++ [o], c : cparens, cs) ts
-- With NoListTuplePuns, contexts are parsed as data constructors, which causes failure
-- downstream.
@@ -1164,15 +1164,13 @@ checkContext orig_t@(L (EpAnn l _ cs) _orig_t) =
True -> unprocessed
False -> do
let
- ol = (getEpTokenLoc o)
- cl = (getEpTokenLoc c)
(op, cp) = case q of
- EpTok ql -> ([ql], [cl])
- _ -> ([ol], [cl])
+ EpTok ql -> ([EpTok ql], [c])
+ _ -> ([o], [c])
mkCTuple (oparens ++ op, cp ++ cparens, cs) ts
check (opi,cpi,csi) (L _lp1 (HsParTy (o,c) ty))
-- to be sure HsParTy doesn't get into the way
- = check (getEpTokenLoc o:opi, getEpTokenLoc c:cpi, csi) ty
+ = check (o:opi, c:cpi, csi) ty
-- No need for anns, returning original
check (_opi,_cpi,_csi) _t = unprocessed
@@ -1200,16 +1198,16 @@ checkContextExpr :: LHsExpr GhcPs -> PV (LocatedC [LHsExpr GhcPs])
checkContextExpr orig_expr@(L (EpAnn l _ cs) _) =
check ([],[], cs) orig_expr
where
- check :: ([EpaLocation],[EpaLocation],EpAnnComments)
+ check :: ([EpToken "("],[EpToken ")"],EpAnnComments)
-> LHsExpr GhcPs -> PV (LocatedC [LHsExpr GhcPs])
check (oparens,cparens,cs) (L _ (ExplicitTuple (ap_open, ap_close) tup_args boxity))
-- Neither unboxed tuples (#e1,e2#) nor tuple sections (e1,,e2,) can be a context
| isBoxed boxity
, Just es <- tupArgsPresent_maybe tup_args
- = mkCTuple (oparens ++ [ap_open], ap_close : cparens, cs) es
- check (opi, cpi, csi) (L _ (HsPar (EpTok open_tok, EpTok close_tok) expr))
+ = mkCTuple (oparens ++ [EpTok ap_open], EpTok ap_close : cparens, cs) es
+ check (opi, cpi, csi) (L _ (HsPar (open_tok, close_tok) expr))
= check (opi ++ [open_tok], close_tok : cpi, csi) expr
- check (oparens,cparens,cs) (L _ (HsVar _ (L (EpAnn _ (NameAnnOnly NameParens open closed []) _) name)))
+ check (oparens,cparens,cs) (L _ (HsVar _ (L (EpAnn _ (NameAnnOnly (NameParens open closed) []) _) name)))
| name == nameRdrName (dataConName unitDataCon)
= mkCTuple (oparens ++ [open], closed : cparens, cs) []
check _ _ = unprocessed
@@ -3613,9 +3611,9 @@ withCombinedComments start end use = do
-- type or data constructor, based on the extension @ListTuplePuns at .
-- The case with an explicit promotion quote, @'(Int, Double)@, is handled
-- by 'mkExplicitTupleTy'.
-mkTupleSyntaxTy :: EpaLocation
+mkTupleSyntaxTy :: EpToken "("
-> [LocatedA (HsType GhcPs)]
- -> EpaLocation
+ -> EpToken ")"
-> P (HsType GhcPs)
mkTupleSyntaxTy parOpen args parClose =
punsIfElse enabled disabled
@@ -3625,8 +3623,8 @@ mkTupleSyntaxTy parOpen args parClose =
disabled =
HsExplicitTupleTy annsKeyword args
- annParen = AnnParen AnnParens parOpen parClose
- annsKeyword = (NoEpTok, EpTok parOpen, EpTok parClose)
+ annParen = AnnParens parOpen parClose
+ annsKeyword = (NoEpTok, parOpen, parClose)
-- | Decide whether to parse tuple con syntax @(,)@ in a type as a
-- type or data constructor, based on the extension @ListTuplePuns at .
@@ -3642,8 +3640,8 @@ mkTupleSyntaxTycon boxity n =
-- constructor, based on the extension @ListTuplePuns at .
-- The case with an explicit promotion quote, @'[]@, is handled by
-- 'mkExplicitListTy'.
-mkListSyntaxTy0 :: EpaLocation
- -> EpaLocation
+mkListSyntaxTy0 :: EpToken "["
+ -> EpToken "]"
-> SrcSpan
-> P (HsType GhcPs)
mkListSyntaxTy0 brkOpen brkClose span =
@@ -3657,17 +3655,17 @@ mkListSyntaxTy0 brkOpen brkClose span =
disabled =
HsExplicitListTy annsKeyword NotPromoted []
- rdrNameAnn = NameAnnOnly NameSquare brkOpen brkClose []
- annsKeyword = (NoEpTok, EpTok brkOpen, EpTok brkClose)
+ rdrNameAnn = NameAnnOnly (NameSquare brkOpen brkClose) []
+ annsKeyword = (NoEpTok, brkOpen, brkClose)
fullLoc = EpaSpan span
-- | Decide whether to parse list type syntax @[Int]@ in a type as a
-- type or data constructor, based on the extension @ListTuplePuns at .
-- The case with an explicit promotion quote, @'[Int]@, is handled
-- by 'mkExplicitListTy'.
-mkListSyntaxTy1 :: EpaLocation
+mkListSyntaxTy1 :: EpToken "["
-> LocatedA (HsType GhcPs)
- -> EpaLocation
+ -> EpToken "]"
-> P (HsType GhcPs)
mkListSyntaxTy1 brkOpen t brkClose =
punsIfElse enabled disabled
@@ -3677,5 +3675,5 @@ mkListSyntaxTy1 brkOpen t brkClose =
disabled =
HsExplicitListTy annsKeyword NotPromoted [t]
- annsKeyword = (NoEpTok, EpTok brkOpen, EpTok brkClose)
- annParen = AnnParen AnnParensSquare brkOpen brkClose
+ annsKeyword = (NoEpTok, brkOpen, brkClose)
+ annParen = AnnParensSquare brkOpen brkClose
=====================================
testsuite/tests/ghc-api/exactprint/Test20239.stderr
=====================================
@@ -366,10 +366,11 @@
(EpaComments
[]))
(HsTupleTy
- (AnnParen
- AnnParens
- (EpaSpan { Test20239.hs:7:83 })
- (EpaSpan { Test20239.hs:7:84 }))
+ (AnnParens
+ (EpTok
+ (EpaSpan { Test20239.hs:7:83 }))
+ (EpTok
+ (EpaSpan { Test20239.hs:7:84 })))
(HsBoxedOrConstraintTuple)
[])))))))))))))])
(Nothing)))])
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
=====================================
@@ -257,10 +257,11 @@
(EpaComments
[]))
(HsTupleTy
- (AnnParen
- AnnParens
- (EpaSpan { T17544_kw.hs:19:18 })
- (EpaSpan { T17544_kw.hs:19:19 }))
+ (AnnParens
+ (EpTok
+ (EpaSpan { T17544_kw.hs:19:18 }))
+ (EpTok
+ (EpaSpan { T17544_kw.hs:19:19 })))
(HsBoxedOrConstraintTuple)
[])))])
(L
=====================================
testsuite/tests/parser/should_compile/DumpParsedAst.stderr
=====================================
@@ -254,10 +254,11 @@
(EpaComments
[]))
(HsListTy
- (AnnParen
- AnnParensSquare
- (EpaSpan { DumpParsedAst.hs:9:16 })
- (EpaSpan { DumpParsedAst.hs:9:18 }))
+ (AnnParensSquare
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:9:16 }))
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:9:18 })))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:9:17 })
@@ -626,10 +627,11 @@
(EpaComments
[]))
(HsListTy
- (AnnParen
- AnnParensSquare
- (EpaSpan { DumpParsedAst.hs:10:27 })
- (EpaSpan { DumpParsedAst.hs:10:29 }))
+ (AnnParensSquare
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:10:27 }))
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:10:29 })))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:10:28 })
=====================================
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
=====================================
@@ -548,10 +548,11 @@
(EpaComments
[]))
(HsListTy
- (AnnParen
- AnnParensSquare
- (EpaSpan { DumpRenamedAst.hs:12:27 })
- (EpaSpan { DumpRenamedAst.hs:12:29 }))
+ (AnnParensSquare
+ (EpTok
+ (EpaSpan { DumpRenamedAst.hs:12:27 }))
+ (EpTok
+ (EpaSpan { DumpRenamedAst.hs:12:29 })))
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:12:28 })
@@ -646,10 +647,11 @@
(EpaComments
[]))
(HsListTy
- (AnnParen
- AnnParensSquare
- (EpaSpan { DumpRenamedAst.hs:11:16 })
- (EpaSpan { DumpRenamedAst.hs:11:18 }))
+ (AnnParensSquare
+ (EpTok
+ (EpaSpan { DumpRenamedAst.hs:11:16 }))
+ (EpTok
+ (EpaSpan { DumpRenamedAst.hs:11:18 })))
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:11:17 })
@@ -2231,10 +2233,11 @@
(EpaComments
[]))
(HsListTy
- (AnnParen
- AnnParensSquare
- (EpaSpan { DumpRenamedAst.hs:31:12 })
- (EpaSpan { DumpRenamedAst.hs:31:14 }))
+ (AnnParensSquare
+ (EpTok
+ (EpaSpan { DumpRenamedAst.hs:31:12 }))
+ (EpTok
+ (EpaSpan { DumpRenamedAst.hs:31:14 })))
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:31:13 })
@@ -2292,10 +2295,11 @@
(EpaComments
[]))
(HsListTy
- (AnnParen
- AnnParensSquare
- (EpaSpan { DumpRenamedAst.hs:32:10 })
- (EpaSpan { DumpRenamedAst.hs:32:12 }))
+ (AnnParensSquare
+ (EpTok
+ (EpaSpan { DumpRenamedAst.hs:32:10 }))
+ (EpTok
+ (EpaSpan { DumpRenamedAst.hs:32:12 })))
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:32:11 })
=====================================
testsuite/tests/parser/should_compile/DumpSemis.stderr
=====================================
@@ -223,10 +223,11 @@
(EpaComments
[]))
(HsTupleTy
- (AnnParen
- AnnParens
- (EpaSpan { DumpSemis.hs:9:11 })
- (EpaSpan { DumpSemis.hs:9:12 }))
+ (AnnParens
+ (EpTok
+ (EpaSpan { DumpSemis.hs:9:11 }))
+ (EpTok
+ (EpaSpan { DumpSemis.hs:9:12 })))
(HsBoxedOrConstraintTuple)
[]))))))))))
,(L
@@ -527,10 +528,11 @@
(EpaComments
[]))
(HsTupleTy
- (AnnParen
- AnnParens
- (EpaSpan { DumpSemis.hs:14:11 })
- (EpaSpan { DumpSemis.hs:14:12 }))
+ (AnnParens
+ (EpTok
+ (EpaSpan { DumpSemis.hs:14:11 }))
+ (EpTok
+ (EpaSpan { DumpSemis.hs:14:12 })))
(HsBoxedOrConstraintTuple)
[]))))))))))
,(L
@@ -792,10 +794,11 @@
(EpaComments
[]))
(HsTupleTy
- (AnnParen
- AnnParens
- (EpaSpan { DumpSemis.hs:21:11 })
- (EpaSpan { DumpSemis.hs:21:12 }))
+ (AnnParens
+ (EpTok
+ (EpaSpan { DumpSemis.hs:21:11 }))
+ (EpTok
+ (EpaSpan { DumpSemis.hs:21:12 })))
(HsBoxedOrConstraintTuple)
[]))))))))))
,(L
@@ -1547,13 +1550,17 @@
(EpaSpan { DumpSemis.hs:31:6-20 })
(AnnContext
(Just
- ((,)
- (NormalSyntax)
- (EpaSpan { DumpSemis.hs:31:22-23 })))
- [(EpaSpan { DumpSemis.hs:31:6 })
- ,(EpaSpan { DumpSemis.hs:31:7 })]
- [(EpaSpan { DumpSemis.hs:31:19 })
- ,(EpaSpan { DumpSemis.hs:31:20 })])
+ (EpUniTok
+ (EpaSpan { DumpSemis.hs:31:22-23 })
+ (NormalSyntax)))
+ [(EpTok
+ (EpaSpan { DumpSemis.hs:31:6 }))
+ ,(EpTok
+ (EpaSpan { DumpSemis.hs:31:7 }))]
+ [(EpTok
+ (EpaSpan { DumpSemis.hs:31:19 }))
+ ,(EpTok
+ (EpaSpan { DumpSemis.hs:31:20 }))])
(EpaComments
[]))
[(L
=====================================
testsuite/tests/parser/should_compile/KindSigs.stderr
=====================================
@@ -312,10 +312,11 @@
(EpaComments
[]))
(HsTupleTy
- (AnnParen
- AnnParens
- (EpaSpan { KindSigs.hs:15:14 })
- (EpaSpan { KindSigs.hs:15:51 }))
+ (AnnParens
+ (EpTok
+ (EpaSpan { KindSigs.hs:15:14 }))
+ (EpTok
+ (EpaSpan { KindSigs.hs:15:51 })))
(HsBoxedOrConstraintTuple)
[(L
(EpAnn
@@ -529,10 +530,11 @@
(EpaComments
[]))
(HsTupleTy
- (AnnParen
- AnnParensHash
- (EpaSpan { KindSigs.hs:16:15-16 })
- (EpaSpan { KindSigs.hs:16:53-54 }))
+ (AnnParensHash
+ (EpTok
+ (EpaSpan { KindSigs.hs:16:15-16 }))
+ (EpTok
+ (EpaSpan { KindSigs.hs:16:53-54 })))
(HsUnboxedTuple)
[(L
(EpAnn
@@ -719,10 +721,11 @@
(EpaComments
[]))
(HsListTy
- (AnnParen
- AnnParensSquare
- (EpaSpan { KindSigs.hs:19:12 })
- (EpaSpan { KindSigs.hs:19:26 }))
+ (AnnParensSquare
+ (EpTok
+ (EpaSpan { KindSigs.hs:19:12 }))
+ (EpTok
+ (EpaSpan { KindSigs.hs:19:26 })))
(L
(EpAnn
(EpaSpan { KindSigs.hs:19:14-24 })
@@ -949,10 +952,11 @@
(EpaComments
[]))
(HsTupleTy
- (AnnParen
- AnnParens
- (EpaSpan { KindSigs.hs:22:34 })
- (EpaSpan { KindSigs.hs:22:35 }))
+ (AnnParens
+ (EpTok
+ (EpaSpan { KindSigs.hs:22:34 }))
+ (EpTok
+ (EpaSpan { KindSigs.hs:22:35 })))
(HsBoxedOrConstraintTuple)
[]))
(L
@@ -1085,9 +1089,11 @@
(EpAnn
(EpaSpan { KindSigs.hs:23:11-12 })
(NameAnnOnly
- (NameParens)
- (EpaSpan { KindSigs.hs:23:11 })
- (EpaSpan { KindSigs.hs:23:12 })
+ (NameParens
+ (EpTok
+ (EpaSpan { KindSigs.hs:23:11 }))
+ (EpTok
+ (EpaSpan { KindSigs.hs:23:12 })))
[])
(EpaComments
[]))
@@ -1480,10 +1486,11 @@
(EpaComments
[]))
(HsListTy
- (AnnParen
- AnnParensSquare
- (EpaSpan { KindSigs.hs:28:34 })
- (EpaSpan { KindSigs.hs:28:39 }))
+ (AnnParensSquare
+ (EpTok
+ (EpaSpan { KindSigs.hs:28:34 }))
+ (EpTok
+ (EpaSpan { KindSigs.hs:28:39 })))
(L
(EpAnn
(EpaSpan { KindSigs.hs:28:35-38 })
=====================================
testsuite/tests/parser/should_compile/T15323.stderr
=====================================
@@ -182,9 +182,9 @@
(EpaSpan { T15323.hs:6:31-36 })
(AnnContext
(Just
- ((,)
- (NormalSyntax)
- (EpaSpan { T15323.hs:6:38-39 })))
+ (EpUniTok
+ (EpaSpan { T15323.hs:6:38-39 })
+ (NormalSyntax)))
[]
[])
(EpaComments
=====================================
testsuite/tests/parser/should_compile/T20452.stderr
=====================================
@@ -455,10 +455,11 @@
(EpaComments
[]))
(HsListTy
- (AnnParen
- AnnParensSquare
- (EpaSpan { T20452.hs:8:57 })
- (EpaSpan { T20452.hs:8:74 }))
+ (AnnParensSquare
+ (EpTok
+ (EpaSpan { T20452.hs:8:57 }))
+ (EpTok
+ (EpaSpan { T20452.hs:8:74 })))
(L
(EpAnn
(EpaSpan { T20452.hs:8:58-73 })
@@ -467,10 +468,11 @@
(EpaComments
[]))
(HsTupleTy
- (AnnParen
- AnnParens
- (EpaSpan { T20452.hs:8:58 })
- (EpaSpan { T20452.hs:8:73 }))
+ (AnnParens
+ (EpTok
+ (EpaSpan { T20452.hs:8:58 }))
+ (EpTok
+ (EpaSpan { T20452.hs:8:73 })))
(HsBoxedOrConstraintTuple)
[(L
(EpAnn
@@ -698,10 +700,11 @@
(EpaComments
[]))
(HsListTy
- (AnnParen
- AnnParensSquare
- (EpaSpan { T20452.hs:9:57 })
- (EpaSpan { T20452.hs:9:74 }))
+ (AnnParensSquare
+ (EpTok
+ (EpaSpan { T20452.hs:9:57 }))
+ (EpTok
+ (EpaSpan { T20452.hs:9:74 })))
(L
(EpAnn
(EpaSpan { T20452.hs:9:58-73 })
@@ -710,10 +713,11 @@
(EpaComments
[]))
(HsTupleTy
- (AnnParen
- AnnParens
- (EpaSpan { T20452.hs:9:58 })
- (EpaSpan { T20452.hs:9:73 }))
+ (AnnParens
+ (EpTok
+ (EpaSpan { T20452.hs:9:58 }))
+ (EpTok
+ (EpaSpan { T20452.hs:9:73 })))
(HsBoxedOrConstraintTuple)
[(L
(EpAnn
=====================================
testsuite/tests/parser/should_compile/T20846.stderr
=====================================
@@ -113,10 +113,12 @@
(EpAnn
(EpaSpan { T20846.hs:4:1-6 })
(NameAnn
- (NameParens)
- (EpaSpan { T20846.hs:4:1 })
+ (NameParens
+ (EpTok
+ (EpaSpan { T20846.hs:4:1 }))
+ (EpTok
+ (EpaSpan { T20846.hs:4:6 })))
(EpaSpan { T20846.hs:4:2-5 })
- (EpaSpan { T20846.hs:4:6 })
[])
(EpaComments
[]))
=====================================
testsuite/tests/parser/should_compile/T23315/T23315.stderr
=====================================
@@ -101,10 +101,11 @@
(EpaComments
[]))
(HsTupleTy
- (AnnParen
- AnnParens
- (EpaSpan { T23315.hsig:3:6 })
- (EpaSpan { T23315.hsig:3:7 }))
+ (AnnParens
+ (EpTok
+ (EpaSpan { T23315.hsig:3:6 }))
+ (EpTok
+ (EpaSpan { T23315.hsig:3:7 })))
(HsBoxedOrConstraintTuple)
[]))))))))
,(L
=====================================
testsuite/tests/printer/Test24533.stdout
=====================================
@@ -89,11 +89,13 @@
(EpaSpan { Test24533.hs:(5,3)-(7,3) })
(AnnContext
(Just
- ((,)
- (NormalSyntax)
- (EpaSpan { Test24533.hs:7:5-6 })))
- [(EpaSpan { Test24533.hs:5:3 })]
- [(EpaSpan { Test24533.hs:7:3 })])
+ (EpUniTok
+ (EpaSpan { Test24533.hs:7:5-6 })
+ (NormalSyntax)))
+ [(EpTok
+ (EpaSpan { Test24533.hs:5:3 }))]
+ [(EpTok
+ (EpaSpan { Test24533.hs:7:3 }))])
(EpaComments
[(L
(EpaSpan
@@ -233,10 +235,11 @@
(EpaComments
[]))
(HsTupleTy
- (AnnParen
- AnnParens
- (EpaSpan { Test24533.hs:8:8 })
- (EpaSpan { Test24533.hs:8:13 }))
+ (AnnParens
+ (EpTok
+ (EpaSpan { Test24533.hs:8:8 }))
+ (EpTok
+ (EpaSpan { Test24533.hs:8:13 })))
(HsBoxedOrConstraintTuple)
[(L
(EpAnn
@@ -761,11 +764,13 @@
(EpaSpan { Test24533.ppr.hs:3:10-25 })
(AnnContext
(Just
- ((,)
- (NormalSyntax)
- (EpaSpan { Test24533.ppr.hs:3:27-28 })))
- [(EpaSpan { Test24533.ppr.hs:3:10 })]
- [(EpaSpan { Test24533.ppr.hs:3:25 })])
+ (EpUniTok
+ (EpaSpan { Test24533.ppr.hs:3:27-28 })
+ (NormalSyntax)))
+ [(EpTok
+ (EpaSpan { Test24533.ppr.hs:3:10 }))]
+ [(EpTok
+ (EpaSpan { Test24533.ppr.hs:3:25 }))])
(EpaComments
[]))
[(L
@@ -899,10 +904,11 @@
(EpaComments
[]))
(HsTupleTy
- (AnnParen
- AnnParens
- (EpaSpan { Test24533.ppr.hs:3:35 })
- (EpaSpan { Test24533.ppr.hs:3:40 }))
+ (AnnParens
+ (EpTok
+ (EpaSpan { Test24533.ppr.hs:3:35 }))
+ (EpTok
+ (EpaSpan { Test24533.ppr.hs:3:40 })))
(HsBoxedOrConstraintTuple)
[(L
(EpAnn
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -291,12 +291,12 @@ instance HasTrailing AnnPragma where
instance HasTrailing AnnContext where
trailing (AnnContext ma _opens _closes)
= case ma of
- Just (UnicodeSyntax, r) -> [AddDarrowUAnn r]
- Just (NormalSyntax, r) -> [AddDarrowAnn r]
- Nothing -> []
+ Just (EpUniTok r UnicodeSyntax) -> [AddDarrowUAnn r]
+ Just (EpUniTok r NormalSyntax) -> [AddDarrowAnn r]
+ _ -> []
- setTrailing a [AddDarrowUAnn r] = a {ac_darrow = Just (UnicodeSyntax, r)}
- setTrailing a [AddDarrowAnn r] = a{ac_darrow = Just (NormalSyntax, r)}
+ setTrailing a [AddDarrowUAnn r] = a {ac_darrow = Just (EpUniTok r UnicodeSyntax)}
+ setTrailing a [AddDarrowAnn r] = a{ac_darrow = Just (EpUniTok r NormalSyntax)}
setTrailing a [] = a{ac_darrow = Nothing}
setTrailing a ts = error $ "Cannot setTrailing " ++ showAst ts ++ " for " ++ showAst a
@@ -882,27 +882,32 @@ markAnnOpen'' el NoSourceText txt = printStringAtAA el txt
markAnnOpen'' el (SourceText txt) _ = printStringAtAA el $ unpackFS txt
-- ---------------------------------------------------------------------
-{-
-data AnnParen
- = AnnParen {
- ap_adornment :: ParenType,
- ap_open :: EpaLocation,
- ap_close :: EpaLocation
- } deriving (Data)
--}
+
markOpeningParen, markClosingParen :: (Monad m, Monoid w) => AnnParen -> EP w m AnnParen
-markOpeningParen an = markParen an lfst
-markClosingParen an = markParen an lsnd
-
-markParen :: (Monad m, Monoid w) => AnnParen -> (forall a. Lens (a,a) a) -> EP w m AnnParen
-markParen (AnnParen pt o c) l = do
- loc' <- markKwA (view l $ kw pt) (view l (o, c))
- let (o',c') = set l loc' (o,c)
- return (AnnParen pt o' c')
- where
- kw AnnParens = (AnnOpenP, AnnCloseP)
- kw AnnParensHash = (AnnOpenPH, AnnClosePH)
- kw AnnParensSquare = (AnnOpenS, AnnCloseS)
+markOpeningParen an = markParenO an
+markClosingParen an = markParenC an
+
+markParenO :: (Monad m, Monoid w) => AnnParen -> EP w m AnnParen
+markParenO (AnnParens o c) = do
+ o' <- markEpToken o
+ return (AnnParens o' c)
+markParenO (AnnParensHash o c) = do
+ o' <- markEpToken o
+ return (AnnParensHash o' c)
+markParenO (AnnParensSquare o c) = do
+ o' <- markEpToken o
+ return (AnnParensSquare o' c)
+
+markParenC :: (Monad m, Monoid w) => AnnParen -> EP w m AnnParen
+markParenC (AnnParens o c) = do
+ c' <- markEpToken c
+ return (AnnParens o c')
+markParenC (AnnParensHash o c) = do
+ c' <- markEpToken c
+ return (AnnParensHash o c')
+markParenC (AnnParensSquare o c) = do
+ c' <- markEpToken c
+ return (AnnParensSquare o c')
-- ---------------------------------------------------------------------
-- Bare bones Optics
@@ -1028,10 +1033,6 @@ lal_rest :: Lens (AnnList l) l
lal_rest k parent = fmap (\new -> parent { al_rest = new })
(k (al_rest parent))
--- lal_trailing :: Lens AnnList [TrailingAnn]
--- lal_trailing k parent = fmap (\new -> parent { al_trailing = new })
--- (k (al_trailing parent))
-
-- -------------------------------------
lid :: Lens a a
@@ -4175,9 +4176,9 @@ instance (ExactPrint a) => ExactPrint (LocatedC a) where
setAnnotationAnchor = setAnchorAn
exact (L (EpAnn anc (AnnContext ma opens closes) cs) a) = do
- opens' <- mapM (markKwA AnnOpenP) opens
+ opens' <- mapM markEpToken opens
a' <- markAnnotated a
- closes' <- mapM (markKwA AnnCloseP) closes
+ closes' <- mapM markEpToken closes
return (L (EpAnn anc (AnnContext ma opens' closes') cs) a')
-- ---------------------------------------------------------------------
@@ -4213,43 +4214,30 @@ instance ExactPrint (LocatedN RdrName) where
exact (L (EpAnn anc ann cs) n) = do
ann' <-
case ann of
- NameAnn a o l c t -> do
- mn <- markName a o (Just (l,n)) c
+ NameAnn a l t -> do
+ mn <- markName a (Just (l,n))
case mn of
- (o', (Just (l',_n)), c') -> do
- return (NameAnn a o' l' c' t)
+ (a', (Just (l',_n))) -> do
+ return (NameAnn a' l' t)
_ -> error "ExactPrint (LocatedN RdrName)"
- NameAnnCommas a o commas c t -> do
- let (kwo,kwc) = adornments a
- (AddEpAnn _ o') <- markKwC NoCaptureComments (AddEpAnn kwo o)
+ NameAnnCommas a commas t -> do
+ a0 <- markNameAdornmentO a
commas' <- forM commas (\loc -> locFromAdd <$> markKwC NoCaptureComments (AddEpAnn AnnComma loc))
- (AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn kwc c)
- return (NameAnnCommas a o' commas' c' t)
- NameAnnBars a o bars c t -> do
- let (kwo,kwc) = adornments a
- (AddEpAnn _ o') <- markKwC NoCaptureComments (AddEpAnn kwo o)
+ a1 <- markNameAdornmentC a0
+ return (NameAnnCommas a1 commas' t)
+ NameAnnBars (o,c) bars t -> do
+ o' <- markEpToken o
bars' <- forM bars (\loc -> locFromAdd <$> markKwC NoCaptureComments (AddEpAnn AnnVbar loc))
- (AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn kwc c)
- return (NameAnnBars a o' bars' c' t)
- NameAnnOnly a o c t -> do
- (o',_,c') <- markName a o Nothing c
- return (NameAnnOnly a o' c' t)
- NameAnnRArrow unicode o nl c t -> do
- o' <- case o of
- Just o0 -> do
- (AddEpAnn _ o') <- markKwC NoCaptureComments (AddEpAnn AnnOpenP o0)
- return (Just o')
- Nothing -> return Nothing
- (AddEpAnn _ nl') <-
- if unicode
- then markKwC NoCaptureComments (AddEpAnn AnnRarrowU nl)
- else markKwC NoCaptureComments (AddEpAnn AnnRarrow nl)
- c' <- case c of
- Just c0 -> do
- (AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn AnnCloseP c0)
- return (Just c')
- Nothing -> return Nothing
- return (NameAnnRArrow unicode o' nl' c' t)
+ c' <- markEpToken c
+ return (NameAnnBars (o',c') bars' t)
+ NameAnnOnly a t -> do
+ (a',_) <- markName a Nothing
+ return (NameAnnOnly a' t)
+ NameAnnRArrow o nl c t -> do
+ o' <- mapM markEpToken o
+ nl' <- markEpUniToken nl
+ c' <- mapM markEpToken c
+ return (NameAnnRArrow o' nl' c' t)
NameAnnQuote q name t -> do
debugM $ "NameAnnQuote"
(AddEpAnn _ q') <- markKwC NoCaptureComments (AddEpAnn AnnSimpleQuote q)
@@ -4260,6 +4248,37 @@ instance ExactPrint (LocatedN RdrName) where
return (NameAnnTrailing t)
return (L (EpAnn anc ann' cs) n)
+
+markNameAdornmentO :: (Monad m, Monoid w) => NameAdornment -> EP w m NameAdornment
+markNameAdornmentO (NameParens o c) = do
+ o' <- markEpToken o
+ return (NameParens o' c)
+markNameAdornmentO (NameParensHash o c) = do
+ o' <- markEpToken o
+ return (NameParensHash o' c)
+markNameAdornmentO (NameBackquotes o c) = do
+ o' <- markEpToken o
+ return (NameBackquotes o' c)
+markNameAdornmentO (NameSquare o c) = do
+ o' <- markEpToken o
+ return (NameSquare o' c)
+markNameAdornmentO NameNoAdornment = return NameNoAdornment
+
+markNameAdornmentC :: (Monad m, Monoid w) => NameAdornment -> EP w m NameAdornment
+markNameAdornmentC (NameParens o c) = do
+ c' <- markEpToken c
+ return (NameParens o c')
+markNameAdornmentC (NameParensHash o c) = do
+ c' <- markEpToken c
+ return (NameParensHash o c')
+markNameAdornmentC (NameBackquotes o c) = do
+ c' <- markEpToken c
+ return (NameBackquotes o c')
+markNameAdornmentC (NameSquare o c) = do
+ c' <- markEpToken c
+ return (NameSquare o c')
+markNameAdornmentC NameNoAdornment = return NameNoAdornment
+
locFromAdd :: AddEpAnn -> EpaLocation
locFromAdd (AddEpAnn _ loc) = loc
@@ -4277,25 +4296,18 @@ printUnicode anc n = do
markName :: (Monad m, Monoid w)
- => NameAdornment -> EpaLocation -> Maybe (EpaLocation,RdrName) -> EpaLocation
- -> EP w m (EpaLocation, Maybe (EpaLocation,RdrName), EpaLocation)
-markName adorn open mname close = do
- let (kwo,kwc) = adornments adorn
- (AddEpAnn _ open') <- markKwC CaptureComments (AddEpAnn kwo open)
+ => NameAdornment -> Maybe (EpaLocation,RdrName)
+ -> EP w m (NameAdornment, Maybe (EpaLocation,RdrName))
+markName adorn mname = do
+ adorn0 <- markNameAdornmentO adorn
mname' <-
case mname of
Nothing -> return Nothing
Just (name, a) -> do
name' <- printStringAtAAC CaptureComments name (showPprUnsafe a)
return (Just (name',a))
- (AddEpAnn _ close') <- markKwC CaptureComments (AddEpAnn kwc close)
- return (open', mname', close')
-
-adornments :: NameAdornment -> (AnnKeywordId, AnnKeywordId)
-adornments NameParens = (AnnOpenP, AnnCloseP)
-adornments NameParensHash = (AnnOpenPH, AnnClosePH)
-adornments NameBackquotes = (AnnBackquote, AnnBackquote)
-adornments NameSquare = (AnnOpenS, AnnCloseS)
+ adorn1 <- markNameAdornmentC adorn0
+ return (adorn1, mname')
markTrailing :: (Monad m, Monoid w) => [TrailingAnn] -> EP w m [TrailingAnn]
markTrailing ts = do
=====================================
utils/haddock/haddock-api/src/Haddock/Types.hs
=====================================
@@ -998,40 +998,31 @@ instance NFData (EpAnn NameAnn) where
rnf (EpAnn en ann cs) = en `deepseq` ann `deepseq` cs `deepseq` ()
instance NFData NameAnn where
- rnf (NameAnn a b c d e) =
+ rnf (NameAnn a b c) =
a `deepseq`
b `deepseq`
c `deepseq`
- d `deepseq`
- e `deepseq`
- ()
- rnf (NameAnnCommas a b c d e) =
+ ()
+ rnf (NameAnnCommas a b c) =
a `deepseq`
b `deepseq`
c `deepseq`
- d `deepseq`
- e `deepseq`
- ()
- rnf (NameAnnBars a b c d e) =
+ ()
+ rnf (NameAnnBars a b c) =
a `deepseq`
b `deepseq`
c `deepseq`
- d `deepseq`
- e `deepseq`
- ()
- rnf (NameAnnOnly a b c d) =
+ ()
+ rnf (NameAnnOnly a b) =
a `deepseq`
b `deepseq`
- c `deepseq`
- d `deepseq`
- ()
- rnf (NameAnnRArrow a b c d e) =
+ ()
+ rnf (NameAnnRArrow a b c d) =
a `deepseq`
b `deepseq`
c `deepseq`
d `deepseq`
- e `deepseq`
- ()
+ ()
rnf (NameAnnQuote a b c) =
a `deepseq`
b `deepseq`
@@ -1047,10 +1038,11 @@ instance NFData TrailingAnn where
rnf (AddDarrowUAnn epaL) = rnf epaL
instance NFData NameAdornment where
- rnf NameParens = ()
- rnf NameParensHash = ()
- rnf NameBackquotes = ()
- rnf NameSquare = ()
+ rnf (NameParens o c) = o `deepseq` c `seq` ()
+ rnf (NameParensHash o c) = o `deepseq` c `seq` ()
+ rnf (NameBackquotes o c) = o `deepseq` c `seq` ()
+ rnf (NameSquare o c) = o `deepseq` c `seq` ()
+ rnf NameNoAdornment = ()
instance NFData NoComments where
rnf NoComments = ()
@@ -1085,3 +1077,15 @@ instance NFData BufPos where
instance NFData DeltaPos where
rnf (SameLine n) = rnf n
rnf (DifferentLine n m) = n `deepseq` m `deepseq` ()
+
+instance NFData (EpToken tok) where
+ rnf (EpTok l) = rnf l
+ rnf NoEpTok = ()
+
+instance NFData (EpUniToken tok toku) where
+ rnf (EpUniTok l s) = l `deepseq` s `deepseq` ()
+ rnf NoEpUniTok = ()
+
+instance NFData IsUnicodeSyntax where
+ rnf NormalSyntax = ()
+ rnf UnicodeSyntax = ()
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1a41de9cd511b8d971c92fc8fcd9b973b6609c72
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1a41de9cd511b8d971c92fc8fcd9b973b6609c72
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/20241026/eb0484bf/attachment-0001.html>
More information about the ghc-commits
mailing list