[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: EPA: Remove [AddEpAnn] commit 3
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Oct 17 03:28:24 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
53009148 by Alan Zimmerman at 2024-10-16T23:27:48-04:00
EPA: Remove [AddEpAnn] commit 3
EPA: Remove [AddEpAnn] from HsDocTy
EPA: Remove [AddEpAnn] from HsBangTy
EPA: Remove [AddEpAnn] from HsExplicitListTy
EPA: Remove [AddEpAnn] from HsExplicitTupleTy
EPA: Remove [AddEpAnn] from HsTypedBracket
EPA: Remove [AddEpAnn] from HsUntypedBracket
EPA: Remove [AddEpAnn] from PatBuilderOpApp
EPA: break out 'EpToken "|"' from ClassDecl anns
EPA: Remove [AddEpAnn] from ClassDecl
EPA: Remove [AddEpAnn] from SynDecl
- - - - -
cf72d5f7 by Daan Rijks at 2024-10-16T23:27:48-04:00
Expand the haddocks for Control.Category
- - - - -
cecae385 by Andrew Lelechenko at 2024-10-16T23:27:48-04:00
documentation: more examples for Control.Category
- - - - -
26 changed files:
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Parser/Types.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/ThToHs.hs
- libraries/base/src/Control/Category.hs
- libraries/ghc-internal/src/GHC/Internal/Control/Category.hs
- testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/parser/should_compile/KindSigs.stderr
- testsuite/tests/parser/should_compile/T20452.stderr
- testsuite/tests/printer/AnnotationNoListTuplePuns.stdout
- testsuite/tests/printer/Test24533.stdout
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
Changes:
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -31,6 +31,8 @@ module GHC.Hs.Decls (
-- ** Class or type declarations
TyClDecl(..), LTyClDecl, DataDeclRn(..),
+ AnnClassDecl(..),
+ AnnSynDecl(..),
TyClGroup(..),
tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,
tyClGroupKindSigs,
@@ -353,7 +355,7 @@ instance Outputable SpliceDecoration where
type instance XFamDecl (GhcPass _) = NoExtField
-type instance XSynDecl GhcPs = [AddEpAnn]
+type instance XSynDecl GhcPs = AnnSynDecl
type instance XSynDecl GhcRn = NameSet -- FVs
type instance XSynDecl GhcTc = NameSet -- FVs
@@ -368,7 +370,7 @@ data DataDeclRn = DataDeclRn
deriving Data
type instance XClassDecl GhcPs =
- ( [AddEpAnn]
+ ( AnnClassDecl
, EpLayout -- See Note [Class EpLayout]
, AnnSortKey DeclTag ) -- TODO:AZ:tidy up AnnSortKey
@@ -380,6 +382,32 @@ type instance XXTyClDecl (GhcPass _) = DataConCantHappen
type instance XCTyFamInstDecl (GhcPass _) = [AddEpAnn]
type instance XXTyFamInstDecl (GhcPass _) = DataConCantHappen
+data AnnClassDecl
+ = AnnClassDecl {
+ acd_class :: EpToken "class",
+ acd_openp :: [EpToken "("],
+ acd_closep :: [EpToken ")"],
+ acd_vbar :: EpToken "|",
+ acd_where :: EpToken "where",
+ acd_openc :: EpToken "{",
+ acd_closec :: EpToken "}",
+ acd_semis :: [EpToken ";"]
+ } deriving Data
+
+instance NoAnn AnnClassDecl where
+ noAnn = AnnClassDecl noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn
+
+data AnnSynDecl
+ = AnnSynDecl {
+ asd_opens :: [EpToken "("],
+ asd_closes :: [EpToken ")"],
+ asd_type :: EpToken "type",
+ asd_equal :: EpToken "="
+ } deriving Data
+
+instance NoAnn AnnSynDecl where
+ noAnn = AnnSynDecl noAnn noAnn noAnn noAnn
+
------------- Pretty printing FamilyDecls -----------
pprFlavour :: FamilyInfo pass -> SDoc
=====================================
compiler/GHC/Hs/Dump.hs
=====================================
@@ -67,10 +67,14 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
`extQ` annotationAnnList
`extQ` annotationEpAnnImportDecl
`extQ` annotationNoEpAnns
+ `extQ` annotationExprBracket
+ `extQ` annotationTypedBracket
`extQ` addEpAnn
`extQ` epTokenOC
`extQ` epTokenCC
`extQ` annParen
+ `extQ` annClassDecl
+ `extQ` annSynDecl
`extQ` lit `extQ` litr `extQ` litt
`extQ` sourceText
`extQ` deltaPos
@@ -203,6 +207,23 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
parens $ text "AnnParen"
$$ vcat [ppr a, epaLocation o, epaLocation c]
+ annClassDecl :: AnnClassDecl -> SDoc
+ annClassDecl (AnnClassDecl c ops cps v w oc cc s) = case ba of
+ BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnClassDecl"
+ NoBlankEpAnnotations ->
+ parens $ text "AnnClassDecl"
+ $$ vcat [showAstData' c, showAstData' ops, showAstData' cps,
+ showAstData' v, showAstData' w, showAstData' oc,
+ showAstData' cc, showAstData' s]
+
+ annSynDecl :: AnnSynDecl -> SDoc
+ annSynDecl (AnnSynDecl ops cps t e) = case ba of
+ BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnSynDecl"
+ NoBlankEpAnnotations ->
+ parens $ text "AnnSynDecl"
+ $$ vcat [showAstData' ops, showAstData' cps,
+ showAstData' t, showAstData' e]
+
addEpAnn :: AddEpAnn -> SDoc
addEpAnn (AddEpAnn a s) = case ba of
BlankEpAnnotations -> parens
@@ -210,6 +231,22 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
NoBlankEpAnnotations ->
parens $ text "AddEpAnn" <+> ppr a <+> epaLocation s
+ annotationExprBracket :: BracketAnn (EpUniToken "[|" "⟦") (EpToken "[e|") -> SDoc
+ annotationExprBracket = annotationBracket
+
+ annotationTypedBracket :: BracketAnn (EpToken "[||") (EpToken "[e||") -> SDoc
+ annotationTypedBracket = annotationBracket
+
+ annotationBracket ::forall n h .(Data n, Data h, Typeable n, Typeable h)
+ => BracketAnn n h -> SDoc
+ annotationBracket a = case ba of
+ BlankEpAnnotations -> parens
+ $ text "blanked:" <+> text "BracketAnn"
+ NoBlankEpAnnotations ->
+ parens $ case a of
+ BracketNoE t -> text "BracketNoE" <+> showAstData' t
+ BracketHasE t -> text "BracketHasE" <+> showAstData' t
+
epTokenOC :: EpToken "{" -> SDoc
epTokenOC = epToken'
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -181,15 +181,23 @@ data HsBracketTc = HsBracketTc
-- pasted back in by the desugarer
}
-type instance XTypedBracket GhcPs = [AddEpAnn]
+type instance XTypedBracket GhcPs = (BracketAnn (EpToken "[||") (EpToken "[e||"), EpToken "||]")
type instance XTypedBracket GhcRn = NoExtField
type instance XTypedBracket GhcTc = HsBracketTc
-type instance XUntypedBracket GhcPs = [AddEpAnn]
+type instance XUntypedBracket GhcPs = NoExtField
type instance XUntypedBracket GhcRn = [PendingRnSplice] -- See Note [Pending Splices]
-- Output of the renamer is the *original* renamed expression,
-- plus _renamed_ splices to be type checked
type instance XUntypedBracket GhcTc = HsBracketTc
+data BracketAnn noE hasE
+ = BracketNoE noE
+ | BracketHasE hasE
+ deriving Data
+
+instance (NoAnn n, NoAnn h) => NoAnn (BracketAnn n h) where
+ noAnn = BracketNoE noAnn
+
-- ---------------------------------------------------------------------
-- API Annotations types
@@ -2141,12 +2149,12 @@ ppr_splice herald mn e
<> ppr e
-type instance XExpBr GhcPs = NoExtField
-type instance XPatBr GhcPs = NoExtField
-type instance XDecBrL GhcPs = NoExtField
+type instance XExpBr GhcPs = (BracketAnn (EpUniToken "[|" "⟦") (EpToken "[e|"), EpUniToken "|]" "⟧")
+type instance XPatBr GhcPs = (EpToken "[p|", EpUniToken "|]" "⟧")
+type instance XDecBrL GhcPs = (EpToken "[d|", EpUniToken "|]" "⟧", (EpToken "{", EpToken "}"))
type instance XDecBrG GhcPs = NoExtField
-type instance XTypBr GhcPs = NoExtField
-type instance XVarBr GhcPs = NoExtField
+type instance XTypBr GhcPs = (EpToken "[t|", EpUniToken "|]" "⟧")
+type instance XVarBr GhcPs = EpaLocation
type instance XXQuote GhcPs = DataConCantHappen
type instance XExpBr GhcRn = NoExtField
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -475,18 +475,18 @@ type instance XSpliceTy GhcPs = NoExtField
type instance XSpliceTy GhcRn = HsUntypedSpliceResult (LHsType GhcRn)
type instance XSpliceTy GhcTc = Kind
-type instance XDocTy (GhcPass _) = [AddEpAnn]
-type instance XBangTy (GhcPass _) = ([AddEpAnn], SourceText)
+type instance XDocTy (GhcPass _) = NoExtField
+type instance XBangTy (GhcPass _) = ((EpaLocation, EpaLocation, EpaLocation), SourceText)
type instance XRecTy GhcPs = AnnList
type instance XRecTy GhcRn = NoExtField
type instance XRecTy GhcTc = NoExtField
-type instance XExplicitListTy GhcPs = [AddEpAnn]
+type instance XExplicitListTy GhcPs = (EpToken "'", EpToken "[", EpToken "]")
type instance XExplicitListTy GhcRn = NoExtField
type instance XExplicitListTy GhcTc = Kind
-type instance XExplicitTupleTy GhcPs = [AddEpAnn]
+type instance XExplicitTupleTy GhcPs = (EpToken "'", EpToken "(", EpToken ")")
type instance XExplicitTupleTy GhcRn = NoExtField
type instance XExplicitTupleTy GhcTc = [Kind]
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1292,8 +1292,9 @@ topdecl :: { LHsDecl GhcPs }
--
cl_decl :: { LTyClDecl GhcPs }
: 'class' tycl_hdr fds where_cls
- {% (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (sndOf3 $ unLoc $4) (thdOf3 $ unLoc $4))
- (mj AnnClass $1:(fst $ unLoc $3)++(fstOf3 $ unLoc $4)) }
+ {% do { let {(wtok, (oc,semis,cc)) = fstOf3 $ unLoc $4}
+ ; mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (sndOf3 $ unLoc $4) (thdOf3 $ unLoc $4)
+ (AnnClassDecl (epTok $1) [] [] (fst $ unLoc $3) wtok oc cc semis) }}
-- Default declarations (toplevel)
--
@@ -1314,7 +1315,7 @@ ty_decl :: { LTyClDecl GhcPs }
--
-- Note the use of type for the head; this allows
-- infix type constructors to be declared
- {% mkTySynonym (comb2 $1 $4) $2 $4 [mj AnnType $1,mj AnnEqual $3] }
+ {% mkTySynonym (comb2 $1 $4) $2 $4 (epTok $1) (epTok $3) }
-- type family declarations
| 'type' 'family' type opt_tyfam_kind_sig opt_injective_info
@@ -1749,9 +1750,9 @@ decl_cls : at_decl_cls { $1 }
quotes (ppr $2)
; amsA' (sLL $1 $> $ SigD noExtField $ ClassOpSig (AnnSig (epUniTok $3) Nothing (Just (epTok $1))) True [v] $4) }}
-decls_cls :: { Located ([AddEpAnn],OrdList (LHsDecl GhcPs)) } -- Reversed
+decls_cls :: { Located ([EpToken ";"],OrdList (LHsDecl GhcPs)) } -- Reversed
: decls_cls ';' decl_cls {% if isNilOL (snd $ unLoc $1)
- then return (sLL $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)
+ then return (sLL $1 $> ((fst $ unLoc $1) ++ [mzEpTok $2]
, unitOL $3))
else case (snd $ unLoc $1) of
SnocOL hs t -> do
@@ -1759,7 +1760,7 @@ decls_cls :: { Located ([AddEpAnn],OrdList (LHsDecl GhcPs)) } -- Reversed
return (sLL $1 $> (fst $ unLoc $1
, snocOL hs t' `appOL` unitOL $3)) }
| decls_cls ';' {% if isNilOL (snd $ unLoc $1)
- then return (sLZ $1 $> ( (fst $ unLoc $1) ++ (mz AnnSemi $2)
+ then return (sLZ $1 $> ( (fst $ unLoc $1) ++ [mzEpTok $2]
,snd $ unLoc $1))
else case (snd $ unLoc $1) of
SnocOL hs t -> do
@@ -1770,24 +1771,24 @@ decls_cls :: { Located ([AddEpAnn],OrdList (LHsDecl GhcPs)) } -- Reversed
| {- empty -} { noLoc ([],nilOL) }
decllist_cls
- :: { Located ([AddEpAnn]
+ :: { Located ((EpToken "{", [EpToken ";"], EpToken "}")
, OrdList (LHsDecl GhcPs)
, EpLayout) } -- Reversed
- : '{' decls_cls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2)
+ : '{' decls_cls '}' { sLL $1 $> ((epTok $1, fst $ unLoc $2, epTok $3)
,snd $ unLoc $2, epExplicitBraces $1 $3) }
| vocurly decls_cls close { let { L l (anns, decls) = $2 }
- in L l (anns, decls, EpVirtualBraces (getVOCURLY $1)) }
+ in L l ((NoEpTok, anns, NoEpTok), decls, EpVirtualBraces (getVOCURLY $1)) }
-- Class body
--
-where_cls :: { Located ([AddEpAnn]
+where_cls :: { Located ((EpToken "where", (EpToken "{", [EpToken ";"], EpToken "}"))
,(OrdList (LHsDecl GhcPs)) -- Reversed
,EpLayout) }
-- No implicit parameters
-- May have type declarations
- : 'where' decllist_cls { sLL $1 $> (mj AnnWhere $1:(fstOf3 $ unLoc $2)
+ : 'where' decllist_cls { sLL $1 $> ((epTok $1,fstOf3 $ unLoc $2)
,sndOf3 $ unLoc $2,thdOf3 $ unLoc $2) }
- | {- empty -} { noLoc ([],nilOL,EpNoLayout) }
+ | {- empty -} { noLoc ((noAnn, noAnn),nilOL,EpNoLayout) }
-- Declarations in instance bodies
--
@@ -2177,8 +2178,8 @@ sigtypes1 :: { OrdList (LHsSigType GhcPs) }
-- Types
unpackedness :: { Located UnpackednessPragma }
- : '{-# UNPACK' '#-}' { sLL $1 $> (UnpackednessPragma [mo $1, mc $2] (getUNPACK_PRAGs $1) SrcUnpack) }
- | '{-# NOUNPACK' '#-}' { sLL $1 $> (UnpackednessPragma [mo $1, mc $2] (getNOUNPACK_PRAGs $1) SrcNoUnpack) }
+ : '{-# UNPACK' '#-}' { sLL $1 $> (UnpackednessPragma (glR $1, glR $2) (getUNPACK_PRAGs $1) SrcUnpack) }
+ | '{-# NOUNPACK' '#-}' { sLL $1 $> (UnpackednessPragma (glR $1, glR $2) (getNOUNPACK_PRAGs $1) SrcNoUnpack) }
forall_telescope :: { Located (HsForAllTelescope GhcPs) }
: 'forall' tv_bndrs '.' {% do { hintExplicitForall $1
@@ -2304,8 +2305,8 @@ atype :: { LHsType GhcPs }
; return $ sL1a $1 (HsStarTy noExtField (isUnicode $1)) } }
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
- | PREFIX_TILDE atype {% amsA' (sLL $1 $> (mkBangTy [mj AnnTilde $1] SrcLazy $2)) }
- | PREFIX_BANG atype {% amsA' (sLL $1 $> (mkBangTy [mj AnnBang $1] SrcStrict $2)) }
+ | PREFIX_TILDE atype {% amsA' (sLL $1 $> (mkBangTy (glR $1) SrcLazy $2)) }
+ | PREFIX_BANG atype {% amsA' (sLL $1 $> (mkBangTy (glR $1) SrcStrict $2)) }
| '{' fielddecls '}' {% do { decls <- amsA' (sLL $1 $> $ HsRecTy (AnnList (listAsAnchorM $2) (Just $ moc $1) (Just $ mcc $3) [] []) $2)
; checkRecordSyntax decls }}
@@ -2325,17 +2326,17 @@ atype :: { LHsType GhcPs }
| '(' ktype ')' {% amsA' (sLL $1 $> $ HsParTy (AnnParen AnnParens (glR $1) (glR $3)) $2) }
-- see Note [Promotion] for the followings
| SIMPLEQUOTE '(' ')' {% do { requireLTPuns PEP_QuoteDisambiguation $1 $>
- ; amsA' (sLL $1 $> $ HsExplicitTupleTy [mj AnnSimpleQuote $1,mop $2,mcp $3] []) }}
+ ; amsA' (sLL $1 $> $ HsExplicitTupleTy (epTok $1,epTok $2,epTok $3) []) }}
| SIMPLEQUOTE gen_qcon {% amsA' (sLL $1 $> $ HsTyVar (epTok $1) IsPromoted $2) }
| SIMPLEQUOTE sysdcon_nolist {% do { requireLTPuns PEP_QuoteDisambiguation $1 (reLoc $>)
; amsA' (sLL $1 $> $ HsTyVar (epTok $1) IsPromoted (L (getLoc $2) $ nameRdrName (dataConName (unLoc $2)))) }}
| SIMPLEQUOTE '(' ktype ',' comma_types1 ')'
{% do { requireLTPuns PEP_QuoteDisambiguation $1 $>
; h <- addTrailingCommaA $3 (gl $4)
- ; amsA' (sLL $1 $> $ HsExplicitTupleTy [mj AnnSimpleQuote $1,mop $2,mcp $6] (h : $5)) }}
+ ; amsA' (sLL $1 $> $ HsExplicitTupleTy (epTok $1,epTok $2,epTok $6) (h : $5)) }}
| '[' ']' {% withCombinedComments $1 $> (mkListSyntaxTy0 (glR $1) (glR $2)) }
| SIMPLEQUOTE '[' comma_types0 ']' {% do { requireLTPuns PEP_QuoteDisambiguation $1 $>
- ; amsA' (sLL $1 $> $ HsExplicitListTy [mj AnnSimpleQuote $1,mos $2,mcs $4] IsPromoted $3) }}
+ ; amsA' (sLL $1 $> $ HsExplicitListTy (epTok $1, epTok $2, epTok $4) IsPromoted $3) }}
| SIMPLEQUOTE var {% amsA' (sLL $1 $> $ HsTyVar (epTok $1) IsPromoted $2) }
| quasiquote { mapLocA (HsSpliceTy noExtField) $1 }
@@ -2346,7 +2347,7 @@ atype :: { LHsType GhcPs }
-- (One means a list type, zero means the list type constructor,
-- so you have to quote those.)
| '[' ktype ',' comma_types1 ']' {% do { h <- addTrailingCommaA $2 (gl $3)
- ; amsA' (sLL $1 $> $ HsExplicitListTy [mos $1,mcs $5] NotPromoted (h:$4)) }}
+ ; amsA' (sLL $1 $> $ HsExplicitListTy (NoEpTok,epTok $1,epTok $5) NotPromoted (h:$4)) }}
| INTEGER { sLLa $1 $> $ HsTyLit noExtField $ HsNumTy (getINTEGERs $1)
(il_value (getINTEGER $1)) }
| CHAR { sLLa $1 $> $ HsTyLit noExtField $ HsCharTy (getCHARs $1)
@@ -2420,10 +2421,9 @@ tyvar_wc :: { Located (HsBndrVar GhcPs) }
: tyvar { sL1 $1 (HsBndrVar noExtField $1) }
| '_' { sL1 $1 (HsBndrWildCard noExtField) }
-fds :: { Located ([AddEpAnn],[LHsFunDep GhcPs]) }
- : {- empty -} { noLoc ([],[]) }
- | '|' fds1 { (sLL $1 $> ([mj AnnVbar $1]
- ,reverse (unLoc $2))) }
+fds :: { Located (EpToken "|",[LHsFunDep GhcPs]) }
+ : {- empty -} { noLoc (NoEpTok,[]) }
+ | '|' fds1 { (sLL $1 $> (epTok $1 ,reverse (unLoc $2))) }
fds1 :: { Located [LHsFunDep GhcPs] }
: fds1 ',' fd {%
@@ -3138,26 +3138,26 @@ aexp2 :: { ECP }
| splice_untyped { ECP $ mkHsSplicePV $1 }
| splice_typed { ecpFromExp $ fmap (uncurry HsTypedSplice) (reLoc $1) }
- | SIMPLEQUOTE qvar {% fmap ecpFromExp $ amsA' (sLL $1 $> $ HsUntypedBracket [mj AnnSimpleQuote $1] (VarBr noExtField True $2)) }
- | SIMPLEQUOTE qcon {% fmap ecpFromExp $ amsA' (sLL $1 $> $ HsUntypedBracket [mj AnnSimpleQuote $1] (VarBr noExtField True $2)) }
- | TH_TY_QUOTE tyvar {% fmap ecpFromExp $ amsA' (sLL $1 $> $ HsUntypedBracket [mj AnnThTyQuote $1 ] (VarBr noExtField False $2)) }
- | TH_TY_QUOTE gtycon {% fmap ecpFromExp $ amsA' (sLL $1 $> $ HsUntypedBracket [mj AnnThTyQuote $1 ] (VarBr noExtField False $2)) }
+ | SIMPLEQUOTE qvar {% fmap ecpFromExp $ amsA' (sLL $1 $> $ HsUntypedBracket noExtField (VarBr (glR $1) True $2)) }
+ | SIMPLEQUOTE qcon {% fmap ecpFromExp $ amsA' (sLL $1 $> $ HsUntypedBracket noExtField (VarBr (glR $1) True $2)) }
+ | TH_TY_QUOTE tyvar {% fmap ecpFromExp $ amsA' (sLL $1 $> $ HsUntypedBracket noExtField (VarBr (glR $1) False $2)) }
+ | TH_TY_QUOTE gtycon {% fmap ecpFromExp $ amsA' (sLL $1 $> $ HsUntypedBracket noExtField (VarBr (glR $1) False $2)) }
-- See Note [%shift: aexp2 -> TH_TY_QUOTE]
| TH_TY_QUOTE %shift {% reportEmptyDoubleQuotes (getLoc $1) }
| '[|' exp '|]' {% runPV (unECP $2) >>= \ $2 ->
fmap ecpFromExp $
- amsA' (sLL $1 $> $ HsUntypedBracket (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3]
- else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) (ExpBr noExtField $2)) }
+ amsA' (sLL $1 $> $ HsUntypedBracket noExtField (ExpBr (if (hasE $1) then (BracketHasE (epTok $1), epUniTok $3)
+ else (BracketNoE (epUniTok $1), epUniTok $3)) $2)) }
| '[||' exp '||]' {% runPV (unECP $2) >>= \ $2 ->
fmap ecpFromExp $
- amsA' (sLL $1 $> $ HsTypedBracket (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) $2) }
+ amsA' (sLL $1 $> $ HsTypedBracket (if (hasE $1) then (BracketHasE (epTok $1),epTok $3) else (BracketNoE (epTok $1),epTok $3)) $2) }
| '[t|' ktype '|]' {% fmap ecpFromExp $
- amsA' (sLL $1 $> $ HsUntypedBracket [mo $1,mu AnnCloseQ $3] (TypBr noExtField $2)) }
+ amsA' (sLL $1 $> $ HsUntypedBracket noExtField (TypBr (epTok $1,epUniTok $3) $2)) }
| '[p|' infixexp '|]' {% (checkPattern <=< runPV) (unECP $2) >>= \p ->
fmap ecpFromExp $
- amsA' (sLL $1 $> $ HsUntypedBracket [mo $1,mu AnnCloseQ $3] (PatBr noExtField p)) }
+ amsA' (sLL $1 $> $ HsUntypedBracket noExtField (PatBr (epTok $1,epUniTok $3) p)) }
| '[d|' cvtopbody '|]' {% fmap ecpFromExp $
- amsA' (sLL $1 $> $ HsUntypedBracket (mo $1:mu AnnCloseQ $3:fst $2) (DecBrL noExtField (snd $2))) }
+ amsA' (sLL $1 $> $ HsUntypedBracket noExtField (DecBrL (epTok $1,epUniTok $3, fst $2) (snd $2))) }
| quasiquote { ECP $ mkHsSplicePV $1 }
-- arrow notation extension
@@ -3197,10 +3197,9 @@ acmd :: { LHsCmdTop GhcPs }
runPV (checkCmdBlockArguments cmd) >>= \ _ ->
return (sL1a cmd $ HsCmdTop noExtField cmd) }
-cvtopbody :: { ([AddEpAnn],[LHsDecl GhcPs]) }
- : '{' cvtopdecls0 '}' { ([mj AnnOpenC $1
- ,mj AnnCloseC $3],$2) }
- | vocurly cvtopdecls0 close { ([],$2) }
+cvtopbody :: { ((EpToken "{", EpToken "}"),[LHsDecl GhcPs]) }
+ : '{' cvtopdecls0 '}' { ((epTok $1 ,epTok $3),$2) }
+ | vocurly cvtopdecls0 close { ((NoEpTok, NoEpTok),$2) }
cvtopdecls0 :: { [LHsDecl GhcPs] }
: topdecls_semi { cvTopDecls $1 }
@@ -4641,6 +4640,10 @@ epUniTok t@(L !l _) = EpUniTok (EpaSpan l) u
where
u = if isUnicode t then UnicodeSyntax else NormalSyntax
+-- |Construct an EpToken from the location of the token, provided the span is not zero width
+mzEpTok :: Located Token -> EpToken tok
+mzEpTok !l = if isZeroWidthSpan (gl l) then NoEpTok else (epTok l)
+
epExplicitBraces :: Located Token -> Located Token -> EpLayout
epExplicitBraces !t1 !t2 = EpExplicitBraces (epTok t1) (epTok t2)
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -10,7 +10,7 @@ module GHC.Parser.Annotation (
-- * Core Exact Print Annotation types
AnnKeywordId(..),
EpToken(..), EpUniToken(..),
- getEpTokenSrcSpan, getEpTokenLocs,
+ getEpTokenSrcSpan, getEpTokenLocs, getEpTokenLoc,
TokDcolon,
EpLayout(..),
EpaComment(..), EpaCommentTok(..),
@@ -406,6 +406,10 @@ getEpTokenLocs ls = concatMap go ls
go NoEpTok = []
go (EpTok l) = [l]
+getEpTokenLoc :: EpToken tok -> EpaLocation
+getEpTokenLoc NoEpTok = noAnn
+getEpTokenLoc (EpTok l) = l
+
type TokDcolon = EpUniToken "::" "∷"
-- | Layout information for declarations.
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -71,7 +71,7 @@ module GHC.Parser.Lexer (
xtest, xunset, xset,
disableHaddock,
lexTokenStream,
- mkParensEpAnn,
+ mkParensEpToks,
mkParensLocs,
getCommentsFor, getPriorCommentsFor, getFinalCommentsFor,
getEofPos,
@@ -3628,13 +3628,14 @@ warn_unknown_prag prags span buf len buf2 = do
%************************************************************************
-}
+-- TODO:AZ: we should have only mkParensEpToks. Delee mkParensEpAnn, mkParensLocs
-- |Given a 'RealSrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate
-- 'AddEpAnn' values for the opening and closing bordering on the start
-- and end of the span
-mkParensEpAnn :: RealSrcSpan -> (AddEpAnn, AddEpAnn)
-mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan (RealSrcSpan lo Strict.Nothing)),
- AddEpAnn AnnCloseP (EpaSpan (RealSrcSpan lc Strict.Nothing)))
+mkParensEpToks :: RealSrcSpan -> (EpToken "(", EpToken ")")
+mkParensEpToks ss = (EpTok (EpaSpan (RealSrcSpan lo Strict.Nothing)),
+ EpTok (EpaSpan (RealSrcSpan lc Strict.Nothing)))
where
f = srcSpanFile ss
sl = srcSpanStartLine ss
@@ -3644,6 +3645,7 @@ mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan (RealSrcSpan lo Strict.Nothing)),
lo = mkRealSrcSpan (realSrcSpanStart ss) (mkRealSrcLoc f sl (sc+1))
lc = mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss)
+
-- |Given a 'RealSrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate
-- 'EpaLocation' values for the opening and closing bordering on the start
-- and end of the span
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -161,7 +161,7 @@ import GHC.Utils.Error
import GHC.Utils.Misc
import GHC.Utils.Monad (unlessM)
import Data.Either
-import Data.List ( findIndex, partition )
+import Data.List ( findIndex )
import Data.Foldable
import qualified Data.Semigroup as Semi
import GHC.Unit.Module.Warnings
@@ -204,14 +204,14 @@ mkClassDecl :: SrcSpan
-> Located (a,[LHsFunDep GhcPs])
-> OrdList (LHsDecl GhcPs)
-> EpLayout
- -> [AddEpAnn]
+ -> AnnClassDecl
-> P (LTyClDecl GhcPs)
mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layout annsIn
= do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls
- ; (cls, tparams, fixity, ann, cs) <- checkTyClHdr True tycl_hdr
+ ; (cls, tparams, fixity, ops, cps, cs) <- checkTyClHdr True tycl_hdr
; tyvars <- checkTyVars (text "class") whereDots cls tparams
- ; let anns' = annsIn Semi.<> ann
+ ; let anns' = annsIn { acd_openp = ops, acd_closep = cps}
; let loc = EpAnn (spanAsAnchor loc') noAnn cs
; return (L loc (ClassDecl { tcdCExt = (anns', layout, NoAnnSortKey)
, tcdCtxt = mcxt
@@ -235,9 +235,10 @@ mkTyData :: SrcSpan
-> P (LTyClDecl GhcPs)
mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr))
ksig data_cons (L _ maybe_deriv) annsIn
- = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False tycl_hdr
+ = do { (tc, tparams, fixity, ops, cps, cs) <- checkTyClHdr False tycl_hdr
; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams
- ; let anns' = annsIn Semi.<> ann
+ ; let anns' = annsIn Semi.<>
+ concatMap openParen2AddEpAnn ops Semi.<> concatMap closeParen2AddEpAnn cps
; data_cons <- checkNewOrData loc' (unLoc tc) is_type_data new_or_data data_cons
; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv
; !cs' <- getCommentsFor loc'
@@ -247,6 +248,15 @@ 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)
@@ -265,14 +275,15 @@ mkDataDefn cType mcxt ksig data_cons maybe_deriv
mkTySynonym :: SrcSpan
-> LHsType GhcPs -- LHS
-> LHsType GhcPs -- RHS
- -> [AddEpAnn]
+ -> EpToken "type"
+ -> EpToken "="
-> P (LTyClDecl GhcPs)
-mkTySynonym loc lhs rhs annsIn
- = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False lhs
+mkTySynonym loc lhs rhs antype aneq
+ = do { (tc, tparams, fixity, ops, cps, cs) <- checkTyClHdr False lhs
; tyvars <- checkTyVars (text "type") equalsDots tc tparams
- ; let anns' = annsIn Semi.<> ann
+ ; let anns = AnnSynDecl ops cps antype aneq
; let loc' = EpAnn (spanAsAnchor loc) noAnn cs
- ; return (L loc' (SynDecl { tcdSExt = anns'
+ ; return (L loc' (SynDecl { tcdSExt = anns
, tcdLName = tc, tcdTyVars = tyvars
, tcdFixity = fixity
, tcdRhs = rhs })) }
@@ -308,10 +319,12 @@ mkTyFamInstEqn :: SrcSpan
-> [AddEpAnn]
-> P (LTyFamInstEqn GhcPs)
mkTyFamInstEqn loc bndrs lhs rhs anns
- = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False lhs
+ = do { (tc, tparams, fixity, ops, cps, cs) <- checkTyClHdr False lhs
; let loc' = EpAnn (spanAsAnchor loc) noAnn cs
+ ; let anns' = anns Semi.<>
+ concatMap openParen2AddEpAnn ops Semi.<> concatMap closeParen2AddEpAnn cps
; return (L loc' $ FamEqn
- { feqn_ext = anns `mappend` ann
+ { feqn_ext = anns'
, feqn_tycon = tc
, feqn_bndrs = bndrs
, feqn_pats = tparams
@@ -330,32 +343,20 @@ mkDataFamInst :: SrcSpan
-> P (LInstDecl GhcPs)
mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
ksig data_cons (L _ maybe_deriv) anns
- = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False tycl_hdr
+ = do { (tc, tparams, fixity, ops, cps, cs) <- checkTyClHdr False tycl_hdr
; data_cons <- checkNewOrData loc (unLoc tc) False new_or_data data_cons
; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv
; let loc' = EpAnn (spanAsAnchor loc) noAnn cs
+ ; let anns' = anns Semi.<>
+ concatMap openParen2AddEpAnn ops Semi.<> concatMap closeParen2AddEpAnn cps
; return (L loc' (DataFamInstD noExtField (DataFamInstDecl
- (FamEqn { feqn_ext = ann Semi.<> anns
+ (FamEqn { feqn_ext = anns'
, feqn_tycon = tc
, feqn_bndrs = bndrs
, feqn_pats = tparams
, feqn_fixity = fixity
, feqn_rhs = defn })))) }
--- mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
--- ksig data_cons (L _ maybe_deriv) anns
--- = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
--- ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan
--- ; let anns' = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments
--- ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
--- ; return (L (noAnnSrcSpan loc) (DataFamInstD anns' (DataFamInstDecl
--- (FamEqn { feqn_ext = anns'
--- , feqn_tycon = tc
--- , feqn_bndrs = bndrs
--- , feqn_pats = tparams
--- , feqn_fixity = fixity
--- , feqn_rhs = defn })))) }
-
mkTyFamInst :: SrcSpan
@@ -375,11 +376,13 @@ mkFamDecl :: SrcSpan
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
mkFamDecl loc info topLevel lhs ksig injAnn annsIn
- = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False lhs
+ = 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
; return (L loc' (FamDecl noExtField (FamilyDecl
- { fdExt = annsIn Semi.<> ann
+ { fdExt = anns'
, fdTopLevel = topLevel
, fdInfo = info, fdLName = tc
, fdTyVars = tyvars
@@ -738,8 +741,7 @@ mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) =
do { unless (name == patsyn_name) $
wrongNameBindingErr (locA loc) decl
-- conAnn should only be AnnOpenP, AnnCloseP, so the rest should be empty
- ; let (ann_fun, rest) = mk_ann_funrhs []
- ; unless (null rest) $ return $ panic "mkPatSynMatchGroup: unexpected anns"
+ ; let ann_fun = mk_ann_funrhs [] []
; match <- case details of
PrefixCon _ pats -> return $ Match { m_ext = noExtField
, m_ctxt = ctxt, m_pats = L l pats
@@ -1063,8 +1065,8 @@ checkTyClHdr :: Bool -- True <=> class header
-> P (LocatedN RdrName, -- the head symbol (type or class name)
[LHsTypeArg GhcPs], -- parameters of head symbol
LexicalFixity, -- the declaration is in infix format
- [AddEpAnn], -- API Annotation for HsParTy
- -- when stripping parens
+ [EpToken "("], -- API Annotation for HsParTy
+ [EpToken ")"], -- when stripping parens
EpAnnComments) -- Accumulated comments from re-arranging
-- Well-formedness check and decomposition of type and class heads.
-- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn])
@@ -1081,22 +1083,22 @@ checkTyClHdr is_cls ty
; let name = mkOccNameFS tcClsName (starSym isUni)
; let a' = newAnns ll l an
; return (L a' (Unqual name), acc, fix
- , (reverse ops') ++ cps', cs) }
+ , (reverse ops'), cps', cs) }
go cs l (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix
- | isRdrTc tc = return (ltc, acc, fix, (reverse ops) ++ cps, cs Semi.<> comments l)
+ | isRdrTc tc = return (ltc, acc, fix, (reverse ops), cps, cs Semi.<> comments l)
go cs l (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix
- | isRdrTc tc = return (ltc, lhs:rhs:acc, Infix, (reverse ops) ++ cps, cs Semi.<> comments l)
+ | isRdrTc tc = return (ltc, lhs:rhs:acc, Infix, (reverse ops), cps, cs Semi.<> comments l)
where lhs = HsValArg noExtField t1
rhs = HsValArg noExtField t2
go cs l (HsParTy _ ty) acc ops cps fix = goL (cs Semi.<> comments l) ty acc (o:ops) (c:cps) fix
where
- (o,c) = mkParensEpAnn (realSrcSpan (locA l))
+ (o,c) = mkParensEpToks (realSrcSpan (locA l))
go cs l (HsAppTy _ t1 t2) acc ops cps fix = goL (cs Semi.<> comments l) t1 (HsValArg noExtField t2:acc) ops cps fix
go cs l (HsAppKindTy at ty ki) acc ops cps fix = goL (cs Semi.<> comments l) ty (HsTypeArg at ki:acc) ops cps fix
go cs l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix
= return (L (l2l l) (nameRdrName tup_name)
- , map (HsValArg noExtField) ts, fix, (reverse ops)++cps, cs Semi.<> comments l)
+ , map (HsValArg noExtField) ts, fix, (reverse ops), cps, cs Semi.<> comments l)
where
arity = length ts
tup_name | is_cls = cTupleTyConName arity
@@ -1170,15 +1172,16 @@ checkContext orig_t@(L (EpAnn l _ cs) _orig_t) =
-- With NoListTuplePuns, contexts are parsed as data constructors, which causes failure
-- downstream.
-- This converts them just like when they are parsed as types in the punned case.
- check (oparens,cparens,cs) (L _l (HsExplicitTupleTy anns ts))
+ check (oparens,cparens,cs) (L _l (HsExplicitTupleTy (q,o,c) ts))
= punsAllowed >>= \case
True -> unprocessed
False -> do
let
- (op, cp) = case anns of
- [o, c] -> ([o], [c])
- [q, _, c] -> ([q], [c])
- _ -> ([], [])
+ ol = AddEpAnn AnnOpenP (getEpTokenLoc o)
+ cl = AddEpAnn AnnCloseP (getEpTokenLoc c)
+ (op, cp) = case q of
+ EpTok ql -> ([AddEpAnn AnnSimpleQuote ql], [cl])
+ _ -> ([ol], [cl])
mkCTuple (oparens ++ (addLoc <$> op), (addLoc <$> cp) ++ cparens, cs) ts
check (opi,cpi,csi) (L _lp1 (HsParTy ann' ty))
-- to be sure HsParTy doesn't get into the way
@@ -1331,12 +1334,12 @@ checkAPat loc e0 = do
addError $ mkPlainErrorMsgEnvelope (getLocA op) PsErrAtInPatPos
return (WildPat noExtField)
- PatBuilderOpApp l (L cl c) r anns
+ PatBuilderOpApp l (L cl c) r (_os,_cs)
| isRdrDataCon c || isRdrTc c -> do
l <- checkLPat l
r <- checkLPat r
return $ ConPat
- { pat_con_ext = mk_ann_conpat anns
+ { pat_con_ext = noAnn
, pat_con = L cl c
, pat_args = InfixCon l r
}
@@ -1389,9 +1392,8 @@ checkValDef loc lhs (mult_ann, Nothing) grhss
| HsNoMultAnn{} <- mult_ann
= do { mb_fun <- isFunLhs lhs
; case mb_fun of
- Just (fun, is_infix, pats, ann) -> do
- let (ann_fun, ann_rest) = mk_ann_funrhs ann
- unless (null ann_rest) $ panic "checkValDef: unexpected anns"
+ Just (fun, is_infix, pats, ops, cps) -> do
+ let ann_fun = mk_ann_funrhs ops cps
let l = listLocation pats
checkFunBind loc ann_fun
fun is_infix (L l pats) grhss
@@ -1404,29 +1406,8 @@ checkValDef loc lhs (mult_ann, Nothing) ghrss
= do lhs' <- checkPattern lhs
checkPatBind loc lhs' ghrss mult_ann
-mk_ann_funrhs :: [AddEpAnn] -> (AnnFunRhs, [AddEpAnn])
-mk_ann_funrhs ann = (AnnFunRhs strict (map to_tok opens) (map to_tok closes), rest)
- where
- (opens, ra0) = partition (\(AddEpAnn kw _) -> kw == AnnOpenP) ann
- (closes, ra1) = partition (\(AddEpAnn kw _) -> kw == AnnCloseP) ra0
- (bangs, rest) = partition (\(AddEpAnn kw _) -> kw == AnnBang) ra1
- strict = case bangs of
- (AddEpAnn _ s:_) -> EpTok s
- _ -> NoEpTok
- to_tok (AddEpAnn _ s) = EpTok s
-
-mk_ann_conpat :: [AddEpAnn] -> (Maybe (EpToken "{"), Maybe (EpToken "}"))
-mk_ann_conpat ann = (open, close)
- where
- (opens, ra0) = partition (\(AddEpAnn kw _) -> kw == AnnOpenC) ann
- (closes, _ra1) = partition (\(AddEpAnn kw _) -> kw == AnnCloseC) ra0
- open = case opens of
- (o:_) -> Just (to_tok o)
- _ -> Nothing
- close = case closes of
- (o:_) -> Just (to_tok o)
- _ -> Nothing
- to_tok (AddEpAnn _ s) = EpTok s
+mk_ann_funrhs :: [EpToken "("] -> [EpToken ")"] -> AnnFunRhs
+mk_ann_funrhs ops cps = AnnFunRhs NoEpTok ops cps
checkFunBind :: SrcSpan
-> AnnFunRhs
@@ -1468,10 +1449,10 @@ checkPatBind :: SrcSpan
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> HsMultAnn GhcPs
-> P (HsBind GhcPs)
-checkPatBind loc (L _ (BangPat ans (L _ (VarPat _ v))))
+checkPatBind loc (L _ (BangPat an (L _ (VarPat _ v))))
(L _match_span grhss) (HsNoMultAnn _)
= return (makeFunBind v (L (noAnnSrcSpan loc)
- [L (noAnnSrcSpan loc) (m ans v)]))
+ [L (noAnnSrcSpan loc) (m an v)]))
where
m a v = Match { m_ext = noExtField
, m_ctxt = FunRhs { mc_fun = v
@@ -1517,7 +1498,7 @@ checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr
isFunLhs :: LocatedA (PatBuilder GhcPs)
-> P (Maybe (LocatedN RdrName, LexicalFixity,
- [LocatedA (ArgPatBuilder GhcPs)],[AddEpAnn]))
+ [LocatedA (ArgPatBuilder GhcPs)],[EpToken "("],[EpToken ")"]))
-- A variable binding is parsed as a FunBind.
-- Just (fun, is_infix, arg_pats) if e is a function LHS
isFunLhs e = go e [] [] []
@@ -1527,7 +1508,7 @@ isFunLhs e = go e [] [] []
go (L l (PatBuilderVar (L loc f))) es ops cps
| not (isRdrDataCon f) = do
let (_l, loc') = transferCommentsOnlyA l loc
- return (Just (L loc' f, Prefix, es, (reverse ops) ++ cps))
+ return (Just (L loc' f, Prefix, es, (reverse ops), cps))
go (L l (PatBuilderApp (L lf f) e)) es ops cps = do
let (_l, lf') = transferCommentsOnlyA l lf
go (L lf' f) (mk e:es) ops cps
@@ -1537,21 +1518,21 @@ isFunLhs e = go e [] [] []
-- of funlhs.
where
(_l, le') = transferCommentsOnlyA l le
- (o,c) = mkParensEpAnn (realSrcSpan $ locA l)
- go (L loc (PatBuilderOpApp (L ll l) (L loc' op) r anns)) es ops cps
+ (o,c) = mkParensEpToks (realSrcSpan $ locA l)
+ go (L loc (PatBuilderOpApp (L ll l) (L loc' op) r (os,cs))) es ops cps
| not (isRdrDataCon op) -- We have found the function!
= do { let (_l, ll') = transferCommentsOnlyA loc ll
- ; return (Just (L loc' op, Infix, (mk (L ll' l):mk r:es), (anns ++ reverse ops ++ cps))) }
+ ; return (Just (L loc' op, Infix, (mk (L ll' l):mk r:es), (os ++ reverse ops), (cs ++ cps))) }
| otherwise -- Infix data con; keep going
= do { let (_l, ll') = transferCommentsOnlyA loc ll
; mb_l <- go (L ll' l) es ops cps
; return (reassociate =<< mb_l) }
where
- reassociate (op', Infix, j : L k_loc (ArgPatBuilderVisPat k) : es', anns')
- = Just (op', Infix, j : op_app : es', anns')
+ reassociate (op', Infix, j : L k_loc (ArgPatBuilderVisPat k) : es', ops', cps')
+ = Just (op', Infix, j : op_app : es', ops', cps')
where
op_app = mk $ L loc (PatBuilderOpApp (L k_loc k)
- (L loc' op) r (reverse ops ++ cps))
+ (L loc' op) r (reverse ops, cps))
reassociate _other = Nothing
go (L l (PatBuilderAppType (L lp pat) tok ty_pat@(HsTP _ (L (EpAnn anc ann cs) _)))) es ops cps
= go (L lp' pat) (L (EpAnn anc' ann cs) (ArgPatBuilderArgPat invis_pat) : es) ops cps
@@ -1570,13 +1551,13 @@ instance Outputable (ArgPatBuilder GhcPs) where
ppr (ArgPatBuilderVisPat p) = ppr p
ppr (ArgPatBuilderArgPat p) = ppr p
-mkBangTy :: [AddEpAnn] -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs
-mkBangTy anns strictness =
- HsBangTy (anns, NoSourceText) (HsBang NoSrcUnpack strictness)
+mkBangTy :: EpaLocation -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs
+mkBangTy tok_loc strictness =
+ HsBangTy ((noAnn, noAnn, tok_loc), NoSourceText) (HsBang NoSrcUnpack strictness)
-- | Result of parsing @{-\# UNPACK \#-}@ or @{-\# NOUNPACK \#-}@.
data UnpackednessPragma =
- UnpackednessPragma [AddEpAnn] SourceText SrcUnpackedness
+ UnpackednessPragma (EpaLocation, EpaLocation) SourceText SrcUnpackedness
-- | Annotate a type with either an @{-\# UNPACK \#-}@ or a @{-\# NOUNPACK \#-}@ pragma.
addUnpackednessP :: MonadP m => Located UnpackednessPragma -> LHsType GhcPs -> m (LHsType GhcPs)
@@ -1589,11 +1570,11 @@ addUnpackednessP (L lprag (UnpackednessPragma anns prag unpk)) ty = do
-- such as ~T or !T, then add the pragma to the existing HsBangTy.
--
-- Otherwise, wrap the type in a new HsBangTy constructor.
- addUnpackedness an (L _ (HsBangTy (anns, NoSourceText) bang t))
+ addUnpackedness (o,c) (L _ (HsBangTy ((_,_,tl), NoSourceText) bang t))
| HsBang NoSrcUnpack strictness <- bang
- = HsBangTy (an Semi.<> anns, prag) (HsBang unpk strictness) t
- addUnpackedness an t
- = HsBangTy (an, prag) (HsBang unpk NoSrcStrict) t
+ = HsBangTy ((o,c,tl), prag) (HsBang unpk strictness) t
+ addUnpackedness (o,c) t
+ = HsBangTy ((o,c,noAnn), prag) (HsBang unpk NoSrcStrict) t
---------------------------------------------------------------------------
-- | Check for monad comprehensions
@@ -2051,7 +2032,7 @@ instance DisambECP (PatBuilder GhcPs) where
superInfixOp m = m
mkHsOpAppPV l p1 op p2 = do
!cs <- getCommentsFor l
- return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ PatBuilderOpApp p1 op p2 []
+ return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ PatBuilderOpApp p1 op p2 ([],[])
mkHsLamPV l lam_variant _ _ = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrLambdaInPat lam_variant)
@@ -3658,7 +3639,7 @@ mkTupleSyntaxTy parOpen args parClose =
HsExplicitTupleTy annsKeyword args
annParen = AnnParen AnnParens parOpen parClose
- annsKeyword = [AddEpAnn AnnOpenP parOpen, AddEpAnn AnnCloseP parClose]
+ annsKeyword = (NoEpTok, EpTok parOpen, EpTok parClose)
-- | Decide whether to parse tuple con syntax @(,)@ in a type as a
-- type or data constructor, based on the extension @ListTuplePuns at .
@@ -3690,7 +3671,7 @@ mkListSyntaxTy0 brkOpen brkClose span =
HsExplicitListTy annsKeyword NotPromoted []
rdrNameAnn = NameAnnOnly NameSquare brkOpen brkClose []
- annsKeyword = [AddEpAnn AnnOpenS brkOpen, AddEpAnn AnnCloseS brkClose]
+ annsKeyword = (NoEpTok, EpTok brkOpen, EpTok brkClose)
fullLoc = EpaSpan span
-- | Decide whether to parse list type syntax @[Int]@ in a type as a
@@ -3709,5 +3690,5 @@ mkListSyntaxTy1 brkOpen t brkClose =
disabled =
HsExplicitListTy annsKeyword NotPromoted [t]
- annsKeyword = [AddEpAnn AnnOpenS brkOpen, AddEpAnn AnnCloseS brkClose]
+ annsKeyword = (NoEpTok, EpTok brkOpen, EpTok brkClose)
annParen = AnnParen AnnParensSquare brkOpen brkClose
=====================================
compiler/GHC/Parser/PostProcess/Haddock.hs
=====================================
@@ -1460,7 +1460,7 @@ instance Monoid ColumnBound where
mkLHsDocTy :: LHsType GhcPs -> Maybe (Located HsDocString) -> LHsType GhcPs
mkLHsDocTy t Nothing = t
-mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noAnn t $ lexLHsDocString doc)
+mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noExtField t $ lexLHsDocString doc)
getForAllTeleLoc :: HsForAllTelescope GhcPs -> SrcSpan
getForAllTeleLoc tele =
=====================================
compiler/GHC/Parser/Types.hs
=====================================
@@ -57,7 +57,7 @@ data PatBuilder p
| PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p))
| PatBuilderAppType (LocatedA (PatBuilder p)) (EpToken "@") (HsTyPat GhcPs)
| PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedN RdrName)
- (LocatedA (PatBuilder p)) [AddEpAnn]
+ (LocatedA (PatBuilder p)) ([EpToken "("], [EpToken ")"])
| PatBuilderVar (LocatedN RdrName)
| PatBuilderOverLit (HsOverLit GhcPs)
=====================================
compiler/GHC/Rename/Splice.hs
=====================================
@@ -181,7 +181,7 @@ rnUntypedBracket e br_body
}
rn_utbracket :: ThStage -> HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeVars)
-rn_utbracket outer_stage br@(VarBr x flg rdr_name)
+rn_utbracket outer_stage br@(VarBr _ flg rdr_name)
= do { name <- lookupOccRn (unLoc rdr_name)
; check_namespace flg name
; this_mod <- getModule
@@ -204,18 +204,18 @@ rn_utbracket outer_stage br@(VarBr x flg rdr_name)
TcRnTHError $ THNameError $ QuotedNameWrongStage br }
}
}
- ; return (VarBr x flg (noLocA name), unitFV name) }
+ ; return (VarBr noExtField flg (noLocA name), unitFV name) }
-rn_utbracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e
- ; return (ExpBr x e', fvs) }
+rn_utbracket _ (ExpBr _ e) = do { (e', fvs) <- rnLExpr e
+ ; return (ExpBr noExtField e', fvs) }
-rn_utbracket _ (PatBr x p)
- = rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs)
+rn_utbracket _ (PatBr _ p)
+ = rnPat ThPatQuote p $ \ p' -> return (PatBr noExtField p', emptyFVs)
-rn_utbracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t
- ; return (TypBr x t', fvs) }
+rn_utbracket _ (TypBr _ t) = do { (t', fvs) <- rnLHsType TypBrCtx t
+ ; return (TypBr noExtField t', fvs) }
-rn_utbracket _ (DecBrL x decls)
+rn_utbracket _ (DecBrL _ decls)
= do { group <- groupDecls decls
; gbl_env <- getGblEnv
; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
@@ -227,7 +227,7 @@ rn_utbracket _ (DecBrL x decls)
-- Discard the tcg_env; it contains only extra info about fixity
; traceRn "rn_utbracket dec" (ppr (tcg_dus tcg_env) $$
ppr (duUses (tcg_dus tcg_env)))
- ; return (DecBrG x group', duUses (tcg_dus tcg_env)) }
+ ; return (DecBrG noExtField group', duUses (tcg_dus tcg_env)) }
where
groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)
groupDecls decls
=====================================
compiler/GHC/Tc/Deriv/Generate.hs
=====================================
@@ -1655,7 +1655,7 @@ gen_Lift_binds loc (DerivInstTys{ dit_rep_tc = tycon
liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp unsafeCodeCoerce_Expr . nlHsApp pure_Expr)
(map (pats_etc mk_typed_bracket mk_tsplice liftTypedName) data_cons)
- mk_untyped_bracket = HsUntypedBracket noAnn . ExpBr noExtField
+ mk_untyped_bracket = HsUntypedBracket noExtField . ExpBr noAnn
mk_typed_bracket = HsTypedBracket noAnn
mk_tsplice = HsTypedSplice noAnn
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -319,7 +319,7 @@ cvtDec (ClassD ctxt cl tvs fds decs)
, tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
, tcdMeths = binds'
, tcdATs = fams', tcdATDefs = at_defs', tcdDocs = [] }
- -- no docs in TH ^^
+ -- no docs in TH ^^
}
cvtDec (InstanceD o ctxt ty decs)
=====================================
libraries/base/src/Control/Category.hs
=====================================
@@ -11,9 +11,26 @@
--
module Control.Category
- ( Category(..)
+ ( -- * Class
+ Category(..)
+
+ -- * Combinators
, (<<<)
, (>>>)
+
+ -- $namingConflicts
) where
import GHC.Internal.Control.Category
+
+-- $namingConflicts
+--
+-- == A note on naming conflicts
+--
+-- The methods from 'Category' conflict with 'Prelude.id' and 'Prelude..' from the
+-- prelude; you will likely want to either import this module qualified, or hide the
+-- prelude functions:
+--
+-- @
+-- import "Prelude" hiding (id, (.))
+-- @
=====================================
libraries/ghc-internal/src/GHC/Internal/Control/Category.hs
=====================================
@@ -28,17 +28,81 @@ import GHC.Internal.Data.Coerce (coerce)
infixr 9 .
infixr 1 >>>, <<<
--- | A class for categories. Instances should satisfy the laws
+-- | A class for categories.
--
--- [Right identity] @f '.' 'id' = f@
--- [Left identity] @'id' '.' f = f@
--- [Associativity] @f '.' (g '.' h) = (f '.' g) '.' h@
+-- In mathematics, a /category/ is defined as a collection of /objects/ and a collection
+-- of /morphisms/ between objects, together with an /identity morphism/ 'id' for every
+-- object and an operation '(.)' that /composes/ compatible morphisms.
+--
+-- This class is defined in an analogous way. The collection of morphisms is represented
+-- by a type parameter @cat@, which has kind @k -> k -> 'Data.Kind.Type'@ for some kind variable @k@
+-- that represents the collection of objects; most of the time the choice of @k@ will be
+-- 'Data.Kind.Type'.
+--
+-- ==== __Examples__
+--
+-- As the method names suggest, there's a category of functions:
+--
+-- @
+-- instance Category '(->)' where
+-- id = \\x -> x
+-- f . g = \\x -> f (g x)
+-- @
+--
+-- Isomorphisms form a category as well:
+--
+-- @
+-- data Iso a b = Iso (a -> b) (b -> a)
+--
+-- instance Category Iso where
+-- id = Iso id id
+-- Iso f1 g1 . Iso f2 g2 = Iso (f1 . f2) (g2 . g1)
+-- @
+--
+-- Natural transformations are another important example:
+--
+-- @
+-- newtype f ~> g = NatTransform (forall x. f x -> g x)
+--
+-- instance Category (~>) where
+-- id = NatTransform id
+-- NatTransform f . NatTransform g = NatTransform (f . g)
+-- @
+--
+-- Using the `TypeData` language extension, we can also make a category where `k` isn't
+-- `Type`, but a custom kind `Door` instead:
+--
+-- @
+-- type data Door = DoorOpen | DoorClosed
+--
+-- data Action (before :: Door) (after :: Door) where
+-- DoNothing :: Action door door
+-- OpenDoor :: Action start DoorClosed -> Action start DoorOpen
+-- CloseDoor :: Action start DoorOpen -> Action start DoorClosed
+--
+-- instance Category Action where
+-- id = DoNothing
+--
+-- DoNothing . action = action
+-- OpenDoor rest . action = OpenDoor (rest . action)
+-- CloseDoor rest . action = CloseDoor (rest . action)
+-- @
--
class Category cat where
- -- | the identity morphism
+ -- | The identity morphism. Implementations should satisfy two laws:
+ --
+ -- [Right identity] @f '.' 'id' = f@
+ -- [Left identity] @'id' '.' f = f@
+ --
+ -- These essentially state that 'id' should "do nothing".
id :: cat a a
- -- | morphism composition
+ -- | Morphism composition. Implementations should satisfy the law:
+ --
+ -- [Associativity] @f '.' (g '.' h) = (f '.' g) '.' h@
+ --
+ -- This means that the way morphisms are grouped is irrelevant, so it is unambiguous
+ -- to write a composition of morphisms as @f '.' g '.' h@, without parentheses.
(.) :: cat b c -> cat a b -> cat a c
{-# RULES
@@ -70,11 +134,13 @@ instance Category Coercion where
id = Coercion
(.) Coercion = coerce
--- | Right-to-left composition
+-- | Right-to-left composition. This is a synonym for '(.)', but it can be useful to make
+-- the order of composition more apparent.
(<<<) :: Category cat => cat b c -> cat a b -> cat a c
(<<<) = (.)
--- | Left-to-right composition
+-- | Left-to-right composition. This is useful if you want to write a morphism as a
+-- pipeline going from left to right.
(>>>) :: Category cat => cat a b -> cat b c -> cat a c
f >>> g = g . f
{-# INLINE (>>>) #-} -- see Note [INLINE on >>>]
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
=====================================
@@ -48,8 +48,17 @@
(NoExtField)
(ClassDecl
((,,)
- [(AddEpAnn AnnClass (EpaSpan { T17544.hs:5:1-5 }))
- ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:5:12-16 }))]
+ (AnnClassDecl
+ (EpTok
+ (EpaSpan { T17544.hs:5:1-5 }))
+ []
+ []
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { T17544.hs:5:12-16 }))
+ (NoEpTok)
+ (NoEpTok)
+ [])
(EpVirtualBraces
(3))
(NoAnnSortKey))
@@ -170,7 +179,7 @@
(EpaComments
[]))
(HsDocTy
- []
+ (NoExtField)
(L
(EpAnn
(EpaSpan { T17544.hs:6:14-16 })
@@ -217,8 +226,17 @@
(NoExtField)
(ClassDecl
((,,)
- [(AddEpAnn AnnClass (EpaSpan { T17544.hs:9:1-5 }))
- ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:9:12-16 }))]
+ (AnnClassDecl
+ (EpTok
+ (EpaSpan { T17544.hs:9:1-5 }))
+ []
+ []
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { T17544.hs:9:12-16 }))
+ (NoEpTok)
+ (NoEpTok)
+ [])
(EpVirtualBraces
(3))
(NoAnnSortKey))
@@ -384,8 +402,17 @@
(NoExtField)
(ClassDecl
((,,)
- [(AddEpAnn AnnClass (EpaSpan { T17544.hs:13:1-5 }))
- ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:13:12-16 }))]
+ (AnnClassDecl
+ (EpTok
+ (EpaSpan { T17544.hs:13:1-5 }))
+ []
+ []
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { T17544.hs:13:12-16 }))
+ (NoEpTok)
+ (NoEpTok)
+ [])
(EpVirtualBraces
(3))
(NoAnnSortKey))
@@ -554,8 +581,17 @@
(NoExtField)
(ClassDecl
((,,)
- [(AddEpAnn AnnClass (EpaSpan { T17544.hs:17:1-5 }))
- ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:17:12-16 }))]
+ (AnnClassDecl
+ (EpTok
+ (EpaSpan { T17544.hs:17:1-5 }))
+ []
+ []
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { T17544.hs:17:12-16 }))
+ (NoEpTok)
+ (NoEpTok)
+ [])
(EpVirtualBraces
(3))
(NoAnnSortKey))
@@ -788,10 +824,17 @@
(NoExtField)
(ClassDecl
((,,)
- [(AddEpAnn AnnClass (EpaSpan { T17544.hs:22:1-5 }))
- ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:22:12-16 }))
- ,(AddEpAnn AnnOpenC (EpaSpan { T17544.hs:22:18 }))
- ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:22:30 }))]
+ (AnnClassDecl
+ (EpTok
+ (EpaSpan { T17544.hs:22:1-5 }))
+ []
+ []
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { T17544.hs:22:12-16 }))
+ (EpTok (EpaSpan { T17544.hs:22:18 }))
+ (EpTok (EpaSpan { T17544.hs:22:30 }))
+ [])
(EpExplicitBraces
(EpTok (EpaSpan { T17544.hs:22:18 }))
(EpTok (EpaSpan { T17544.hs:22:30 })))
@@ -1129,10 +1172,17 @@
(NoExtField)
(ClassDecl
((,,)
- [(AddEpAnn AnnClass (EpaSpan { T17544.hs:28:1-5 }))
- ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:28:12-16 }))
- ,(AddEpAnn AnnOpenC (EpaSpan { T17544.hs:28:18 }))
- ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:28:30 }))]
+ (AnnClassDecl
+ (EpTok
+ (EpaSpan { T17544.hs:28:1-5 }))
+ []
+ []
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { T17544.hs:28:12-16 }))
+ (EpTok (EpaSpan { T17544.hs:28:18 }))
+ (EpTok (EpaSpan { T17544.hs:28:30 }))
+ [])
(EpExplicitBraces
(EpTok (EpaSpan { T17544.hs:28:18 }))
(EpTok (EpaSpan { T17544.hs:28:30 })))
@@ -1470,10 +1520,17 @@
(NoExtField)
(ClassDecl
((,,)
- [(AddEpAnn AnnClass (EpaSpan { T17544.hs:34:1-5 }))
- ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:34:12-16 }))
- ,(AddEpAnn AnnOpenC (EpaSpan { T17544.hs:34:18 }))
- ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:34:30 }))]
+ (AnnClassDecl
+ (EpTok
+ (EpaSpan { T17544.hs:34:1-5 }))
+ []
+ []
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { T17544.hs:34:12-16 }))
+ (EpTok (EpaSpan { T17544.hs:34:18 }))
+ (EpTok (EpaSpan { T17544.hs:34:30 }))
+ [])
(EpExplicitBraces
(EpTok (EpaSpan { T17544.hs:34:18 }))
(EpTok (EpaSpan { T17544.hs:34:30 })))
@@ -1811,10 +1868,17 @@
(NoExtField)
(ClassDecl
((,,)
- [(AddEpAnn AnnClass (EpaSpan { T17544.hs:40:1-5 }))
- ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:40:12-16 }))
- ,(AddEpAnn AnnOpenC (EpaSpan { T17544.hs:40:18 }))
- ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:40:30 }))]
+ (AnnClassDecl
+ (EpTok
+ (EpaSpan { T17544.hs:40:1-5 }))
+ []
+ []
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { T17544.hs:40:12-16 }))
+ (EpTok (EpaSpan { T17544.hs:40:18 }))
+ (EpTok (EpaSpan { T17544.hs:40:30 }))
+ [])
(EpExplicitBraces
(EpTok (EpaSpan { T17544.hs:40:18 }))
(EpTok (EpaSpan { T17544.hs:40:30 })))
@@ -2152,10 +2216,17 @@
(NoExtField)
(ClassDecl
((,,)
- [(AddEpAnn AnnClass (EpaSpan { T17544.hs:46:1-5 }))
- ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:46:12-16 }))
- ,(AddEpAnn AnnOpenC (EpaSpan { T17544.hs:46:18 }))
- ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:46:30 }))]
+ (AnnClassDecl
+ (EpTok
+ (EpaSpan { T17544.hs:46:1-5 }))
+ []
+ []
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { T17544.hs:46:12-16 }))
+ (EpTok (EpaSpan { T17544.hs:46:18 }))
+ (EpTok (EpaSpan { T17544.hs:46:30 }))
+ [])
(EpExplicitBraces
(EpTok (EpaSpan { T17544.hs:46:18 }))
(EpTok (EpaSpan { T17544.hs:46:30 })))
@@ -2493,10 +2564,17 @@
(NoExtField)
(ClassDecl
((,,)
- [(AddEpAnn AnnClass (EpaSpan { T17544.hs:52:1-5 }))
- ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:52:13-17 }))
- ,(AddEpAnn AnnOpenC (EpaSpan { T17544.hs:52:19 }))
- ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:52:32 }))]
+ (AnnClassDecl
+ (EpTok
+ (EpaSpan { T17544.hs:52:1-5 }))
+ []
+ []
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { T17544.hs:52:13-17 }))
+ (EpTok (EpaSpan { T17544.hs:52:19 }))
+ (EpTok (EpaSpan { T17544.hs:52:32 }))
+ [])
(EpExplicitBraces
(EpTok (EpaSpan { T17544.hs:52:19 }))
(EpTok (EpaSpan { T17544.hs:52:32 })))
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
=====================================
@@ -281,8 +281,17 @@
(NoExtField)
(ClassDecl
((,,)
- [(AddEpAnn AnnClass (EpaSpan { T17544_kw.hs:21:1-5 }))
- ,(AddEpAnn AnnWhere (EpaSpan { T17544_kw.hs:23:3-7 }))]
+ (AnnClassDecl
+ (EpTok
+ (EpaSpan { T17544_kw.hs:21:1-5 }))
+ []
+ []
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { T17544_kw.hs:23:3-7 }))
+ (NoEpTok)
+ (NoEpTok)
+ [])
(EpVirtualBraces
(5))
(NoAnnSortKey))
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr
=====================================
@@ -458,7 +458,7 @@
(EpaComments
[]))
(HsDocTy
- []
+ (NoExtField)
(L
(EpAnn
(EpaSpan { T24221.hs:15:3-5 })
@@ -503,7 +503,7 @@
(EpaComments
[]))
(HsDocTy
- []
+ (NoExtField)
(L
(EpAnn
(EpaSpan { T24221.hs:17:3-6 })
@@ -616,7 +616,7 @@
(EpaComments
[]))
(HsDocTy
- []
+ (NoExtField)
(L
(EpAnn
(EpaSpan { T24221.hs:21:3-5 })
@@ -661,7 +661,7 @@
(EpaComments
[]))
(HsDocTy
- []
+ (NoExtField)
(L
(EpAnn
(EpaSpan { T24221.hs:25:3-6 })
=====================================
testsuite/tests/parser/should_compile/DumpParsedAst.stderr
=====================================
@@ -501,9 +501,13 @@
(EpaComments
[]))
(HsExplicitListTy
- [(AddEpAnn AnnSimpleQuote (EpaSpan { DumpParsedAst.hs:12:10 }))
- ,(AddEpAnn AnnOpenS (EpaSpan { DumpParsedAst.hs:12:11 }))
- ,(AddEpAnn AnnCloseS (EpaSpan { DumpParsedAst.hs:12:12 }))]
+ ((,,)
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:12:10 }))
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:12:11 }))
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:12:12 })))
(IsPromoted)
[])))]
(Prefix)
=====================================
testsuite/tests/parser/should_compile/DumpSemis.stderr
=====================================
@@ -1302,8 +1302,17 @@
(NoExtField)
(ClassDecl
((,,)
- [(AddEpAnn AnnClass (EpaSpan { DumpSemis.hs:28:1-5 }))
- ,(AddEpAnn AnnWhere (EpaSpan { DumpSemis.hs:28:40-44 }))]
+ (AnnClassDecl
+ (EpTok
+ (EpaSpan { DumpSemis.hs:28:1-5 }))
+ []
+ []
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { DumpSemis.hs:28:40-44 }))
+ (NoEpTok)
+ (NoEpTok)
+ [])
(EpVirtualBraces
(3))
(NoAnnSortKey))
=====================================
testsuite/tests/parser/should_compile/KindSigs.stderr
=====================================
@@ -240,8 +240,13 @@
(TyClD
(NoExtField)
(SynDecl
- [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:15:1-4 }))
- ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:15:12 }))]
+ (AnnSynDecl
+ []
+ []
+ (EpTok
+ (EpaSpan { KindSigs.hs:15:1-4 }))
+ (EpTok
+ (EpaSpan { KindSigs.hs:15:12 })))
(L
(EpAnn
(EpaSpan { KindSigs.hs:15:6-8 })
@@ -452,8 +457,13 @@
(TyClD
(NoExtField)
(SynDecl
- [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:16:1-4 }))
- ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:16:13 }))]
+ (AnnSynDecl
+ []
+ []
+ (EpTok
+ (EpaSpan { KindSigs.hs:16:1-4 }))
+ (EpTok
+ (EpaSpan { KindSigs.hs:16:13 })))
(L
(EpAnn
(EpaSpan { KindSigs.hs:16:6-9 })
@@ -664,8 +674,13 @@
(TyClD
(NoExtField)
(SynDecl
- [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:19:1-4 }))
- ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:19:10 }))]
+ (AnnSynDecl
+ []
+ []
+ (EpTok
+ (EpaSpan { KindSigs.hs:19:1-4 }))
+ (EpTok
+ (EpaSpan { KindSigs.hs:19:10 })))
(L
(EpAnn
(EpaSpan { KindSigs.hs:19:6-8 })
@@ -1069,8 +1084,13 @@
(TyClD
(NoExtField)
(SynDecl
- [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:26:1-4 }))
- ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:26:11 }))]
+ (AnnSynDecl
+ []
+ []
+ (EpTok
+ (EpaSpan { KindSigs.hs:26:1-4 }))
+ (EpTok
+ (EpaSpan { KindSigs.hs:26:11 })))
(L
(EpAnn
(EpaSpan { KindSigs.hs:26:6-9 })
@@ -1092,9 +1112,13 @@
(EpaComments
[]))
(HsExplicitListTy
- [(AddEpAnn AnnSimpleQuote (EpaSpan { KindSigs.hs:26:13 }))
- ,(AddEpAnn AnnOpenS (EpaSpan { KindSigs.hs:26:14 }))
- ,(AddEpAnn AnnCloseS (EpaSpan { KindSigs.hs:26:29 }))]
+ ((,,)
+ (EpTok
+ (EpaSpan { KindSigs.hs:26:13 }))
+ (EpTok
+ (EpaSpan { KindSigs.hs:26:14 }))
+ (EpTok
+ (EpaSpan { KindSigs.hs:26:29 })))
(IsPromoted)
[(L
(EpAnn
@@ -1155,8 +1179,13 @@
(TyClD
(NoExtField)
(SynDecl
- [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:27:1-4 }))
- ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:27:12 }))]
+ (AnnSynDecl
+ []
+ []
+ (EpTok
+ (EpaSpan { KindSigs.hs:27:1-4 }))
+ (EpTok
+ (EpaSpan { KindSigs.hs:27:12 })))
(L
(EpAnn
(EpaSpan { KindSigs.hs:27:6-10 })
@@ -1178,8 +1207,12 @@
(EpaComments
[]))
(HsExplicitListTy
- [(AddEpAnn AnnOpenS (EpaSpan { KindSigs.hs:27:14 }))
- ,(AddEpAnn AnnCloseS (EpaSpan { KindSigs.hs:27:45 }))]
+ ((,,)
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { KindSigs.hs:27:14 }))
+ (EpTok
+ (EpaSpan { KindSigs.hs:27:45 })))
(NotPromoted)
[(L
(EpAnn
@@ -1290,8 +1323,13 @@
(TyClD
(NoExtField)
(SynDecl
- [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:28:1-4 }))
- ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:28:14 }))]
+ (AnnSynDecl
+ []
+ []
+ (EpTok
+ (EpaSpan { KindSigs.hs:28:1-4 }))
+ (EpTok
+ (EpaSpan { KindSigs.hs:28:14 })))
(L
(EpAnn
(EpaSpan { KindSigs.hs:28:6-10 })
@@ -1340,9 +1378,13 @@
(EpaComments
[]))
(HsExplicitTupleTy
- [(AddEpAnn AnnSimpleQuote (EpaSpan { KindSigs.hs:28:16 }))
- ,(AddEpAnn AnnOpenP (EpaSpan { KindSigs.hs:28:17 }))
- ,(AddEpAnn AnnCloseP (EpaSpan { KindSigs.hs:28:44 }))]
+ ((,,)
+ (EpTok
+ (EpaSpan { KindSigs.hs:28:16 }))
+ (EpTok
+ (EpaSpan { KindSigs.hs:28:17 }))
+ (EpTok
+ (EpaSpan { KindSigs.hs:28:44 })))
[(L
(EpAnn
(EpaSpan { KindSigs.hs:28:19-39 })
@@ -1363,8 +1405,12 @@
(EpaComments
[]))
(HsExplicitListTy
- [(AddEpAnn AnnOpenS (EpaSpan { KindSigs.hs:28:19 }))
- ,(AddEpAnn AnnCloseS (EpaSpan { KindSigs.hs:28:29 }))]
+ ((,,)
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { KindSigs.hs:28:19 }))
+ (EpTok
+ (EpaSpan { KindSigs.hs:28:29 })))
(NotPromoted)
[(L
(EpAnn
@@ -1465,8 +1511,13 @@
(TyClD
(NoExtField)
(SynDecl
- [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:31:1-4 }))
- ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:31:19 }))]
+ (AnnSynDecl
+ []
+ []
+ (EpTok
+ (EpaSpan { KindSigs.hs:31:1-4 }))
+ (EpTok
+ (EpaSpan { KindSigs.hs:31:19 })))
(L
(EpAnn
(EpaSpan { KindSigs.hs:31:6-17 })
=====================================
testsuite/tests/parser/should_compile/T20452.stderr
=====================================
@@ -262,10 +262,17 @@
(NoExtField)
(ClassDecl
((,,)
- [(AddEpAnn AnnClass (EpaSpan { T20452.hs:8:1-5 }))
- ,(AddEpAnn AnnWhere (EpaSpan { T20452.hs:8:78-82 }))
- ,(AddEpAnn AnnOpenC (EpaSpan { T20452.hs:8:84 }))
- ,(AddEpAnn AnnCloseC (EpaSpan { T20452.hs:8:85 }))]
+ (AnnClassDecl
+ (EpTok
+ (EpaSpan { T20452.hs:8:1-5 }))
+ []
+ []
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { T20452.hs:8:78-82 }))
+ (EpTok (EpaSpan { T20452.hs:8:84 }))
+ (EpTok (EpaSpan { T20452.hs:8:85 }))
+ [])
(EpExplicitBraces
(EpTok (EpaSpan { T20452.hs:8:84 }))
(EpTok (EpaSpan { T20452.hs:8:85 })))
@@ -492,10 +499,17 @@
(NoExtField)
(ClassDecl
((,,)
- [(AddEpAnn AnnClass (EpaSpan { T20452.hs:9:1-5 }))
- ,(AddEpAnn AnnWhere (EpaSpan { T20452.hs:9:78-82 }))
- ,(AddEpAnn AnnOpenC (EpaSpan { T20452.hs:9:84 }))
- ,(AddEpAnn AnnCloseC (EpaSpan { T20452.hs:9:85 }))]
+ (AnnClassDecl
+ (EpTok
+ (EpaSpan { T20452.hs:9:1-5 }))
+ []
+ []
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { T20452.hs:9:78-82 }))
+ (EpTok (EpaSpan { T20452.hs:9:84 }))
+ (EpTok (EpaSpan { T20452.hs:9:85 }))
+ [])
(EpExplicitBraces
(EpTok (EpaSpan { T20452.hs:9:84 }))
(EpTok (EpaSpan { T20452.hs:9:85 })))
=====================================
testsuite/tests/printer/AnnotationNoListTuplePuns.stdout
=====================================
@@ -72,8 +72,13 @@
(TyClD
(NoExtField)
(SynDecl
- [(AddEpAnn AnnType (EpaSpan { AnnotationNoListTuplePuns.hs:5:1-4 }))
- ,(AddEpAnn AnnEqual (EpaSpan { AnnotationNoListTuplePuns.hs:5:8 }))]
+ (AnnSynDecl
+ []
+ []
+ (EpTok
+ (EpaSpan { AnnotationNoListTuplePuns.hs:5:1-4 }))
+ (EpTok
+ (EpaSpan { AnnotationNoListTuplePuns.hs:5:8 })))
(L
(EpAnn
(EpaSpan { AnnotationNoListTuplePuns.hs:5:6 })
@@ -101,8 +106,12 @@
"-- comment inside A")
{ AnnotationNoListTuplePuns.hs:7:3 }))]))
(HsExplicitListTy
- [(AddEpAnn AnnOpenS (EpaSpan { AnnotationNoListTuplePuns.hs:7:3 }))
- ,(AddEpAnn AnnCloseS (EpaSpan { AnnotationNoListTuplePuns.hs:9:3 }))]
+ ((,,)
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { AnnotationNoListTuplePuns.hs:7:3 }))
+ (EpTok
+ (EpaSpan { AnnotationNoListTuplePuns.hs:9:3 })))
(NotPromoted)
[])))))
,(L
@@ -128,8 +137,13 @@
(TyClD
(NoExtField)
(SynDecl
- [(AddEpAnn AnnType (EpaSpan { AnnotationNoListTuplePuns.hs:12:1-4 }))
- ,(AddEpAnn AnnEqual (EpaSpan { AnnotationNoListTuplePuns.hs:12:8 }))]
+ (AnnSynDecl
+ []
+ []
+ (EpTok
+ (EpaSpan { AnnotationNoListTuplePuns.hs:12:1-4 }))
+ (EpTok
+ (EpaSpan { AnnotationNoListTuplePuns.hs:12:8 })))
(L
(EpAnn
(EpaSpan { AnnotationNoListTuplePuns.hs:12:6 })
@@ -157,8 +171,12 @@
"-- comment inside B")
{ AnnotationNoListTuplePuns.hs:14:3 }))]))
(HsExplicitListTy
- [(AddEpAnn AnnOpenS (EpaSpan { AnnotationNoListTuplePuns.hs:14:3 }))
- ,(AddEpAnn AnnCloseS (EpaSpan { AnnotationNoListTuplePuns.hs:17:3 }))]
+ ((,,)
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { AnnotationNoListTuplePuns.hs:14:3 }))
+ (EpTok
+ (EpaSpan { AnnotationNoListTuplePuns.hs:17:3 })))
(NotPromoted)
[(L
(EpAnn
@@ -243,8 +261,13 @@
(TyClD
(NoExtField)
(SynDecl
- [(AddEpAnn AnnType (EpaSpan { AnnotationNoListTuplePuns.ppr.hs:4:1-4 }))
- ,(AddEpAnn AnnEqual (EpaSpan { AnnotationNoListTuplePuns.ppr.hs:4:8 }))]
+ (AnnSynDecl
+ []
+ []
+ (EpTok
+ (EpaSpan { AnnotationNoListTuplePuns.ppr.hs:4:1-4 }))
+ (EpTok
+ (EpaSpan { AnnotationNoListTuplePuns.ppr.hs:4:8 })))
(L
(EpAnn
(EpaSpan { AnnotationNoListTuplePuns.ppr.hs:4:6 })
@@ -266,8 +289,12 @@
(EpaComments
[]))
(HsExplicitListTy
- [(AddEpAnn AnnOpenS (EpaSpan { AnnotationNoListTuplePuns.ppr.hs:4:10 }))
- ,(AddEpAnn AnnCloseS (EpaSpan { AnnotationNoListTuplePuns.ppr.hs:4:11 }))]
+ ((,,)
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { AnnotationNoListTuplePuns.ppr.hs:4:10 }))
+ (EpTok
+ (EpaSpan { AnnotationNoListTuplePuns.ppr.hs:4:11 })))
(NotPromoted)
[])))))
,(L
@@ -280,8 +307,13 @@
(TyClD
(NoExtField)
(SynDecl
- [(AddEpAnn AnnType (EpaSpan { AnnotationNoListTuplePuns.ppr.hs:5:1-4 }))
- ,(AddEpAnn AnnEqual (EpaSpan { AnnotationNoListTuplePuns.ppr.hs:5:8 }))]
+ (AnnSynDecl
+ []
+ []
+ (EpTok
+ (EpaSpan { AnnotationNoListTuplePuns.ppr.hs:5:1-4 }))
+ (EpTok
+ (EpaSpan { AnnotationNoListTuplePuns.ppr.hs:5:8 })))
(L
(EpAnn
(EpaSpan { AnnotationNoListTuplePuns.ppr.hs:5:6 })
@@ -303,8 +335,12 @@
(EpaComments
[]))
(HsExplicitListTy
- [(AddEpAnn AnnOpenS (EpaSpan { AnnotationNoListTuplePuns.ppr.hs:5:10 }))
- ,(AddEpAnn AnnCloseS (EpaSpan { AnnotationNoListTuplePuns.ppr.hs:5:15 }))]
+ ((,,)
+ (NoEpTok)
+ (EpTok
+ (EpaSpan { AnnotationNoListTuplePuns.ppr.hs:5:10 }))
+ (EpTok
+ (EpaSpan { AnnotationNoListTuplePuns.ppr.hs:5:15 })))
(NotPromoted)
[(L
(EpAnn
=====================================
testsuite/tests/printer/Test24533.stdout
=====================================
@@ -308,7 +308,16 @@
(NoExtField)
(ClassDecl
((,,)
- [(AddEpAnn AnnClass (EpaSpan { Test24533.hs:11:1-5 }))]
+ (AnnClassDecl
+ (EpTok
+ (EpaSpan { Test24533.hs:11:1-5 }))
+ []
+ []
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ [])
(EpNoLayout)
(NoAnnSortKey))
(Nothing)
@@ -933,7 +942,16 @@
(NoExtField)
(ClassDecl
((,,)
- [(AddEpAnn AnnClass (EpaSpan { Test24533.ppr.hs:4:1-5 }))]
+ (AnnClassDecl
+ (EpTok
+ (EpaSpan { Test24533.ppr.hs:4:1-5 }))
+ []
+ []
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ (NoEpTok)
+ [])
(EpNoLayout)
(NoAnnSortKey))
(Nothing)
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -837,21 +837,6 @@ markEpAnnLMS'' a l kw (Just str) = do
-- -------------------------------------
-markEpAnnMS' :: (Monad m, Monoid w)
- => [AddEpAnn] -> AnnKeywordId -> Maybe String -> EP w m [AddEpAnn]
-markEpAnnMS' anns kw Nothing = mark anns kw
-markEpAnnMS' anns kw (Just str) = do
- mapM go anns
- where
- go :: (Monad m, Monoid w) => AddEpAnn -> EP w m AddEpAnn
- go (AddEpAnn kw' r)
- | kw' == kw = do
- r' <- printStringAtAA r str
- return (AddEpAnn kw' r')
- | otherwise = return (AddEpAnn kw' r)
-
--- -------------------------------------
-
markEpAnnLMS' :: (Monad m, Monoid w)
=> EpAnn a -> Lens a AddEpAnn -> AnnKeywordId -> Maybe String -> EP w m (EpAnn a)
markEpAnnLMS' an l kw ms = markEpAnnLMS0 an (lepa . l) kw ms
@@ -3286,51 +3271,53 @@ instance ExactPrint (HsExpr GhcPs) where
return (ArithSeq (AnnArithSeq o' mc' dd' c') s seqInfo')
- exact (HsTypedBracket an e) = do
- an0 <- markEpAnnLMS'' an lidl AnnOpen (Just "[||")
- an1 <- markEpAnnLMS'' an0 lidl AnnOpenE (Just "[e||")
+ exact (HsTypedBracket (o,c) e) = do
+ o' <- case o of
+ BracketNoE t -> BracketNoE <$> markEpToken t
+ BracketHasE t -> BracketHasE <$> markEpToken t
e' <- markAnnotated e
- an2 <- markEpAnnLMS'' an1 lidl AnnClose (Just "||]")
- return (HsTypedBracket an2 e')
+ c' <- markEpToken c
+ return (HsTypedBracket (o',c') e')
- exact (HsUntypedBracket an (ExpBr a e)) = do
- an0 <- markEpAnnL an lidl AnnOpenEQ -- "[|"
- an1 <- markEpAnnL an0 lidl AnnOpenE -- "[e|" -- optional
+ exact (HsUntypedBracket a (ExpBr (o,c) e)) = do
+ o' <- case o of
+ BracketNoE t -> BracketNoE <$> markEpUniToken t
+ BracketHasE t -> BracketHasE <$> markEpToken t
e' <- markAnnotated e
- an2 <- markEpAnnL an1 lidl AnnCloseQ -- "|]"
- return (HsUntypedBracket an2 (ExpBr a e'))
+ c' <- markEpUniToken c
+ return (HsUntypedBracket a (ExpBr (o',c') e'))
- exact (HsUntypedBracket an (PatBr a e)) = do
- an0 <- markEpAnnLMS'' an lidl AnnOpen (Just "[p|")
+ exact (HsUntypedBracket a (PatBr (o,c) e)) = do
+ o' <- markEpToken o
e' <- markAnnotated e
- an1 <- markEpAnnL an0 lidl AnnCloseQ -- "|]"
- return (HsUntypedBracket an1 (PatBr a e'))
+ c' <- markEpUniToken c
+ return (HsUntypedBracket a (PatBr (o',c') e'))
- exact (HsUntypedBracket an (DecBrL a e)) = do
- an0 <- markEpAnnLMS'' an lidl AnnOpen (Just "[d|")
- an1 <- markEpAnnL an0 lidl AnnOpenC
+ exact (HsUntypedBracket a (DecBrL (o,c, (oc,cc)) e)) = do
+ o' <- markEpToken o
+ oc' <- markEpToken oc
e' <- markAnnotated e
- an2 <- markEpAnnL an1 lidl AnnCloseC
- an3 <- markEpAnnL an2 lidl AnnCloseQ -- "|]"
- return (HsUntypedBracket an3 (DecBrL a e'))
+ cc' <- markEpToken cc
+ c' <- markEpUniToken c
+ return (HsUntypedBracket a (DecBrL (o',c',(oc',cc')) e'))
- exact (HsUntypedBracket an (TypBr a e)) = do
- an0 <- markEpAnnLMS'' an lidl AnnOpen (Just "[t|")
+ exact (HsUntypedBracket a (TypBr (o,c) e)) = do
+ o' <- markEpToken o
e' <- markAnnotated e
- an1 <- markEpAnnL an0 lidl AnnCloseQ -- "|]"
- return (HsUntypedBracket an1 (TypBr a e'))
+ c' <- markEpUniToken c
+ return (HsUntypedBracket a (TypBr (o',c') e'))
- exact (HsUntypedBracket an (VarBr a b e)) = do
+ exact (HsUntypedBracket a (VarBr an b e)) = do
(an0, e') <- if b
then do
- an' <- markEpAnnL an lidl AnnSimpleQuote
+ an' <- printStringAtAA an "'"
e' <- markAnnotated e
return (an', e')
else do
- an' <- markEpAnnL an lidl AnnThTyQuote
+ an' <- printStringAtAA an "''"
e' <- markAnnotated e
return (an', e')
- return (HsUntypedBracket an0 (VarBr a b e'))
+ return (HsUntypedBracket a (VarBr an0 b e'))
exact (HsTypedSplice an s) = do
an0 <- markEpToken an
@@ -3768,24 +3755,24 @@ instance ExactPrint (TyClDecl GhcPs) where
decl' <- markAnnotated decl
return (FamDecl a decl')
- exact (SynDecl { tcdSExt = an
+ exact (SynDecl { tcdSExt = AnnSynDecl ops cps t eq
, tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity
, tcdRhs = rhs }) = do
-- There may be arbitrary parens around parts of the constructor
-- that are infix. Turn these into comments so that they feed
-- into the right place automatically
-- TODO: no longer sorting on insert. What now?
- an0 <- annotationsToComments an lidl [AnnOpenP,AnnCloseP]
- an1 <- markEpAnnL an0 lidl AnnType
+ epTokensToComments AnnOpenP ops
+ epTokensToComments AnnCloseP cps
+ t' <- markEpToken t
(_anx, ltycon', tyvars',_,_) <- exactVanillaDeclHead ltycon tyvars fixity Nothing
- an2 <- markEpAnnL an1 lidl AnnEqual
+ eq' <- markEpToken eq
rhs' <- markAnnotated rhs
- return (SynDecl { tcdSExt = an2
+ return (SynDecl { tcdSExt = AnnSynDecl [] [] t' eq'
, tcdLName = ltycon', tcdTyVars = tyvars', tcdFixity = fixity
, tcdRhs = rhs' })
- -- TODO: add a workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/20452
exact (DataDecl { tcdDExt = an, tcdLName = ltycon, tcdTyVars = tyvars
, tcdFixity = fixity, tcdDataDefn = defn }) = do
(_, an', ltycon', tyvars', _, defn') <-
@@ -3795,7 +3782,7 @@ instance ExactPrint (TyClDecl GhcPs) where
-- -----------------------------------
- exact (ClassDecl {tcdCExt = (an, lo, sortKey),
+ exact (ClassDecl {tcdCExt = (AnnClassDecl c ops cps vb w oc cc semis, lo, sortKey),
tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
tcdFixity = fixity,
tcdFDs = fds,
@@ -3805,10 +3792,10 @@ instance ExactPrint (TyClDecl GhcPs) where
-- TODO: add a test that demonstrates tcdDocs
| null sigs && null methods && null ats && null at_defs -- No "where" part
= do
- (an0, fds', lclas', tyvars',context') <- top_matter
- an1 <- markEpAnnL an0 lidl AnnOpenC
- an2 <- markEpAnnL an1 lidl AnnCloseC
- return (ClassDecl {tcdCExt = (an2, lo, sortKey),
+ (c', w', vb', fds', lclas', tyvars',context') <- top_matter
+ oc' <- markEpToken oc
+ cc' <- markEpToken cc
+ return (ClassDecl {tcdCExt = (AnnClassDecl c' [] [] vb' w' oc' cc' semis, lo, sortKey),
tcdCtxt = context', tcdLName = lclas', tcdTyVars = tyvars',
tcdFixity = fixity,
tcdFDs = fds',
@@ -3818,9 +3805,9 @@ instance ExactPrint (TyClDecl GhcPs) where
| otherwise -- Laid out
= do
- (an0, fds', lclas', tyvars',context') <- top_matter
- an1 <- markEpAnnL an0 lidl AnnOpenC
- an2 <- markEpAnnAllL' an1 lidl AnnSemi
+ (c', w', vb', fds', lclas', tyvars',context') <- top_matter
+ oc' <- markEpToken oc
+ semis' <- mapM markEpToken semis
(sortKey', ds) <- withSortKey sortKey
[(ClsSigTag, prepareListAnnotationA sigs),
(ClsMethodTag, prepareListAnnotationA methods),
@@ -3828,13 +3815,13 @@ instance ExactPrint (TyClDecl GhcPs) where
(ClsAtdTag, prepareListAnnotationA at_defs)
-- ++ prepareListAnnotation docs
]
- an3 <- markEpAnnL an2 lidl AnnCloseC
+ cc' <- markEpToken cc
let
sigs' = undynamic ds
methods' = undynamic ds
ats' = undynamic ds
at_defs' = undynamic ds
- return (ClassDecl {tcdCExt = (an3, lo, sortKey'),
+ return (ClassDecl {tcdCExt = (AnnClassDecl c' [] [] vb' w' oc' cc' semis', lo, sortKey'),
tcdCtxt = context', tcdLName = lclas', tcdTyVars = tyvars',
tcdFixity = fixity,
tcdFDs = fds',
@@ -3843,17 +3830,18 @@ instance ExactPrint (TyClDecl GhcPs) where
tcdDocs = _docs})
where
top_matter = do
- an' <- annotationsToComments an lidl [AnnOpenP, AnnCloseP]
- an0 <- markEpAnnL an' lidl AnnClass
+ epTokensToComments AnnOpenP ops
+ epTokensToComments AnnCloseP cps
+ c' <- markEpToken c
(_, lclas', tyvars',_,context') <- exactVanillaDeclHead lclas tyvars fixity context
- (an1, fds') <- if (null fds)
- then return (an0, fds)
+ (vb', fds') <- if (null fds)
+ then return (vb, fds)
else do
- an1 <- markEpAnnL an0 lidl AnnVbar
+ vb' <- markEpToken vb
fds' <- markAnnotated fds
- return (an1, fds')
- an2 <- markEpAnnL an1 lidl AnnWhere
- return (an2, fds', lclas', tyvars',context')
+ return (vb', fds')
+ w' <- markEpToken w
+ return (c', w', vb', fds', lclas', tyvars',context')
-- ---------------------------------------------------------------------
@@ -4202,37 +4190,36 @@ instance ExactPrint (HsType GhcPs) where
exact (HsDocTy an ty doc) = do
ty' <- markAnnotated ty
return (HsDocTy an ty' doc)
- exact (HsBangTy (an, mt) (HsBang up str) ty) = do
- an0 <-
+ exact (HsBangTy ((o,c,tk), mt) (HsBang up str) ty) = do
+ (o',c') <-
case mt of
- NoSourceText -> return an
+ NoSourceText -> return (o,c)
SourceText src -> do
debugM $ "HsBangTy: src=" ++ showAst src
- an0 <- markEpAnnMS' an AnnOpen (Just $ unpackFS src)
- an1 <- markEpAnnMS' an0 AnnClose (Just "#-}")
- debugM $ "HsBangTy: done unpackedness"
- return an1
- an1 <-
+ o' <- printStringAtAA o (unpackFS src)
+ c' <- printStringAtAA c "#-}"
+ return (o',c')
+ tk' <-
case str of
- SrcLazy -> mark an0 AnnTilde
- SrcStrict -> mark an0 AnnBang
- NoSrcStrict -> return an0
+ SrcLazy -> printStringAtAA tk "~"
+ SrcStrict -> printStringAtAA tk "!"
+ NoSrcStrict -> return tk
ty' <- markAnnotated ty
- return (HsBangTy (an1, mt) (HsBang up str) ty')
- exact (HsExplicitListTy an prom tys) = do
- an0 <- if (isPromoted prom)
- then mark an AnnSimpleQuote
- else return an
- an1 <- mark an0 AnnOpenS
+ return (HsBangTy ((o',c',tk'), mt) (HsBang up str) ty')
+ exact (HsExplicitListTy (sq,o,c) prom tys) = do
+ sq' <- if (isPromoted prom)
+ then markEpToken sq
+ else return sq
+ o' <- markEpToken o
tys' <- markAnnotated tys
- an2 <- mark an1 AnnCloseS
- return (HsExplicitListTy an2 prom tys')
- exact (HsExplicitTupleTy an tys) = do
- an0 <- mark an AnnSimpleQuote
- an1 <- mark an0 AnnOpenP
+ c' <- markEpToken c
+ return (HsExplicitListTy (sq',o',c') prom tys')
+ exact (HsExplicitTupleTy (sq, o, c) tys) = do
+ sq' <- markEpToken sq
+ o' <- markEpToken o
tys' <- markAnnotated tys
- an2 <- mark an1 AnnCloseP
- return (HsExplicitTupleTy an2 tys')
+ c' <- markEpToken c
+ return (HsExplicitTupleTy (sq', o', c') tys')
exact (HsTyLit a lit) = do
case lit of
(HsNumTy src v) -> printSourceText src (show v)
=====================================
utils/check-exact/Main.hs
=====================================
@@ -166,7 +166,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/printer/T18052a.hs" Nothing
-- "../../testsuite/tests/printer/T18247a.hs" Nothing
-- "../../testsuite/tests/printer/Test10268.hs" Nothing
- "../../testsuite/tests/printer/Test10269.hs" Nothing
+ -- "../../testsuite/tests/printer/Test10269.hs" Nothing
-- "../../testsuite/tests/printer/Test10276.hs" Nothing
-- "../../testsuite/tests/printer/Test10278.hs" Nothing
-- "../../testsuite/tests/printer/Test10312.hs" Nothing
@@ -209,6 +209,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/printer/PprParenFunBind.hs" Nothing
-- "../../testsuite/tests/printer/Test16279.hs" Nothing
-- "../../testsuite/tests/printer/HsDocTy.hs" Nothing
+ "../../testsuite/tests/printer/Test21355.hs" Nothing
-- "../../testsuite/tests/printer/Test22765.hs" Nothing
-- "../../testsuite/tests/printer/Test22771.hs" Nothing
-- "../../testsuite/tests/printer/Test23465.hs" Nothing
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2424235d74fc5ea634ee68f2381ef657071c6a0b...cecae38586355beeb2d88c326dfe4d645041b7af
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2424235d74fc5ea634ee68f2381ef657071c6a0b...cecae38586355beeb2d88c326dfe4d645041b7af
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/b648f9ac/attachment-0001.html>
More information about the ghc-commits
mailing list