[Git][ghc/ghc][wip/az/epa-remove-addepann-5] EPA: Remove [AddEpAnn] Commit 5
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Sun Oct 20 21:45:13 UTC 2024
Alan Zimmerman pushed to branch wip/az/epa-remove-addepann-5 at Glasgow Haskell Compiler / GHC
Commits:
c8601c77 by Alan Zimmerman at 2024-10-20T19:26:52+01:00
EPA: Remove [AddEpAnn] Commit 5
EPA: Remove [AddEpAnn] from AnnPragma
EPA: Remove [AddEpAnn] From ForeignDecl
EPA: Remove [AddEpAnn] from RoleAnnotDecl
EPA: Remove [AddEpAnn] from StandaloneKindSig
EPA: Remove [AddEpAnn] From HsDeriving
EPA: Remove [AddEpAnn] from ConDeclField
EPA: Remove [AddEpAnn] from ConDeclGADT
EPA: Remove [AddEpAnn] from ConDeclH98
EPA: Remove [AddEpAnn] from ClsInstDecl
- - - - -
22 changed files:
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/JS/Ppr.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.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/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/KindSigs.stderr
- testsuite/tests/parser/should_compile/T14189.stderr
- testsuite/tests/parser/should_compile/T15323.stderr
- testsuite/tests/parser/should_compile/T20452.stderr
- testsuite/tests/printer/T18791.stderr
- testsuite/tests/printer/Test24533.stdout
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
Changes:
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -35,6 +35,7 @@ module GHC.Hs.Decls (
AnnClassDecl(..),
AnnSynDecl(..),
AnnFamilyDecl(..),
+ AnnClsInstDecl(..),
TyClGroup(..),
tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,
tyClGroupKindSigs,
@@ -59,7 +60,7 @@ module GHC.Hs.Decls (
LClsInstDecl, ClsInstDecl(..),
-- ** Standalone deriving declarations
- DerivDecl(..), LDerivDecl,
+ DerivDecl(..), LDerivDecl, AnnDerivDecl,
-- ** Deriving strategies
DerivStrategy(..), LDerivStrategy,
derivStrategyName, foldDerivStrategy, mapDerivStrategy,
@@ -80,7 +81,9 @@ module GHC.Hs.Decls (
CImportSpec(..),
-- ** Data-constructor declarations
ConDecl(..), LConDecl,
- HsConDeclH98Details, HsConDeclGADTDetails(..), hsConDeclTheta,
+ HsConDeclH98Details, HsConDeclGADTDetails(..),
+ AnnConDeclH98(..), AnnConDeclGADT(..),
+ hsConDeclTheta,
getConNames, getRecConArgs_maybe,
-- ** Document comments
DocDecl(..), LDocDecl, docDeclDoc,
@@ -705,7 +708,7 @@ instance OutputableBndrId p
type instance XCHsDataDefn (GhcPass _) = AnnDataDefn
type instance XXHsDataDefn (GhcPass _) = DataConCantHappen
-type instance XCHsDerivingClause (GhcPass _) = [AddEpAnn]
+type instance XCHsDerivingClause (GhcPass _) = EpToken "deriving"
type instance XXHsDerivingClause (GhcPass _) = DataConCantHappen
instance OutputableBndrId p
@@ -741,7 +744,7 @@ instance OutputableBndrId p => Outputable (DerivClauseTys (GhcPass p)) where
ppr (DctSingle _ ty) = ppr ty
ppr (DctMulti _ tys) = parens (interpp'SP tys)
-type instance XStandaloneKindSig GhcPs = [AddEpAnn]
+type instance XStandaloneKindSig GhcPs = (EpToken "type", TokDcolon)
type instance XStandaloneKindSig GhcRn = NoExtField
type instance XStandaloneKindSig GhcTc = NoExtField
@@ -750,11 +753,11 @@ type instance XXStandaloneKindSig (GhcPass p) = DataConCantHappen
standaloneKindSigName :: StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)
standaloneKindSigName (StandaloneKindSig _ lname _) = unLoc lname
-type instance XConDeclGADT GhcPs = (EpUniToken "::" "∷", [AddEpAnn])
+type instance XConDeclGADT GhcPs = AnnConDeclGADT
type instance XConDeclGADT GhcRn = NoExtField
type instance XConDeclGADT GhcTc = NoExtField
-type instance XConDeclH98 GhcPs = [AddEpAnn]
+type instance XConDeclH98 GhcPs = AnnConDeclH98
type instance XConDeclH98 GhcRn = NoExtField
type instance XConDeclH98 GhcTc = NoExtField
@@ -768,6 +771,26 @@ type instance XRecConGADT GhcTc = NoExtField
type instance XXConDeclGADTDetails (GhcPass _) = DataConCantHappen
+data AnnConDeclH98
+ = AnnConDeclH98 {
+ acdh_forall :: TokForall,
+ acdh_dot :: EpToken ".",
+ acdh_darrow :: TokDarrow
+ } deriving Data
+
+instance NoAnn AnnConDeclH98 where
+ noAnn = AnnConDeclH98 noAnn noAnn noAnn
+
+data AnnConDeclGADT
+ = AnnConDeclGADT {
+ acdg_openp :: [EpToken "("],
+ acdg_closep :: [EpToken ")"],
+ acdg_dcolon :: TokDcolon
+ } deriving Data
+
+instance NoAnn AnnConDeclGADT where
+ noAnn = AnnConDeclGADT noAnn noAnn noAnn
+
-- Codomain could be 'NonEmpty', but at the moment all users need a list.
getConNames :: ConDecl GhcRn -> [LocatedN Name]
getConNames ConDeclH98 {con_name = name} = [name]
@@ -901,7 +924,7 @@ type instance XCClsInstDecl GhcPs = ( Maybe (LWarningTxt GhcPs)
-- The warning of the deprecated instance
-- See Note [Implementation of deprecated instances]
-- in GHC.Tc.Solver.Dict
- , [AddEpAnn]
+ , AnnClsInstDecl
, AnnSortKey DeclTag) -- For sorting the additional annotations
-- TODO:AZ:tidy up
type instance XCClsInstDecl GhcRn = Maybe (LWarningTxt GhcRn)
@@ -924,6 +947,18 @@ type instance XTyFamInstD GhcTc = NoExtField
type instance XXInstDecl (GhcPass _) = DataConCantHappen
+data AnnClsInstDecl
+ = AnnClsInstDecl {
+ acid_instance :: EpToken "instance",
+ acid_where :: EpToken "where",
+ acid_openc :: EpToken "{",
+ acid_semis :: [EpToken ";"],
+ acid_closec :: EpToken "}"
+ } deriving Data
+
+instance NoAnn AnnClsInstDecl where
+ noAnn = AnnClsInstDecl noAnn noAnn noAnn noAnn noAnn
+
cidDeprecation :: forall p. IsPass p
=> ClsInstDecl (GhcPass p)
-> Maybe (WarningTxt (GhcPass p))
@@ -1086,15 +1121,17 @@ type instance XCDerivDecl GhcPs = ( Maybe (LWarningTxt GhcPs)
-- The warning of the deprecated derivation
-- See Note [Implementation of deprecated instances]
-- in GHC.Tc.Solver.Dict
- , [AddEpAnn] )
+ , AnnDerivDecl )
type instance XCDerivDecl GhcRn = ( Maybe (LWarningTxt GhcRn)
-- The warning of the deprecated derivation
-- See Note [Implementation of deprecated instances]
-- in GHC.Tc.Solver.Dict
- , [AddEpAnn] )
-type instance XCDerivDecl GhcTc = [AddEpAnn]
+ , AnnDerivDecl )
+type instance XCDerivDecl GhcTc = AnnDerivDecl
type instance XXDerivDecl (GhcPass _) = DataConCantHappen
+type AnnDerivDecl = (EpToken "deriving", EpToken "instance")
+
derivDeprecation :: forall p. IsPass p
=> DerivDecl (GhcPass p)
-> Maybe (WarningTxt (GhcPass p))
@@ -1128,15 +1165,15 @@ instance OutputableBndrId p
************************************************************************
-}
-type instance XStockStrategy GhcPs = [AddEpAnn]
+type instance XStockStrategy GhcPs = EpToken "stock"
type instance XStockStrategy GhcRn = NoExtField
type instance XStockStrategy GhcTc = NoExtField
-type instance XAnyClassStrategy GhcPs = [AddEpAnn]
+type instance XAnyClassStrategy GhcPs = EpToken "anyclass"
type instance XAnyClassStrategy GhcRn = NoExtField
type instance XAnyClassStrategy GhcTc = NoExtField
-type instance XNewtypeStrategy GhcPs = [AddEpAnn]
+type instance XNewtypeStrategy GhcPs = EpToken "newtype"
type instance XNewtypeStrategy GhcRn = NoExtField
type instance XNewtypeStrategy GhcTc = NoExtField
@@ -1144,7 +1181,7 @@ type instance XViaStrategy GhcPs = XViaStrategyPs
type instance XViaStrategy GhcRn = LHsSigType GhcRn
type instance XViaStrategy GhcTc = Type
-data XViaStrategyPs = XViaStrategyPs [AddEpAnn] (LHsSigType GhcPs)
+data XViaStrategyPs = XViaStrategyPs (EpToken "via") (LHsSigType GhcPs)
instance OutputableBndrId p
=> Outputable (DerivStrategy (GhcPass p)) where
@@ -1202,11 +1239,11 @@ instance OutputableBndrId p
************************************************************************
-}
-type instance XForeignImport GhcPs = [AddEpAnn]
+type instance XForeignImport GhcPs = (EpToken "foreign", EpToken "import", TokDcolon)
type instance XForeignImport GhcRn = NoExtField
type instance XForeignImport GhcTc = Coercion
-type instance XForeignExport GhcPs = [AddEpAnn]
+type instance XForeignExport GhcPs = (EpToken "foreign", EpToken "export", TokDcolon)
type instance XForeignExport GhcRn = NoExtField
type instance XForeignExport GhcTc = Coercion
@@ -1218,6 +1255,7 @@ type instance XXForeignImport (GhcPass _) = DataConCantHappen
type instance XCExport (GhcPass _) = LocatedE SourceText -- original source text for the C entity
type instance XXForeignExport (GhcPass _) = DataConCantHappen
+
-- pretty printing of foreign declarations
instance OutputableBndrId p
@@ -1362,7 +1400,7 @@ type instance XWarnings GhcTc = SourceText
type instance XXWarnDecls (GhcPass _) = DataConCantHappen
-type instance XWarning (GhcPass _) = (NamespaceSpecifier, [AddEpAnn])
+type instance XWarning (GhcPass _) = (NamespaceSpecifier, (EpToken "[", EpToken "]"))
type instance XXWarnDecl (GhcPass _) = DataConCantHappen
@@ -1418,7 +1456,7 @@ pprAnnProvenance (TypeAnnProvenance (L _ name))
************************************************************************
-}
-type instance XCRoleAnnotDecl GhcPs = [AddEpAnn]
+type instance XCRoleAnnotDecl GhcPs = (EpToken "type", EpToken "role")
type instance XCRoleAnnotDecl GhcRn = NoExtField
type instance XCRoleAnnotDecl GhcTc = NoExtField
=====================================
compiler/GHC/Hs/Dump.hs
=====================================
@@ -81,6 +81,7 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
`extQ` annSynDecl
`extQ` annDataDefn
`extQ` annFamilyDecl
+ `extQ` annClsInstDecl
`extQ` lit `extQ` litr `extQ` litt
`extQ` sourceText
`extQ` deltaPos
@@ -262,6 +263,15 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
showAstData' g, showAstData' h, showAstData' i,
showAstData' j, showAstData' k, showAstData' l]
+ annClsInstDecl :: AnnClsInstDecl -> SDoc
+ annClsInstDecl (AnnClsInstDecl a b c d e) = case ba of
+ BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnFamilyDecl"
+ NoBlankEpAnnotations ->
+ parens $ text "AnnClsInstDecl"
+ $$ vcat [showAstData' a, showAstData' b, showAstData' c,
+ showAstData' d, showAstData' e]
+
+
addEpAnn :: AddEpAnn -> SDoc
addEpAnn (AddEpAnn a s) = case ba of
BlankEpAnnotations -> parens
@@ -294,7 +304,7 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
epTokenInstance :: EpToken "instance" -> SDoc
epTokenInstance = epToken'
- epTokenForall :: EpUniToken "forall" "∀" -> SDoc
+ epTokenForall :: TokForall -> SDoc
epTokenForall = epUniToken'
epToken' :: KnownSymbol sym => EpToken sym -> SDoc
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -163,15 +163,15 @@ getBangStrictness _ = (mkHsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)
fromMaybeContext :: Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)
fromMaybeContext mctxt = unLoc $ fromMaybe (noLocA []) mctxt
-type instance XHsForAllVis (GhcPass _) = EpAnn (EpUniToken "forall" "∀", EpUniToken "->" "→")
+type instance XHsForAllVis (GhcPass _) = EpAnn (TokForall, EpUniToken "->" "→")
-- Location of 'forall' and '->'
-type instance XHsForAllInvis (GhcPass _) = EpAnn (EpUniToken "forall" "∀", EpToken ".")
+type instance XHsForAllInvis (GhcPass _) = EpAnn (TokForall, EpToken ".")
-- Location of 'forall' and '.'
type instance XXHsForAllTelescope (GhcPass _) = DataConCantHappen
-type EpAnnForallVis = EpAnn (EpUniToken "forall" "∀", EpUniToken "->" "→")
-type EpAnnForallInvis = EpAnn (EpUniToken "forall" "∀", EpToken ".")
+type EpAnnForallVis = EpAnn (TokForall, TokRarrow)
+type EpAnnForallInvis = EpAnn (TokForall, EpToken ".")
type HsQTvsRn = [Name] -- Implicit variables
-- For example, in data T (a :: k1 -> k2) = ...
@@ -461,7 +461,7 @@ type instance XListTy (GhcPass _) = AnnParen
type instance XTupleTy (GhcPass _) = AnnParen
type instance XSumTy (GhcPass _) = AnnParen
type instance XOpTy (GhcPass _) = NoExtField
-type instance XParTy (GhcPass _) = AnnParen
+type instance XParTy (GhcPass _) = (EpToken "(", EpToken ")")
type instance XIParamTy (GhcPass _) = TokDcolon
type instance XStarTy (GhcPass _) = NoExtField
type instance XKindSig (GhcPass _) = TokDcolon
@@ -572,7 +572,7 @@ pprHsArrow (HsUnrestrictedArrow _) = pprArrowWithMultiplicity visArgTypeLike (Le
pprHsArrow (HsLinearArrow _) = pprArrowWithMultiplicity visArgTypeLike (Left True)
pprHsArrow (HsExplicitMult _ p) = pprArrowWithMultiplicity visArgTypeLike (Right (ppr p))
-type instance XConDeclField (GhcPass _) = [AddEpAnn]
+type instance XConDeclField (GhcPass _) = TokDcolon
type instance XXConDeclField (GhcPass _) = DataConCantHappen
instance OutputableBndrId p
@@ -710,23 +710,22 @@ mkHsAppKindTy at ty k = addCLocA ty k (HsAppKindTy at ty k)
-- It returns API Annotations for any parens removed
splitHsFunType ::
LHsType (GhcPass p)
- -> ( [AddEpAnn], EpAnnComments -- The locations of any parens and
+ -> ( ([EpToken "("], [EpToken ")"]) , EpAnnComments -- The locations of any parens and
-- comments discarded
, [HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p))
splitHsFunType ty = go ty
where
- go (L l (HsParTy an ty))
+ go (L l (HsParTy (op,cp) ty))
= let
- (anns, cs, args, res) = splitHsFunType ty
- anns' = anns ++ annParen2AddEpAnn an
+ ((ops, cps), cs, args, res) = splitHsFunType ty
cs' = cs S.<> epAnnComments l
- in (anns', cs', args, res)
+ in ((ops++[op], cps ++ [cp]), cs', args, res)
go (L ll (HsFunTy _ mult x y))
| (anns, csy, args, res) <- splitHsFunType y
= (anns, csy S.<> epAnnComments ll, HsScaled mult x:args, res)
- go other = ([], emptyComments, [], other)
+ go other = (noAnn, emptyComments, [], other)
-- | Retrieve the name of the \"head\" of a nested type application.
-- This is somewhat like @GHC.Tc.Gen.HsType.splitHsAppTys@, but a little more
=====================================
compiler/GHC/JS/Ppr.hs
=====================================
@@ -33,7 +33,7 @@
-- * Design
--
-- This module follows the architecture and style of the other backends in
--- GHC: it intances Outputable for the relevant types, creates a class that
+-- GHC: it instances Outputable for the relevant types, creates a class that
-- describes a morphism from the IR domain to JavaScript concrete Syntax and
-- then generates that syntax on a case by case basis.
--
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1274,7 +1274,7 @@ topdecl :: { LHsDecl GhcPs }
| stand_alone_deriving { L (getLoc $1) (DerivD noExtField (unLoc $1)) }
| role_annot { L (getLoc $1) (RoleAnnotD noExtField (unLoc $1)) }
| default_decl { L (getLoc $1) (DefD noExtField (unLoc $1)) }
- | 'foreign' fdecl {% amsA' (sLL $1 $> ((snd $ unLoc $2) (mj AnnForeign $1:(fst $ unLoc $2)))) }
+ | 'foreign' fdecl {% amsA' (sLL $1 $> ((unLoc $2) (epTok $1))) }
| '{-# DEPRECATED' deprecations '#-}' {% amsA' (sLL $1 $> $ WarningD noExtField (Warnings ((glR $1,glR $3), (getDEPRECATED_PRAGs $1)) (fromOL $2))) }
| '{-# WARNING' warnings '#-}' {% amsA' (sLL $1 $> $ WarningD noExtField (Warnings ((glR $1,glR $3), (getWARNING_PRAGs $1)) (fromOL $2))) }
| '{-# RULES' rules '#-}' {% amsA' (sLL $1 $> $ RuleD noExtField (HsRules ((glR $1,glR $3), (getRULES_PRAGs $1)) (reverse $2))) }
@@ -1366,7 +1366,7 @@ ty_decl :: { LTyClDecl GhcPs }
standalone_kind_sig :: { LStandaloneKindSig GhcPs }
: 'type' sks_vars '::' sigktype
{% mkStandaloneKindSig (comb2 $1 $4) (L (gl $2) $ unLoc $2) $4
- [mj AnnType $1,mu AnnDcolon $3]}
+ (epTok $1,epUniTok $3)}
-- See also: sig_vars
sks_vars :: { Located [LocatedN RdrName] } -- Returned in reverse order
@@ -1380,7 +1380,8 @@ sks_vars :: { Located [LocatedN RdrName] } -- Returned in reverse order
inst_decl :: { LInstDecl GhcPs }
: 'instance' maybe_warning_pragma overlap_pragma inst_type where_inst
{% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $5)
- ; let anns = (mj AnnInstance $1 : (fst $ unLoc $5))
+ ; let (twhere, (openc, closec, semis)) = fst $ unLoc $5
+ ; let anns = AnnClsInstDecl (epTok $1) twhere openc semis closec
; let cid = ClsInstDecl
{ cid_ext = ($2, anns, NoAnnSortKey)
, cid_poly_ty = $4, cid_binds = binds
@@ -1421,27 +1422,27 @@ inst_decl :: { LInstDecl GhcPs }
overlap_pragma :: { Maybe (LocatedP OverlapMode) }
: '{-# OVERLAPPABLE' '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1)))
- (AnnPragma (mo $1) (mc $2) []) }
+ (AnnPragma (glR $1) (glR $2) noAnn noAnn noAnn noAnn noAnn) }
| '{-# OVERLAPPING' '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1)))
- (AnnPragma (mo $1) (mc $2) []) }
+ (AnnPragma (glR $1) (glR $2) noAnn noAnn noAnn noAnn noAnn) }
| '{-# OVERLAPS' '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1)))
- (AnnPragma (mo $1) (mc $2) []) }
+ (AnnPragma (glR $1) (glR $2) noAnn noAnn noAnn noAnn noAnn) }
| '{-# INCOHERENT' '#-}' {% fmap Just $ amsr (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1)))
- (AnnPragma (mo $1) (mc $2) []) }
+ (AnnPragma (glR $1) (glR $2) noAnn noAnn noAnn noAnn noAnn) }
| {- empty -} { Nothing }
deriv_strategy_no_via :: { LDerivStrategy GhcPs }
- : 'stock' {% amsA' (sL1 $1 (StockStrategy [mj AnnStock $1])) }
- | 'anyclass' {% amsA' (sL1 $1 (AnyclassStrategy [mj AnnAnyclass $1])) }
- | 'newtype' {% amsA' (sL1 $1 (NewtypeStrategy [mj AnnNewtype $1])) }
+ : 'stock' {% amsA' (sL1 $1 (StockStrategy (epTok $1))) }
+ | 'anyclass' {% amsA' (sL1 $1 (AnyclassStrategy (epTok $1))) }
+ | 'newtype' {% amsA' (sL1 $1 (NewtypeStrategy (epTok $1))) }
deriv_strategy_via :: { LDerivStrategy GhcPs }
- : 'via' sigktype {% amsA' (sLL $1 $> (ViaStrategy (XViaStrategyPs [mj AnnVia $1] $2))) }
+ : 'via' sigktype {% amsA' (sLL $1 $> (ViaStrategy (XViaStrategyPs (epTok $1) $2))) }
deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) }
- : 'stock' {% fmap Just $ amsA' (sL1 $1 (StockStrategy [mj AnnStock $1])) }
- | 'anyclass' {% fmap Just $ amsA' (sL1 $1 (AnyclassStrategy [mj AnnAnyclass $1])) }
- | 'newtype' {% fmap Just $ amsA' (sL1 $1 (NewtypeStrategy [mj AnnNewtype $1])) }
+ : 'stock' {% fmap Just $ amsA' (sL1 $1 (StockStrategy (epTok $1))) }
+ | 'anyclass' {% fmap Just $ amsA' (sL1 $1 (AnyclassStrategy (epTok $1))) }
+ | 'newtype' {% fmap Just $ amsA' (sL1 $1 (NewtypeStrategy (epTok $1))) }
| deriv_strategy_via { Just $1 }
| {- empty -} { Nothing }
@@ -1659,11 +1660,11 @@ capi_ctype :: { Maybe (LocatedP CType) }
capi_ctype : '{-# CTYPE' STRING STRING '#-}'
{% fmap Just $ amsr (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2)))
(getSTRINGs $3,getSTRING $3)))
- (AnnPragma (mo $1) (mc $4) [mj AnnHeader $2,mj AnnVal $3]) }
+ (AnnPragma (glR $1) (glR $4) noAnn (glR $2) (glR $3) noAnn noAnn) }
| '{-# CTYPE' STRING '#-}'
{% fmap Just $ amsr (sLL $1 $> (CType (getCTYPEs $1) Nothing (getSTRINGs $2, getSTRING $2)))
- (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) }
+ (AnnPragma (glR $1) (glR $3) noAnn noAnn (glR $2) noAnn noAnn) }
| { Nothing }
@@ -1676,7 +1677,7 @@ stand_alone_deriving :: { LDerivDecl GhcPs }
{% do { let { err = text "in the stand-alone deriving instance"
<> colon <+> quotes (ppr $6) }
; amsA' (sLL $1 $>
- (DerivDecl ($4, [mj AnnDeriving $1, mj AnnInstance $3]) (mkHsWildCardBndrs $6) $2 $5)) }}
+ (DerivDecl ($4, (epTok $1, epTok $3)) (mkHsWildCardBndrs $6) $2 $5)) }}
-----------------------------------------------------------------------------
-- Role annotations
@@ -1684,7 +1685,7 @@ stand_alone_deriving :: { LDerivDecl GhcPs }
role_annot :: { LRoleAnnotDecl GhcPs }
role_annot : 'type' 'role' oqtycon maybe_roles
{% mkRoleAnnotDecl (comb3 $1 $4 $3) $3 (reverse (unLoc $4))
- [mj AnnType $1,mj AnnRole $2] }
+ (epTok $1,epTok $2) }
-- Reversed!
maybe_roles :: { Located [Located (Maybe FastString)] }
@@ -1816,9 +1817,9 @@ decl_inst :: { Located (OrdList (LHsDecl GhcPs)) }
decl_inst : at_decl_inst { sL1 $1 (unitOL (sL1a $1 (InstD noExtField (unLoc $1)))) }
| decl { sL1 $1 (unitOL $1) }
-decls_inst :: { Located ([AddEpAnn],OrdList (LHsDecl GhcPs)) } -- Reversed
+decls_inst :: { Located ([EpToken ";"],OrdList (LHsDecl GhcPs)) } -- Reversed
: decls_inst ';' decl_inst {% if isNilOL (snd $ unLoc $1)
- then return (sLL $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)
+ then return (sLL $1 $> ((fst $ unLoc $1) ++ [mzEpTok $2]
, unLoc $3))
else case (snd $ unLoc $1) of
SnocOL hs t -> do
@@ -1826,7 +1827,7 @@ decls_inst :: { Located ([AddEpAnn],OrdList (LHsDecl GhcPs)) } -- Reversed
return (sLL $1 $> (fst $ unLoc $1
, snocOL hs t' `appOL` unLoc $3)) }
| decls_inst ';' {% 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
@@ -1837,20 +1838,20 @@ decls_inst :: { Located ([AddEpAnn],OrdList (LHsDecl GhcPs)) } -- Reversed
| {- empty -} { noLoc ([],nilOL) }
decllist_inst
- :: { Located ([AddEpAnn]
+ :: { Located ((EpToken "{", EpToken "}", [EpToken ";"])
, OrdList (LHsDecl GhcPs)) } -- Reversed
- : '{' decls_inst '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2),snd $ unLoc $2) }
- | vocurly decls_inst close { L (gl $2) (unLoc $2) }
+ : '{' decls_inst '}' { sLL $1 $> ((epTok $1,epTok $3,fst $ unLoc $2),snd $ unLoc $2) }
+ | vocurly decls_inst close { L (gl $2) ((noAnn,noAnn,fst $ unLoc $2),snd $ unLoc $2) }
-- Instance body
--
-where_inst :: { Located ([AddEpAnn]
+where_inst :: { Located ((EpToken "where", (EpToken "{", EpToken "}", [EpToken ";"]))
, OrdList (LHsDecl GhcPs)) } -- Reversed
-- No implicit parameters
-- May have type declarations
- : 'where' decllist_inst { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2)
- ,(snd $ unLoc $2)) }
- | {- empty -} { noLoc ([],nilOL) }
+ : 'where' decllist_inst { sLL $1 $> ((epTok $1,(fst $ unLoc $2))
+ ,snd $ unLoc $2) }
+ | {- empty -} { noLoc (noAnn,nilOL) }
-- Declarations in binding groups other than classes and instances
--
@@ -2019,10 +2020,10 @@ to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated.
maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) }
: '{-# DEPRECATED' strings '#-}'
{% fmap Just $ amsr (sLL $1 $> $ DeprecatedTxt (getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2))
- (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2)) }
+ (AnnPragma (glR $1) (glR $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) }
| '{-# WARNING' warning_category strings '#-}'
{% fmap Just $ amsr (sLL $1 $> $ WarningTxt $2 (getWARNING_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $3))
- (AnnPragma (mo $1) (mc $4) (fst $ unLoc $3))}
+ (AnnPragma (glR $1) (glR $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn)}
| {- empty -} { Nothing }
warning_category :: { Maybe (LocatedE InWarningCategory) }
@@ -2081,9 +2082,9 @@ deprecation :: { OrdList (LWarnDecl GhcPs) }
{% fmap unitOL $ amsA' (sL (comb3 $1 $2 $>) $ (Warning (unLoc $1, fst $ unLoc $3) (unLoc $2)
(DeprecatedTxt NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) }
-strings :: { Located ([AddEpAnn],[Located StringLiteral]) }
- : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) }
- | '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) }
+strings :: { Located ((EpToken "[", EpToken "]"),[Located StringLiteral]) }
+ : STRING { sL1 $1 (noAnn,[L (gl $1) (getStringLiteral $1)]) }
+ | '[' stringlist ']' { sLL $1 $> $ ((epTok $1,epTok $3),fromOL (unLoc $2)) }
stringlist :: { Located (OrdList (Located StringLiteral)) }
: stringlist ',' STRING {% if isNilOL (unLoc $1)
@@ -2104,35 +2105,35 @@ stringlist :: { Located (OrdList (Located StringLiteral)) }
annotation :: { LHsDecl GhcPs }
: '{-# ANN' name_var aexp '#-}' {% runPV (unECP $3) >>= \ $3 ->
amsA' (sLL $1 $> (AnnD noExtField $ HsAnnotation
- (AnnPragma (mo $1) (mc $4) [],
+ (AnnPragma (glR $1) (glR $4) noAnn noAnn noAnn noAnn noAnn,
(getANN_PRAGs $1))
(ValueAnnProvenance $2) $3)) }
| '{-# ANN' 'type' otycon aexp '#-}' {% runPV (unECP $4) >>= \ $4 ->
amsA' (sLL $1 $> (AnnD noExtField $ HsAnnotation
- (AnnPragma (mo $1) (mc $5) [mj AnnType $2],
+ (AnnPragma (glR $1) (glR $5) noAnn noAnn noAnn (epTok $2) noAnn,
(getANN_PRAGs $1))
(TypeAnnProvenance $3) $4)) }
| '{-# ANN' 'module' aexp '#-}' {% runPV (unECP $3) >>= \ $3 ->
amsA' (sLL $1 $> (AnnD noExtField $ HsAnnotation
- (AnnPragma (mo $1) (mc $4) [mj AnnModule $2],
+ (AnnPragma (glR $1) (glR $4) noAnn noAnn noAnn noAnn (epTok $2),
(getANN_PRAGs $1))
ModuleAnnProvenance $3)) }
-----------------------------------------------------------------------------
-- Foreign import and export declarations
-fdecl :: { Located ([AddEpAnn], [AddEpAnn] -> HsDecl GhcPs) }
+fdecl :: { Located (EpToken "foreign" -> HsDecl GhcPs) }
fdecl : 'import' callconv safety fspec
- {% mkImport $2 $3 (snd $ unLoc $4) >>= \i ->
- return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $4),i)) }
+ {% mkImport $2 $3 (snd $ unLoc $4) (epTok $1, fst $ unLoc $4) >>= \i ->
+ return (sLL $1 $> i) }
| 'import' callconv fspec
- {% do { d <- mkImport $2 (noLoc PlaySafe) (snd $ unLoc $3);
- return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $3),d)) }}
+ {% do { d <- mkImport $2 (noLoc PlaySafe) (snd $ unLoc $3) (epTok $1, fst $ unLoc $3);
+ return (sLL $1 $> d) }}
| 'export' callconv fspec
- {% mkExport $2 (snd $ unLoc $3) >>= \i ->
- return (sLL $1 $> (mj AnnExport $1 : (fst $ unLoc $3),i) ) }
+ {% mkExport $2 (snd $ unLoc $3) (epTok $1, fst $ unLoc $3) >>= \i ->
+ return (sLL $1 $> i ) }
callconv :: { Located CCallConv }
: 'stdcall' { sLL $1 $> StdCallConv }
@@ -2146,12 +2147,12 @@ safety :: { Located Safety }
| 'safe' { sLL $1 $> PlaySafe }
| 'interruptible' { sLL $1 $> PlayInterruptible }
-fspec :: { Located ([AddEpAnn]
+fspec :: { Located (TokDcolon
,(Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)) }
- : STRING var '::' sigtype { sLL $1 $> ([mu AnnDcolon $3]
+ : STRING var '::' sigtype { sLL $1 $> (epUniTok $3
,(L (getLoc $1)
(getStringLiteral $1), $2, $4)) }
- | var '::' sigtype { sLL $1 $> ([mu AnnDcolon $2]
+ | var '::' sigtype { sLL $1 $> (epUniTok $2
,(noLoc (StringLiteral NoSourceText nilFS Nothing), $1, $3)) }
-- if the entity string is missing, it defaults to the empty string;
-- the meaning of an empty entity string depends on the calling
@@ -2343,7 +2344,7 @@ atype :: { LHsType GhcPs }
| '(#' 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)) }
- | '(' ktype ')' {% amsA' (sLL $1 $> $ HsParTy (AnnParen AnnParens (glR $1) (glR $3)) $2) }
+ | '(' ktype ')' {% amsA' (sLL $1 $> $ HsParTy (epTok $1, epTok $3) $2) }
-- see Note [Promotion] for the followings
| SIMPLEQUOTE '(' ')' {% do { requireLTPuns PEP_QuoteDisambiguation $1 $>
; amsA' (sLL $1 $> $ HsExplicitTupleTy (epTok $1,epTok $2,epTok $3) []) }}
@@ -2559,22 +2560,22 @@ constr :: { LConDecl GhcPs }
: forall context '=>' constr_stuff
{% amsA' (let (con,details) = unLoc $4 in
(L (comb4 $1 $2 $3 $4) (mkConDeclH98
- (mu AnnDarrow $3:(fst $ unLoc $1))
+ (epUniTok $3,(fst $ unLoc $1))
con
(snd $ unLoc $1)
(Just $2)
details))) }
| forall constr_stuff
{% amsA' (let (con,details) = unLoc $2 in
- (L (comb2 $1 $2) (mkConDeclH98 (fst $ unLoc $1)
+ (L (comb2 $1 $2) (mkConDeclH98 (noAnn, fst $ unLoc $1)
con
(snd $ unLoc $1)
Nothing -- No context
details))) }
-forall :: { Located ([AddEpAnn], Maybe [LHsTyVarBndr Specificity GhcPs]) }
- : 'forall' tv_bndrs '.' { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) }
- | {- empty -} { noLoc ([], Nothing) }
+forall :: { Located ((TokForall, EpToken "."), Maybe [LHsTyVarBndr Specificity GhcPs]) }
+ : 'forall' tv_bndrs '.' { sLL $1 $> ((epUniTok $1,epTok $3), Just $2) }
+ | {- empty -} { noLoc (noAnn, Nothing) }
constr_stuff :: { Located (LocatedN RdrName, HsConDeclH98Details GhcPs) }
: infixtype {% do { b <- runPV $1
@@ -2599,7 +2600,7 @@ fielddecl :: { LConDeclField GhcPs }
-- A list because of f,g :: Int
: sig_vars '::' ctype
{% amsA' (L (comb2 $1 $3)
- (ConDeclField [mu AnnDcolon $2]
+ (ConDeclField (epUniTok $2)
(reverse (map (\ln@(L l n)
-> L (fromTrailingN l) $ FieldOcc noExtField (L (noTrailingN l) n)) (unLoc $1))) $3 Nothing))}
@@ -2618,15 +2619,15 @@ derivings :: { Located (HsDeriving GhcPs) }
deriving :: { LHsDerivingClause GhcPs }
: 'deriving' deriv_clause_types
{% let { full_loc = comb2 $1 $> }
- in amsA' (L full_loc $ HsDerivingClause [mj AnnDeriving $1] Nothing $2) }
+ in amsA' (L full_loc $ HsDerivingClause (epTok $1) Nothing $2) }
| 'deriving' deriv_strategy_no_via deriv_clause_types
{% let { full_loc = comb2 $1 $> }
- in amsA' (L full_loc $ HsDerivingClause [mj AnnDeriving $1] (Just $2) $3) }
+ in amsA' (L full_loc $ HsDerivingClause (epTok $1) (Just $2) $3) }
| 'deriving' deriv_clause_types deriv_strategy_via
{% let { full_loc = comb2 $1 $> }
- in amsA' (L full_loc $ HsDerivingClause [mj AnnDeriving $1] (Just $3) $2) }
+ in amsA' (L full_loc $ HsDerivingClause (epTok $1) (Just $3) $2) }
deriv_clause_types :: { LDerivClauseTys GhcPs }
: qtycon { let { tc = sL1a $1 $ mkHsImplicitSigType $
@@ -2971,12 +2972,12 @@ prag_e :: { Located (HsPragE GhcPs) }
: '{-# SCC' STRING '#-}' {% do { scc <- getSCC $2
; return (sLL $1 $>
(HsPragSCC
- (AnnPragma (mo $1) (mc $3) [mj AnnValStr $2],
+ (AnnPragma (glR $1) (glR $3) noAnn (glR $2) noAnn noAnn noAnn,
(getSCC_PRAGs $1))
(StringLiteral (getSTRINGs $2) scc Nothing)))} }
| '{-# SCC' VARID '#-}' { sLL $1 $>
(HsPragSCC
- (AnnPragma (mo $1) (mc $3) [mj AnnVal $2],
+ (AnnPragma (glR $1) (glR $3) noAnn (glR $2) noAnn noAnn noAnn,
(getSCC_PRAGs $1))
(StringLiteral NoSourceText (getVARID $2) Nothing)) }
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -11,7 +11,7 @@ module GHC.Parser.Annotation (
AnnKeywordId(..),
EpToken(..), EpUniToken(..),
getEpTokenSrcSpan, getEpTokenLocs, getEpTokenLoc,
- TokDcolon, TokRarrow,
+ TokDcolon, TokDarrow, TokRarrow, TokForall,
EpLayout(..),
EpaComment(..), EpaCommentTok(..),
IsUnicodeSyntax(..),
@@ -410,8 +410,11 @@ getEpTokenLoc :: EpToken tok -> EpaLocation
getEpTokenLoc NoEpTok = noAnn
getEpTokenLoc (EpTok l) = l
+-- TODO:AZ: check we have all of the unicode tokens
type TokDcolon = EpUniToken "::" "∷"
+type TokDarrow = EpUniToken "=>" "⇒"
type TokRarrow = EpUniToken "->" "→"
+type TokForall = EpUniToken "forall" "∀"
-- | Layout information for declarations.
data EpLayout =
@@ -813,9 +816,13 @@ data NameAdornment
-- annotations in pragmas.
data AnnPragma
= AnnPragma {
- apr_open :: AddEpAnn,
- apr_close :: AddEpAnn,
- apr_rest :: [AddEpAnn]
+ apr_open :: EpaLocation,
+ apr_close :: EpaLocation,
+ apr_squares :: (EpToken "[", EpToken "]"),
+ apr_loc1 :: EpaLocation,
+ apr_loc2 :: EpaLocation,
+ apr_type :: EpToken "type",
+ apr_module :: EpToken "module"
} deriving (Data,Eq)
-- ---------------------------------------------------------------------
@@ -1402,7 +1409,7 @@ instance NoAnn NameAnn where
noAnn = NameAnnTrailing []
instance NoAnn AnnPragma where
- noAnn = AnnPragma noAnn noAnn []
+ noAnn = AnnPragma noAnn noAnn noAnn noAnn noAnn noAnn noAnn
instance NoAnn AnnParen where
noAnn = AnnParen AnnParens noAnn noAnn
@@ -1496,4 +1503,6 @@ instance Outputable AnnList where
= text "AnnList" <+> ppr a <+> ppr o <+> ppr c <+> ppr r <+> ppr t
instance Outputable AnnPragma where
- ppr (AnnPragma o c r) = text "AnnPragma" <+> ppr o <+> ppr c <+> ppr r
+ ppr (AnnPragma o c s l ca t m)
+ = text "AnnPragma" <+> ppr o <+> ppr c <+> ppr s <+> ppr l
+ <+> ppr ca <+> ppr ca <+> ppr t <+> ppr m
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -283,7 +283,7 @@ mkStandaloneKindSig
:: SrcSpan
-> Located [LocatedN RdrName] -- LHS
-> LHsSigType GhcPs -- RHS
- -> [AddEpAnn]
+ -> (EpToken "type", TokDcolon)
-> P (LStandaloneKindSig GhcPs)
mkStandaloneKindSig loc lhs rhs anns =
do { vs <- mapM check_lhs_name (unLoc lhs)
@@ -408,7 +408,7 @@ mkSpliceDecl lexpr@(L loc expr)
mkRoleAnnotDecl :: SrcSpan
-> LocatedN RdrName -- type being annotated
-> [Located (Maybe FastString)] -- roles
- -> [AddEpAnn]
+ -> (EpToken "type", EpToken "role")
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl loc tycon roles anns
= do { roles' <- mapM parse_role roles
@@ -773,12 +773,12 @@ recordPatSynErr loc pat =
addFatalError $ mkPlainErrorMsgEnvelope loc $
(PsErrRecordSyntaxInPatSynDecl pat)
-mkConDeclH98 :: [AddEpAnn] -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]
+mkConDeclH98 :: (TokDarrow, (TokForall, EpToken ".")) -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]
-> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs
-> ConDecl GhcPs
-mkConDeclH98 ann name mb_forall mb_cxt args
- = ConDeclH98 { con_ext = ann
+mkConDeclH98 (tdarrow, (tforall,tdot)) name mb_forall mb_cxt args
+ = ConDeclH98 { con_ext = AnnConDeclH98 tforall tdot tdarrow
, con_name = name
, con_forall = isJust mb_forall
, con_ex_tvs = mb_forall `orElse` []
@@ -795,12 +795,12 @@ mkConDeclH98 ann name mb_forall mb_cxt args
-- Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details.
mkGadtDecl :: SrcSpan
-> NonEmpty (LocatedN RdrName)
- -> EpUniToken "::" "∷"
+ -> TokDcolon
-> LHsSigType GhcPs
-> P (LConDecl GhcPs)
mkGadtDecl loc names dcol ty = do
- (args, res_ty, annsa, csa) <-
+ (args, res_ty, (ops, cps), csa) <-
case body_ty of
L ll (HsFunTy _ hsArr (L (EpAnn anc _ cs) (HsRecTy an rf)) res_ty) -> do
arr <- case hsArr of
@@ -810,10 +810,10 @@ mkGadtDecl loc names dcol ty = do
return noAnn
return ( RecConGADT arr (L (EpAnn anc an cs) rf), res_ty
- , [], epAnnComments ll)
+ , ([], []), epAnnComments ll)
_ -> do
- let (anns, cs, arg_types, res_type) = splitHsFunType body_ty
- return (PrefixConGADT noExtField arg_types, res_type, anns, cs)
+ let ((ops, cps), cs, arg_types, res_type) = splitHsFunType body_ty
+ return (PrefixConGADT noExtField arg_types, res_type, (ops,cps), cs)
let bndrs_loc = case outer_bndrs of
HsOuterImplicit{} -> getLoc ty
@@ -822,7 +822,7 @@ mkGadtDecl loc names dcol ty = do
let l = EpAnn (spanAsAnchor loc) noAnn csa
pure $ L l ConDeclGADT
- { con_g_ext = (dcol, annsa)
+ { con_g_ext = AnnConDeclGADT ops cps dcol
, con_names = names
, con_bndrs = L bndrs_loc outer_bndrs
, con_mb_cxt = mcxt
@@ -1079,9 +1079,7 @@ checkTyClHdr is_cls ty
| 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) = mkParensEpToks (realSrcSpan (locA l))
+ go cs l (HsParTy (o,c) ty) acc ops cps fix = goL (cs Semi.<> comments l) ty acc (o:ops) (c:cps) fix
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
@@ -1098,12 +1096,12 @@ checkTyClHdr is_cls ty
-- Combine the annotations from the HsParTy and HsStarTy into a
-- new one for the LocatedN RdrName
- newAnns :: SrcSpanAnnA -> SrcSpanAnnA -> AnnParen -> SrcSpanAnnN
- newAnns l@(EpAnn _ (AnnListItem _) csp0) l1@(EpAnn ap (AnnListItem ta) csp) (AnnParen _ o c) =
+ newAnns :: SrcSpanAnnA -> SrcSpanAnnA -> (EpToken "(", EpToken ")") -> SrcSpanAnnN
+ newAnns l@(EpAnn _ (AnnListItem _) csp0) l1@(EpAnn ap (AnnListItem ta) csp) (o,c) =
let
lr = combineSrcSpans (locA l1) (locA l)
in
- EpAnn (EpaSpan lr) (NameAnn NameParens o ap c ta) (csp0 Semi.<> csp)
+ EpAnn (EpaSpan lr) (NameAnn NameParens (getEpTokenLoc o) ap (getEpTokenLoc c) 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.
@@ -1171,9 +1169,9 @@ checkContext orig_t@(L (EpAnn l _ cs) _orig_t) =
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
- = check (ap_open ann':opi, ap_close ann':cpi, csi) ty
+ 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
-- No need for anns, returning original
check (_opi,_cpi,_csi) _t = unprocessed
@@ -3023,8 +3021,9 @@ checkNewOrData span name is_type_data = curry $ \ case
mkImport :: Located CCallConv
-> Located Safety
-> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)
- -> P ([AddEpAnn] -> HsDecl GhcPs)
-mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =
+ -> (EpToken "import", TokDcolon)
+ -> P (EpToken "foreign" -> HsDecl GhcPs)
+mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) (timport, td) =
case unLoc cconv of
CCallConv -> returnSpec =<< mkCImport
CApiConv -> do
@@ -3060,8 +3059,8 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =
funcTarget = CFunction (StaticTarget esrc entity' Nothing True)
importSpec = CImport (L (l2l loc) esrc) (reLoc cconv) (reLoc safety) Nothing funcTarget
- returnSpec spec = return $ \ann -> ForD noExtField $ ForeignImport
- { fd_i_ext = ann
+ returnSpec spec = return $ \tforeign -> ForD noExtField $ ForeignImport
+ { fd_i_ext = (tforeign, timport, td)
, fd_name = v
, fd_sig_ty = ty
, fd_fi = spec
@@ -3133,10 +3132,11 @@ parseCImport cconv safety nm str sourceText =
--
mkExport :: Located CCallConv
-> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)
- -> P ([AddEpAnn] -> HsDecl GhcPs)
-mkExport (L lc cconv) (L le (StringLiteral esrc entity _), v, ty)
- = return $ \ann -> ForD noExtField $
- ForeignExport { fd_e_ext = ann, fd_name = v, fd_sig_ty = ty
+ -> ( EpToken "export", TokDcolon)
+ -> P (EpToken "foreign" -> HsDecl GhcPs)
+mkExport (L lc cconv) (L le (StringLiteral esrc entity _), v, ty) (texport, td)
+ = return $ \tforeign -> ForD noExtField $
+ ForeignExport { fd_e_ext = (tforeign, texport, td), fd_name = v, fd_sig_ty = ty
, fd_fe = CExport (L (l2l le) esrc) (L (l2l lc) (CExportStatic esrc entity' cconv)) }
where
entity' | nullFS entity = mkExtName (unLoc v)
=====================================
testsuite/tests/ghc-api/exactprint/Test20239.stderr
=====================================
@@ -142,7 +142,10 @@
(EpaComments
[]))
(ConDeclH98
- []
+ (AnnConDeclH98
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpUniTok))
(L
(EpAnn
(EpaSpan { Test20239.hs:5:36-49 })
@@ -190,7 +193,10 @@
(EpaComments
[]))
(ConDeclH98
- []
+ (AnnConDeclH98
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpUniTok))
(L
(EpAnn
(EpaSpan { Test20239.hs:7:36-48 })
@@ -218,10 +224,11 @@
(EpaComments
[]))
(HsParTy
- (AnnParen
- AnnParens
- (EpaSpan { Test20239.hs:7:50 })
- (EpaSpan { Test20239.hs:7:86 }))
+ ((,)
+ (EpTok
+ (EpaSpan { Test20239.hs:7:50 }))
+ (EpTok
+ (EpaSpan { Test20239.hs:7:86 })))
(L
(EpAnn
(EpaSpan { Test20239.hs:7:51-85 })
@@ -290,10 +297,11 @@
(EpaComments
[]))
(HsParTy
- (AnnParen
- AnnParens
- (EpaSpan { Test20239.hs:7:68 })
- (EpaSpan { Test20239.hs:7:85 }))
+ ((,)
+ (EpTok
+ (EpaSpan { Test20239.hs:7:68 }))
+ (EpTok
+ (EpaSpan { Test20239.hs:7:85 })))
(L
(EpAnn
(EpaSpan { Test20239.hs:7:69-84 })
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
=====================================
@@ -972,8 +972,13 @@
(ClsInstDecl
((,,)
(Nothing)
- [(AddEpAnn AnnInstance (EpaSpan { T17544.hs:23:1-8 }))
- ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:23:17-21 }))]
+ (AnnClsInstDecl
+ (EpTok (EpaSpan { T17544.hs:23:1-8 }))
+ (EpTok
+ (EpaSpan { T17544.hs:23:17-21 }))
+ (NoEpTok)
+ []
+ (NoEpTok))
(NoAnnSortKey))
(L
(EpAnn
@@ -1110,11 +1115,12 @@
(EpaComments
[]))
(ConDeclGADT
- ((,)
+ (AnnConDeclGADT
+ []
+ []
(EpUniTok
(EpaSpan { T17544.hs:25:10-11 })
- (NormalSyntax))
- [])
+ (NormalSyntax)))
(:|
(L
(EpAnn
@@ -1348,8 +1354,13 @@
(ClsInstDecl
((,,)
(Nothing)
- [(AddEpAnn AnnInstance (EpaSpan { T17544.hs:29:1-8 }))
- ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:29:17-21 }))]
+ (AnnClsInstDecl
+ (EpTok (EpaSpan { T17544.hs:29:1-8 }))
+ (EpTok
+ (EpaSpan { T17544.hs:29:17-21 }))
+ (NoEpTok)
+ []
+ (NoEpTok))
(NoAnnSortKey))
(L
(EpAnn
@@ -1486,11 +1497,12 @@
(EpaComments
[]))
(ConDeclGADT
- ((,)
+ (AnnConDeclGADT
+ []
+ []
(EpUniTok
(EpaSpan { T17544.hs:31:10-11 })
- (NormalSyntax))
- [])
+ (NormalSyntax)))
(:|
(L
(EpAnn
@@ -1724,8 +1736,13 @@
(ClsInstDecl
((,,)
(Nothing)
- [(AddEpAnn AnnInstance (EpaSpan { T17544.hs:35:1-8 }))
- ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:35:17-21 }))]
+ (AnnClsInstDecl
+ (EpTok (EpaSpan { T17544.hs:35:1-8 }))
+ (EpTok
+ (EpaSpan { T17544.hs:35:17-21 }))
+ (NoEpTok)
+ []
+ (NoEpTok))
(NoAnnSortKey))
(L
(EpAnn
@@ -1862,11 +1879,12 @@
(EpaComments
[]))
(ConDeclGADT
- ((,)
+ (AnnConDeclGADT
+ []
+ []
(EpUniTok
(EpaSpan { T17544.hs:37:10-11 })
- (NormalSyntax))
- [])
+ (NormalSyntax)))
(:|
(L
(EpAnn
@@ -2100,8 +2118,13 @@
(ClsInstDecl
((,,)
(Nothing)
- [(AddEpAnn AnnInstance (EpaSpan { T17544.hs:41:1-8 }))
- ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:41:17-21 }))]
+ (AnnClsInstDecl
+ (EpTok (EpaSpan { T17544.hs:41:1-8 }))
+ (EpTok
+ (EpaSpan { T17544.hs:41:17-21 }))
+ (NoEpTok)
+ []
+ (NoEpTok))
(NoAnnSortKey))
(L
(EpAnn
@@ -2238,11 +2261,12 @@
(EpaComments
[]))
(ConDeclGADT
- ((,)
+ (AnnConDeclGADT
+ []
+ []
(EpUniTok
(EpaSpan { T17544.hs:43:10-11 })
- (NormalSyntax))
- [])
+ (NormalSyntax)))
(:|
(L
(EpAnn
@@ -2476,8 +2500,13 @@
(ClsInstDecl
((,,)
(Nothing)
- [(AddEpAnn AnnInstance (EpaSpan { T17544.hs:47:1-8 }))
- ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:47:17-21 }))]
+ (AnnClsInstDecl
+ (EpTok (EpaSpan { T17544.hs:47:1-8 }))
+ (EpTok
+ (EpaSpan { T17544.hs:47:17-21 }))
+ (NoEpTok)
+ []
+ (NoEpTok))
(NoAnnSortKey))
(L
(EpAnn
@@ -2614,11 +2643,12 @@
(EpaComments
[]))
(ConDeclGADT
- ((,)
+ (AnnConDeclGADT
+ []
+ []
(EpUniTok
(EpaSpan { T17544.hs:49:10-11 })
- (NormalSyntax))
- [])
+ (NormalSyntax)))
(:|
(L
(EpAnn
@@ -2852,8 +2882,13 @@
(ClsInstDecl
((,,)
(Nothing)
- [(AddEpAnn AnnInstance (EpaSpan { T17544.hs:53:1-8 }))
- ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:53:18-22 }))]
+ (AnnClsInstDecl
+ (EpTok (EpaSpan { T17544.hs:53:1-8 }))
+ (EpTok
+ (EpaSpan { T17544.hs:53:18-22 }))
+ (NoEpTok)
+ []
+ (NoEpTok))
(NoAnnSortKey))
(L
(EpAnn
@@ -2990,11 +3025,12 @@
(EpaComments
[]))
(ConDeclGADT
- ((,)
+ (AnnConDeclGADT
+ []
+ []
(EpUniTok
(EpaSpan { T17544.hs:55:11-12 })
- (NormalSyntax))
- [])
+ (NormalSyntax)))
(:|
(L
(EpAnn
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
=====================================
@@ -101,11 +101,12 @@
(EpaComments
[]))
(ConDeclGADT
- ((,)
+ (AnnConDeclGADT
+ []
+ []
(EpUniTok
(EpaSpan { T17544_kw.hs:16:15-16 })
- (NormalSyntax))
- [])
+ (NormalSyntax)))
(:|
(L
(EpAnn
@@ -214,11 +215,12 @@
(EpaComments
[]))
(ConDeclGADT
- ((,)
+ (AnnConDeclGADT
+ []
+ []
(EpUniTok
(EpaSpan { T17544_kw.hs:19:15-16 })
- (NormalSyntax))
- [])
+ (NormalSyntax)))
(:|
(L
(EpAnn
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr
=====================================
@@ -90,7 +90,10 @@
(EpaComments
[]))
(ConDeclH98
- []
+ (AnnConDeclH98
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpUniTok))
(L
(EpAnn
(EpaSpan { T24221.hs:5:5-8 })
@@ -151,7 +154,10 @@
(EpaComments
[]))
(ConDeclH98
- []
+ (AnnConDeclH98
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpUniTok))
(L
(EpAnn
(EpaSpan { T24221.hs:7:5-8 })
@@ -211,7 +217,10 @@
(EpaComments
[]))
(ConDeclH98
- []
+ (AnnConDeclH98
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpUniTok))
(L
(EpAnn
(EpaSpan { T24221.hs:9:9-10 })
@@ -339,7 +348,10 @@
(EpaComments
[]))
(ConDeclH98
- []
+ (AnnConDeclH98
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpUniTok))
(L
(EpAnn
(EpaSpan { T24221.hs:12:7-8 })
@@ -467,7 +479,10 @@
(EpaComments
[]))
(ConDeclH98
- []
+ (AnnConDeclH98
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpUniTok))
(L
(EpAnn
(EpaSpan { T24221.hs:16:3-4 })
@@ -637,7 +652,10 @@
(EpaComments
[]))
(ConDeclH98
- []
+ (AnnConDeclH98
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpUniTok))
(L
(EpAnn
(EpaSpan { T24221.hs:23:3-4 })
@@ -807,7 +825,10 @@
(EpaComments
[]))
(ConDeclH98
- []
+ (AnnConDeclH98
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpUniTok))
(L
(EpAnn
(EpaSpan { T24221.hs:28:3-8 })
@@ -844,7 +865,9 @@
(EpaComments
[]))
(ConDeclField
- [(AddEpAnn AnnDcolon (EpaSpan { T24221.hs:28:15-16 }))]
+ (EpUniTok
+ (EpaSpan { T24221.hs:28:15-16 })
+ (NormalSyntax))
[(L
(EpAnn
(EpaSpan { T24221.hs:28:12-13 })
@@ -903,7 +926,9 @@
(EpaComments
[]))
(ConDeclField
- [(AddEpAnn AnnDcolon (EpaSpan { T24221.hs:29:15-16 }))]
+ (EpUniTok
+ (EpaSpan { T24221.hs:29:15-16 })
+ (NormalSyntax))
[(L
(EpAnn
(EpaSpan { T24221.hs:29:12-13 })
@@ -1008,7 +1033,10 @@
(EpaComments
[]))
(ConDeclH98
- []
+ (AnnConDeclH98
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpUniTok))
(L
(EpAnn
(EpaSpan { T24221.hs:32:3-8 })
@@ -1045,7 +1073,9 @@
(EpaComments
[]))
(ConDeclField
- [(AddEpAnn AnnDcolon (EpaSpan { T24221.hs:33:10-11 }))]
+ (EpUniTok
+ (EpaSpan { T24221.hs:33:10-11 })
+ (NormalSyntax))
[(L
(EpAnn
(EpaSpan { T24221.hs:33:7-8 })
@@ -1104,7 +1134,9 @@
(EpaComments
[]))
(ConDeclField
- [(AddEpAnn AnnDcolon (EpaSpan { T24221.hs:34:10-11 }))]
+ (EpUniTok
+ (EpaSpan { T24221.hs:34:10-11 })
+ (NormalSyntax))
[(L
(EpAnn
(EpaSpan { T24221.hs:34:7-8 })
@@ -1221,7 +1253,10 @@
(EpaComments
[]))
(ConDeclH98
- []
+ (AnnConDeclH98
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpUniTok))
(L
(EpAnn
(EpaSpan { T24221.hs:38:3-8 })
@@ -1258,7 +1293,9 @@
(EpaComments
[]))
(ConDeclField
- [(AddEpAnn AnnDcolon (EpaSpan { T24221.hs:40:8-9 }))]
+ (EpUniTok
+ (EpaSpan { T24221.hs:40:8-9 })
+ (NormalSyntax))
[(L
(EpAnn
(EpaSpan { T24221.hs:40:5-6 })
@@ -1317,7 +1354,9 @@
(EpaComments
[]))
(ConDeclField
- [(AddEpAnn AnnDcolon (EpaSpan { T24221.hs:42:8-9 }))]
+ (EpUniTok
+ (EpaSpan { T24221.hs:42:8-9 })
+ (NormalSyntax))
[(L
(EpAnn
(EpaSpan { T24221.hs:42:5-6 })
=====================================
testsuite/tests/parser/should_compile/DumpParsedAst.stderr
=====================================
@@ -125,7 +125,10 @@
(EpaComments
[]))
(ConDeclH98
- []
+ (AnnConDeclH98
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpUniTok))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:7:14-17 })
@@ -150,7 +153,10 @@
(EpaComments
[]))
(ConDeclH98
- []
+ (AnnConDeclH98
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpUniTok))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:7:21-24 })
@@ -201,8 +207,12 @@
(KindSigD
(NoExtField)
(StandaloneKindSig
- [(AddEpAnn AnnType (EpaSpan { DumpParsedAst.hs:9:1-4 }))
- ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:9:13-14 }))]
+ ((,)
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:9:1-4 }))
+ (EpUniTok
+ (EpaSpan { DumpParsedAst.hs:9:13-14 })
+ (NormalSyntax)))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:9:6-11 })
@@ -352,10 +362,11 @@
(EpaComments
[]))
(HsParTy
- (AnnParen
- AnnParens
- (EpaSpan { DumpParsedAst.hs:11:10 })
- (EpaSpan { DumpParsedAst.hs:11:17 }))
+ ((,)
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:11:10 }))
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:11:17 })))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:11:11-16 })
@@ -450,10 +461,11 @@
(EpaComments
[]))
(HsParTy
- (AnnParen
- AnnParens
- (EpaSpan { DumpParsedAst.hs:11:26 })
- (EpaSpan { DumpParsedAst.hs:11:36 }))
+ ((,)
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:11:26 }))
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:11:36 })))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:11:27-35 })
@@ -794,7 +806,10 @@
(EpaComments
[]))
(ConDeclH98
- []
+ (AnnConDeclH98
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpUniTok))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:15:21-23 })
@@ -822,10 +837,11 @@
(EpaComments
[]))
(HsParTy
- (AnnParen
- AnnParens
- (EpaSpan { DumpParsedAst.hs:15:25 })
- (EpaSpan { DumpParsedAst.hs:15:29 }))
+ ((,)
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:15:25 }))
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:15:29 })))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:15:26-28 })
@@ -885,8 +901,12 @@
(KindSigD
(NoExtField)
(StandaloneKindSig
- [(AddEpAnn AnnType (EpaSpan { DumpParsedAst.hs:17:1-4 }))
- ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:17:9-10 }))]
+ ((,)
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:17:1-4 }))
+ (EpUniTok
+ (EpaSpan { DumpParsedAst.hs:17:9-10 })
+ (NormalSyntax)))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:17:6-7 })
@@ -960,10 +980,11 @@
(EpaComments
[]))
(HsParTy
- (AnnParen
- AnnParens
- (EpaSpan { DumpParsedAst.hs:17:17 })
- (EpaSpan { DumpParsedAst.hs:17:27 }))
+ ((,)
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:17:17 }))
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:17:27 })))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:17:18-26 })
@@ -1604,10 +1625,11 @@
(EpaComments
[]))
(HsParTy
- (AnnParen
- AnnParens
- (EpaSpan { DumpParsedAst.hs:22:22 })
- (EpaSpan { DumpParsedAst.hs:22:37 }))
+ ((,)
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:22:22 }))
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:22:37 })))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:22:23-36 })
@@ -1731,10 +1753,11 @@
(EpaComments
[]))
(HsParTy
- (AnnParen
- AnnParens
- (EpaSpan { DumpParsedAst.hs:22:42 })
- (EpaSpan { DumpParsedAst.hs:22:52 }))
+ ((,)
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:22:42 }))
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:22:52 })))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:22:43-51 })
@@ -1814,11 +1837,12 @@
(EpaComments
[]))
(ConDeclGADT
- ((,)
+ (AnnConDeclGADT
+ []
+ []
(EpUniTok
(EpaSpan { DumpParsedAst.hs:23:7-8 })
- (NormalSyntax))
- [])
+ (NormalSyntax)))
(:|
(L
(EpAnn
@@ -1855,10 +1879,11 @@
(EpaComments
[]))
(HsParTy
- (AnnParen
- AnnParens
- (EpaSpan { DumpParsedAst.hs:23:10 })
- (EpaSpan { DumpParsedAst.hs:23:34 }))
+ ((,)
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:23:10 }))
+ (EpTok
+ (EpaSpan { DumpParsedAst.hs:23:34 })))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:23:11-33 })
=====================================
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
=====================================
@@ -304,10 +304,9 @@
(EpaComments
[]))
(HsParTy
- (AnnParen
- AnnParens
- (EpaDelta { <no location info> } (SameLine 0) [])
- (EpaDelta { <no location info> } (SameLine 0) []))
+ ((,)
+ (NoEpTok)
+ (NoEpTok))
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:13:11-16 })
@@ -398,10 +397,9 @@
(EpaComments
[]))
(HsParTy
- (AnnParen
- AnnParens
- (EpaDelta { <no location info> } (SameLine 0) [])
- (EpaDelta { <no location info> } (SameLine 0) []))
+ ((,)
+ (NoEpTok)
+ (NoEpTok))
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:13:27-35 })
@@ -850,10 +848,9 @@
(EpaComments
[]))
(HsParTy
- (AnnParen
- AnnParens
- (EpaDelta { <no location info> } (SameLine 0) [])
- (EpaDelta { <no location info> } (SameLine 0) []))
+ ((,)
+ (NoEpTok)
+ (NoEpTok))
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:19:23-36 })
@@ -966,10 +963,9 @@
(EpaComments
[]))
(HsParTy
- (AnnParen
- AnnParens
- (EpaDelta { <no location info> } (SameLine 0) [])
- (EpaDelta { <no location info> } (SameLine 0) []))
+ ((,)
+ (NoEpTok)
+ (NoEpTok))
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:19:43-51 })
@@ -1079,10 +1075,9 @@
(EpaComments
[]))
(HsParTy
- (AnnParen
- AnnParens
- (EpaDelta { <no location info> } (SameLine 0) [])
- (EpaDelta { <no location info> } (SameLine 0) []))
+ ((,)
+ (NoEpTok)
+ (NoEpTok))
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:20:11-33 })
@@ -1452,10 +1447,9 @@
(EpaComments
[]))
(HsParTy
- (AnnParen
- AnnParens
- (EpaDelta { <no location info> } (SameLine 0) [])
- (EpaDelta { <no location info> } (SameLine 0) []))
+ ((,)
+ (NoEpTok)
+ (NoEpTok))
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:22:26-28 })
@@ -1955,10 +1949,9 @@
(EpaComments
[]))
(HsParTy
- (AnnParen
- AnnParens
- (EpaDelta { <no location info> } (SameLine 0) [])
- (EpaDelta { <no location info> } (SameLine 0) []))
+ ((,)
+ (NoEpTok)
+ (NoEpTok))
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:24:18-26 })
=====================================
testsuite/tests/parser/should_compile/KindSigs.stderr
=====================================
@@ -831,10 +831,11 @@
(EpaComments
[]))
(HsParTy
- (AnnParen
- AnnParens
- (EpaSpan { KindSigs.hs:22:8 })
- (EpaSpan { KindSigs.hs:22:20 }))
+ ((,)
+ (EpTok
+ (EpaSpan { KindSigs.hs:22:8 }))
+ (EpTok
+ (EpaSpan { KindSigs.hs:22:20 })))
(L
(EpAnn
(EpaSpan { KindSigs.hs:22:9-19 })
@@ -924,10 +925,11 @@
(EpaComments
[]))
(HsParTy
- (AnnParen
- AnnParens
- (EpaSpan { KindSigs.hs:22:33 })
- (EpaSpan { KindSigs.hs:22:44 }))
+ ((,)
+ (EpTok
+ (EpaSpan { KindSigs.hs:22:33 }))
+ (EpTok
+ (EpaSpan { KindSigs.hs:22:44 })))
(L
(EpAnn
(EpaSpan { KindSigs.hs:22:34-43 })
@@ -1643,10 +1645,11 @@
(EpaComments
[]))
(HsParTy
- (AnnParen
- AnnParens
- (EpaSpan { KindSigs.hs:34:9 })
- (EpaSpan { KindSigs.hs:34:22 }))
+ ((,)
+ (EpTok
+ (EpaSpan { KindSigs.hs:34:9 }))
+ (EpTok
+ (EpaSpan { KindSigs.hs:34:22 })))
(L
(EpAnn
(EpaSpan { KindSigs.hs:34:10-21 })
=====================================
testsuite/tests/parser/should_compile/T14189.stderr
=====================================
@@ -167,7 +167,7 @@
(EpaComments
[]))
(ConDeclField
- []
+ (NoEpUniTok)
[(L
(EpAnn
(EpaSpan { T14189.hs:6:33 })
=====================================
testsuite/tests/parser/should_compile/T15323.stderr
=====================================
@@ -116,11 +116,12 @@
(EpaComments
[]))
(ConDeclGADT
- ((,)
+ (AnnConDeclGADT
+ []
+ []
(EpUniTok
(EpaSpan { T15323.hs:6:17-18 })
- (NormalSyntax))
- [])
+ (NormalSyntax)))
(:|
(L
(EpAnn
@@ -196,10 +197,11 @@
(EpaComments
[]))
(HsParTy
- (AnnParen
- AnnParens
- (EpaSpan { T15323.hs:6:31 })
- (EpaSpan { T15323.hs:6:36 }))
+ ((,)
+ (EpTok
+ (EpaSpan { T15323.hs:6:31 }))
+ (EpTok
+ (EpaSpan { T15323.hs:6:36 })))
(L
(EpAnn
(EpaSpan { T15323.hs:6:32-35 })
=====================================
testsuite/tests/parser/should_compile/T20452.stderr
=====================================
@@ -137,7 +137,10 @@
(EpaComments
[]))
(ConDeclH98
- []
+ (AnnConDeclH98
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpUniTok))
(L
(EpAnn
(EpaSpan { T20452.hs:5:26-31 })
@@ -257,7 +260,10 @@
(EpaComments
[]))
(ConDeclH98
- []
+ (AnnConDeclH98
+ (NoEpUniTok)
+ (NoEpTok)
+ (NoEpUniTok))
(L
(EpAnn
(EpaSpan { T20452.hs:6:26-31 })
=====================================
testsuite/tests/printer/T18791.stderr
=====================================
@@ -89,11 +89,12 @@
(EpaComments
[]))
(ConDeclGADT
- ((,)
+ (AnnConDeclGADT
+ []
+ []
(EpUniTok
(EpaSpan { T18791.hs:5:7-8 })
- (NormalSyntax))
- [])
+ (NormalSyntax)))
(:|
(L
(EpAnn
=====================================
testsuite/tests/printer/Test24533.stdout
=====================================
@@ -57,7 +57,12 @@
(ClsInstDecl
((,,)
(Nothing)
- [(AddEpAnn AnnInstance (EpaSpan { Test24533.hs:4:1-8 }))]
+ (AnnClsInstDecl
+ (EpTok (EpaSpan { Test24533.hs:4:1-8 }))
+ (NoEpTok)
+ (NoEpTok)
+ []
+ (NoEpTok))
(NoAnnSortKey))
(L
(EpAnn
@@ -449,8 +454,13 @@
(ClsInstDecl
((,,)
(Nothing)
- [(AddEpAnn AnnInstance (EpaSpan { Test24533.hs:14:1-8 }))
- ,(AddEpAnn AnnWhere (EpaSpan { Test24533.hs:14:17-21 }))]
+ (AnnClsInstDecl
+ (EpTok (EpaSpan { Test24533.hs:14:1-8 }))
+ (EpTok
+ (EpaSpan { Test24533.hs:14:17-21 }))
+ (NoEpTok)
+ []
+ (NoEpTok))
(NoAnnSortKey))
(L
(EpAnn
@@ -717,7 +727,12 @@
(ClsInstDecl
((,,)
(Nothing)
- [(AddEpAnn AnnInstance (EpaSpan { Test24533.ppr.hs:3:1-8 }))]
+ (AnnClsInstDecl
+ (EpTok (EpaSpan { Test24533.ppr.hs:3:1-8 }))
+ (NoEpTok)
+ (NoEpTok)
+ []
+ (NoEpTok))
(NoAnnSortKey))
(L
(EpAnn
@@ -1036,8 +1051,13 @@
(ClsInstDecl
((,,)
(Nothing)
- [(AddEpAnn AnnInstance (EpaSpan { Test24533.ppr.hs:5:1-8 }))
- ,(AddEpAnn AnnWhere (EpaSpan { Test24533.ppr.hs:5:17-21 }))]
+ (AnnClsInstDecl
+ (EpTok (EpaSpan { Test24533.ppr.hs:5:1-8 }))
+ (EpTok
+ (EpaSpan { Test24533.ppr.hs:5:17-21 }))
+ (NoEpTok)
+ []
+ (NoEpTok))
(NoAnnSortKey))
(L
(EpAnn
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -63,7 +63,6 @@ import Data.Data ( Data )
import Data.Dynamic
import Data.Foldable
import Data.Functor.Const
-import qualified Data.Set as Set
import Data.Typeable
import Data.List ( partition, sort, sortBy)
import qualified Data.List.NonEmpty as NE
@@ -363,11 +362,11 @@ instance HasTrailing Bool where
trailing _ = []
setTrailing a _ = a
-instance HasTrailing (EpUniToken "forall" "∀", EpUniToken "->" "→") where
+instance HasTrailing (TokForall, EpUniToken "->" "→") where
trailing _ = []
setTrailing a _ = a
-instance HasTrailing (EpUniToken "forall" "∀", EpToken ".") where
+instance HasTrailing (TokForall, EpToken ".") where
trailing _ = []
setTrailing a _ = a
@@ -646,23 +645,6 @@ flushComments !trailing_anns = do
-- ---------------------------------------------------------------------
--- |In order to interleave annotations into the stream, we turn them into
--- comments. They are removed from the annotation to avoid duplication.
-annotationsToComments :: (Monad m, Monoid w)
- => a -> Lens a [AddEpAnn] -> [AnnKeywordId] -> EP w m a
-annotationsToComments a l kws = do
- let (newComments, newAnns) = go ([],[]) (view l a)
- addComments True newComments
- return (set l (reverse newAnns) a)
- where
- keywords = Set.fromList kws
-
- go :: ([Comment], [AddEpAnn]) -> [AddEpAnn] -> ([Comment], [AddEpAnn])
- go acc [] = acc
- go (cs',ans) ((AddEpAnn k ss) : ls)
- | Set.member k keywords = go ((mkKWComment k (epaToNoCommentsLocation ss)):cs', ans) ls
- | otherwise = go (cs', (AddEpAnn k ss):ans) ls
-
epTokensToComments :: (Monad m, Monoid w)
=> AnnKeywordId -> [EpToken tok] -> EP w m ()
epTokensToComments kw toks
@@ -825,10 +807,6 @@ markLensAA' a l = do
-- -------------------------------------
-markEpAnnLMS :: (Monad m, Monoid w)
- => EpAnn a -> Lens a [AddEpAnn] -> AnnKeywordId -> Maybe String -> EP w m (EpAnn a)
-markEpAnnLMS epann l kw ms = markEpAnnLMS'' epann (lepa . l) kw ms
-
markEpAnnLMS'' :: (Monad m, Monoid w)
=> a -> Lens a [AddEpAnn] -> AnnKeywordId -> Maybe String -> EP w m a
markEpAnnLMS'' an l kw Nothing = markEpAnnL an l kw
@@ -843,26 +821,6 @@ markEpAnnLMS'' a l kw (Just str) = do
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
-
-markEpAnnLMS0 :: (Monad m, Monoid w)
- => a -> Lens a AddEpAnn -> AnnKeywordId -> Maybe String -> EP w m a
-markEpAnnLMS0 an l _kw Nothing = markLensKwA an l
-markEpAnnLMS0 a l kw (Just str) = do
- anns <- go (view l a)
- return (set l anns a)
- 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)
-
-- ---------------------------------------------------------------------
-- markEpTokenM :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok)
@@ -912,19 +870,8 @@ markArrow (HsExplicitMult (pct, arr) t) = do
-- ---------------------------------------------------------------------
-markAnnCloseP :: (Monad m, Monoid w) => EpAnn AnnPragma -> EP w m (EpAnn AnnPragma)
-markAnnCloseP an = markEpAnnLMS' an lapr_close AnnClose (Just "#-}")
-
-markAnnCloseP' :: (Monad m, Monoid w) => AnnPragma -> EP w m AnnPragma
-markAnnCloseP' an = markEpAnnLMS0 an lapr_close AnnClose (Just "#-}")
-
-markAnnOpenP :: (Monad m, Monoid w) => EpAnn AnnPragma -> SourceText -> String -> EP w m (EpAnn AnnPragma)
-markAnnOpenP an NoSourceText txt = markEpAnnLMS' an lapr_open AnnOpen (Just txt)
-markAnnOpenP an (SourceText txt) _ = markEpAnnLMS' an lapr_open AnnOpen (Just $ unpackFS txt)
-
-markAnnOpenP' :: (Monad m, Monoid w) => AnnPragma -> SourceText -> String -> EP w m AnnPragma
-markAnnOpenP' an NoSourceText txt = markEpAnnLMS0 an lapr_open AnnOpen (Just txt)
-markAnnOpenP' an (SourceText txt) _ = markEpAnnLMS0 an lapr_open AnnOpen (Just $ unpackFS txt)
+markAnnCloseP'' :: (Monad m, Monoid w) => EpaLocation -> EP w m EpaLocation
+markAnnCloseP'' l = printStringAtAA l "#-}"
markAnnOpen' :: (Monad m, Monoid w)
=> Maybe EpaLocation -> SourceText -> String -> EP w m (Maybe EpaLocation)
@@ -1089,18 +1036,6 @@ lal_rest k parent = fmap (\new -> parent { al_rest = new })
-- -------------------------------------
-lapr_rest :: Lens AnnPragma [AddEpAnn]
-lapr_rest k parent = fmap (\newAnns -> parent { apr_rest = newAnns })
- (k (apr_rest parent))
-
-lapr_open :: Lens AnnPragma AddEpAnn
-lapr_open k parent = fmap (\new -> parent { apr_open = new })
- (k (apr_open parent))
-
-lapr_close :: Lens AnnPragma AddEpAnn
-lapr_close k parent = fmap (\new -> parent { apr_close = new })
- (k (apr_close parent))
-
lidl :: Lens [AddEpAnn] [AddEpAnn]
lidl k parent = fmap (\new -> new)
(k parent)
@@ -1340,12 +1275,6 @@ lepl_case k parent = fmap (\new -> parent { epl_case = new })
-- End of lenses
-- ---------------------------------------------------------------------
-markLensKwA :: (Monad m, Monoid w)
- => a -> Lens a AddEpAnn -> EP w m a
-markLensKwA a l = do
- loc <- markKw (view l a)
- return (set l loc a)
-
markLensKw' :: (Monad m, Monoid w)
=> EpAnn a -> Lens a EpaLocation -> AnnKeywordId -> EP w m (EpAnn a)
markLensKw' (EpAnn anc a cs) l kw = do
@@ -1785,22 +1714,22 @@ instance ExactPrint (LocatedP (WarningTxt GhcPs)) where
getAnnotationEntry = entryFromLocatedA
setAnnotationAnchor = setAnchorAn
- exact (L an (WarningTxt mb_cat src ws)) = do
- an0 <- markAnnOpenP an src "{-# WARNING"
+ exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (WarningTxt mb_cat src ws)) = do
+ o' <- markAnnOpen'' o src "{-# WARNING"
mb_cat' <- markAnnotated mb_cat
- an1 <- markEpAnnL' an0 lapr_rest AnnOpenS
+ os' <- markEpToken os
ws' <- markAnnotated ws
- an2 <- markEpAnnL' an1 lapr_rest AnnCloseS
- an3 <- markAnnCloseP an2
- return (L an3 (WarningTxt mb_cat' src ws'))
+ cs' <- markEpToken cs
+ c' <- printStringAtAA c "#-}"
+ return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (WarningTxt mb_cat' src ws'))
- exact (L an (DeprecatedTxt src ws)) = do
- an0 <- markAnnOpenP an src "{-# DEPRECATED"
- an1 <- markEpAnnL' an0 lapr_rest AnnOpenS
+ exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (DeprecatedTxt src ws)) = do
+ o' <- markAnnOpen'' o src "{-# DEPRECATED"
+ os' <- markEpToken os
ws' <- markAnnotated ws
- an2 <- markEpAnnL' an1 lapr_rest AnnCloseS
- an3 <- markAnnCloseP an2
- return (L an3 (DeprecatedTxt src ws'))
+ cs' <- markEpToken cs
+ c' <- printStringAtAA c "#-}"
+ return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (DeprecatedTxt src ws'))
instance ExactPrint InWarningCategory where
getAnnotationEntry _ = NoEntryVal
@@ -2057,14 +1986,14 @@ instance ExactPrint (DerivDecl GhcPs) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (DerivDecl (mw, an) typ ms mov) = do
- an0 <- markEpAnnL an lidl AnnDeriving
+ exact (DerivDecl (mw, (td,ti)) typ ms mov) = do
+ td' <- markEpToken td
ms' <- mapM markAnnotated ms
- an1 <- markEpAnnL an0 lidl AnnInstance
+ ti' <- markEpToken ti
mw' <- mapM markAnnotated mw
mov' <- mapM markAnnotated mov
typ' <- markAnnotated typ
- return (DerivDecl (mw', an1) typ' ms' mov')
+ return (DerivDecl (mw', (td',ti')) typ' ms' mov')
-- ---------------------------------------------------------------------
@@ -2072,25 +2001,25 @@ instance ExactPrint (ForeignDecl GhcPs) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (ForeignImport an n ty fimport) = do
- an0 <- markEpAnnL an lidl AnnForeign
- an1 <- markEpAnnL an0 lidl AnnImport
+ exact (ForeignImport (tf,ti,td) n ty fimport) = do
+ tf' <- markEpToken tf
+ ti' <- markEpToken ti
fimport' <- markAnnotated fimport
n' <- markAnnotated n
- an2 <- markEpAnnL an1 lidl AnnDcolon
+ td' <- markEpUniToken td
ty' <- markAnnotated ty
- return (ForeignImport an2 n' ty' fimport')
+ return (ForeignImport (tf',ti',td') n' ty' fimport')
- exact (ForeignExport an n ty fexport) = do
- an0 <- markEpAnnL an lidl AnnForeign
- an1 <- markEpAnnL an0 lidl AnnExport
+ exact (ForeignExport (tf,te,td) n ty fexport) = do
+ tf' <- markEpToken tf
+ te' <- markEpToken te
fexport' <- markAnnotated fexport
n' <- markAnnotated n
- an2 <- markEpAnnL an1 lidl AnnDcolon
+ td' <- markEpUniToken td
ty' <- markAnnotated ty
- return (ForeignExport an2 n' ty' fexport')
+ return (ForeignExport (tf',te',td') n' ty' fexport')
-- ---------------------------------------------------------------------
@@ -2162,24 +2091,22 @@ instance ExactPrint (WarnDecl GhcPs) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (Warning (ns_spec, an) lns (WarningTxt mb_cat src ls )) = do
+ exact (Warning (ns_spec, (o,c)) lns (WarningTxt mb_cat src ls )) = do
mb_cat' <- markAnnotated mb_cat
ns_spec' <- exactNsSpec ns_spec
lns' <- markAnnotated lns
- an0 <- markEpAnnL an lidl AnnOpenS -- "["
+ o' <- markEpToken o
ls' <- markAnnotated ls
- an1 <- markEpAnnL an0 lidl AnnCloseS -- "]"
- return (Warning (ns_spec', an1) lns' (WarningTxt mb_cat' src ls'))
- -- return (Warning an1 lns' (WarningTxt mb_cat' src ls'))
+ c' <- markEpToken c
+ return (Warning (ns_spec', (o',c')) lns' (WarningTxt mb_cat' src ls'))
- exact (Warning (ns_spec, an) lns (DeprecatedTxt src ls)) = do
+ exact (Warning (ns_spec, (o,c)) lns (DeprecatedTxt src ls)) = do
ns_spec' <- exactNsSpec ns_spec
lns' <- markAnnotated lns
- an0 <- markEpAnnL an lidl AnnOpenS -- "["
+ o' <- markEpToken o
ls' <- markAnnotated ls
- an1 <- markEpAnnL an0 lidl AnnCloseS -- "]"
- return (Warning (ns_spec', an1) lns' (DeprecatedTxt src ls'))
- -- return (Warning an1 lns' (DeprecatedTxt src ls'))
+ c' <- markEpToken c
+ return (Warning (ns_spec', (o',c')) lns' (DeprecatedTxt src ls'))
exactNsSpec :: (Monad m, Monoid w) => NamespaceSpecifier -> EP w m NamespaceSpecifier
exactNsSpec NoNamespaceSpecifier = pure NoNamespaceSpecifier
@@ -2306,9 +2233,9 @@ instance ExactPrint (RoleAnnotDecl GhcPs) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (RoleAnnotDecl an ltycon roles) = do
- an0 <- markEpAnnL an lidl AnnType
- an1 <- markEpAnnL an0 lidl AnnRole
+ exact (RoleAnnotDecl (tt,tr) ltycon roles) = do
+ tt' <- markEpToken tt
+ tr' <- markEpToken tr
ltycon' <- markAnnotated ltycon
let markRole (L l (Just r)) = do
(L l' r') <- markAnnotated (L l r)
@@ -2317,7 +2244,7 @@ instance ExactPrint (RoleAnnotDecl GhcPs) where
e' <- printStringAtAA (entry l) "_"
return (L (l { entry = e'}) Nothing)
roles' <- mapM markRole roles
- return (RoleAnnotDecl an1 ltycon' roles')
+ return (RoleAnnotDecl (tt',tr') ltycon' roles')
-- ---------------------------------------------------------------------
@@ -2437,28 +2364,28 @@ instance ExactPrint (ClsInstDecl GhcPs) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (ClsInstDecl { cid_ext = (mbWarn, an, sortKey)
+ exact (ClsInstDecl { cid_ext = (mbWarn, AnnClsInstDecl i w oc semis cc, sortKey)
, cid_poly_ty = inst_ty, cid_binds = binds
, cid_sigs = sigs, cid_tyfam_insts = ats
, cid_overlap_mode = mbOverlap
, cid_datafam_insts = adts })
= do
- (mbWarn', an0, mbOverlap', inst_ty') <- top_matter
- an1 <- markEpAnnL an0 lidl AnnOpenC
- an2 <- markEpAnnAllL' an1 lid AnnSemi
+ (mbWarn', i', w', mbOverlap', inst_ty') <- top_matter
+ oc' <- markEpToken oc
+ semis' <- mapM markEpToken semis
(sortKey', ds) <- withSortKey sortKey
[(ClsAtTag, prepareListAnnotationA ats),
(ClsAtdTag, prepareListAnnotationF adts),
(ClsMethodTag, prepareListAnnotationA binds),
(ClsSigTag, prepareListAnnotationA sigs)
]
- an3 <- markEpAnnL an2 lidl AnnCloseC -- '}'
+ cc' <- markEpToken cc
let
ats' = undynamic ds
adts' = undynamic ds
binds' = undynamic ds
sigs' = undynamic ds
- return (ClsInstDecl { cid_ext = (mbWarn', an3, sortKey')
+ return (ClsInstDecl { cid_ext = (mbWarn', AnnClsInstDecl i' w' oc' semis' cc', sortKey')
, cid_poly_ty = inst_ty', cid_binds = binds'
, cid_sigs = sigs', cid_tyfam_insts = ats'
, cid_overlap_mode = mbOverlap'
@@ -2466,12 +2393,12 @@ instance ExactPrint (ClsInstDecl GhcPs) where
where
top_matter = do
- an0 <- markEpAnnL an lidl AnnInstance
+ i' <- markEpToken i
mw <- mapM markAnnotated mbWarn
mo <- mapM markAnnotated mbOverlap
it <- markAnnotated inst_ty
- an1 <- markEpAnnL an0 lidl AnnWhere -- Optional
- return (mw, an1, mo,it)
+ w' <- markEpToken w -- Optional
+ return (mw, i', w', mo,it)
-- ---------------------------------------------------------------------
@@ -2492,35 +2419,35 @@ instance ExactPrint (LocatedP OverlapMode) where
setAnnotationAnchor = setAnchorAn
-- NOTE: NoOverlap is only used in the typechecker
- exact (L an (NoOverlap src)) = do
- an0 <- markAnnOpenP an src "{-# NO_OVERLAP"
- an1 <- markAnnCloseP an0
- return (L an1 (NoOverlap src))
+ exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (NoOverlap src)) = do
+ o' <- markAnnOpen'' o src "{-# NO_OVERLAP"
+ c' <- markAnnCloseP'' c
+ return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (NoOverlap src))
- exact (L an (Overlappable src)) = do
- an0 <- markAnnOpenP an src "{-# OVERLAPPABLE"
- an1 <- markAnnCloseP an0
- return (L an1 (Overlappable src))
+ exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Overlappable src)) = do
+ o' <- markAnnOpen'' o src "{-# OVERLAPPABLE"
+ c' <- markAnnCloseP'' c
+ return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Overlappable src))
- exact (L an (Overlapping src)) = do
- an0 <- markAnnOpenP an src "{-# OVERLAPPING"
- an1 <- markAnnCloseP an0
- return (L an1 (Overlapping src))
+ exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Overlapping src)) = do
+ o' <- markAnnOpen'' o src "{-# OVERLAPPING"
+ c' <- markAnnCloseP'' c
+ return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Overlapping src))
- exact (L an (Overlaps src)) = do
- an0 <- markAnnOpenP an src "{-# OVERLAPS"
- an1 <- markAnnCloseP an0
- return (L an1 (Overlaps src))
+ exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Overlaps src)) = do
+ o' <- markAnnOpen'' o src "{-# OVERLAPS"
+ c' <- markAnnCloseP'' c
+ return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Overlaps src))
- exact (L an (Incoherent src)) = do
- an0 <- markAnnOpenP an src "{-# INCOHERENT"
- an1 <- markAnnCloseP an0
- return (L an1 (Incoherent src))
+ exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Incoherent src)) = do
+ o' <- markAnnOpen'' o src "{-# INCOHERENT"
+ c' <- markAnnCloseP'' c
+ return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Incoherent src))
- exact (L an (NonCanonical src)) = do
- an0 <- markAnnOpenP an src "{-# INCOHERENT"
- an1 <- markAnnCloseP an0
- return (L an1 (Incoherent src))
+ exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (NonCanonical src)) = do
+ o' <- markAnnOpen'' o src "{-# INCOHERENT"
+ c' <- markAnnCloseP'' c
+ return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Incoherent src))
-- ---------------------------------------------------------------------
@@ -2962,12 +2889,12 @@ instance ExactPrint (StandaloneKindSig GhcPs) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (StandaloneKindSig an vars sig) = do
- an0 <- markEpAnnL an lidl AnnType
+ exact (StandaloneKindSig (tt,td) vars sig) = do
+ tt' <- markEpToken tt
vars' <- markAnnotated vars
- an1 <- markEpAnnL an0 lidl AnnDcolon
+ td' <- markEpUniToken td
sig' <- markAnnotated sig
- return (StandaloneKindSig an1 vars' sig')
+ return (StandaloneKindSig (tt',td') vars' sig')
-- ---------------------------------------------------------------------
@@ -2989,24 +2916,24 @@ instance ExactPrint (AnnDecl GhcPs) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (HsAnnotation (an, src) prov e) = do
- an0 <- markAnnOpenP' an src "{-# ANN"
- (an1, prov') <-
+ exact (HsAnnotation (AnnPragma o c s l1 l2 t m, src) prov e) = do
+ o' <- markAnnOpen'' o src "{-# ANN"
+ (t', m', prov') <-
case prov of
(ValueAnnProvenance n) -> do
n' <- markAnnotated n
- return (an0, ValueAnnProvenance n')
+ return (t, m, ValueAnnProvenance n')
(TypeAnnProvenance n) -> do
- an1 <- markEpAnnL an0 lapr_rest AnnType
+ t' <- markEpToken t
n' <- markAnnotated n
- return (an1, TypeAnnProvenance n')
+ return (t', m, TypeAnnProvenance n')
ModuleAnnProvenance -> do
- an1 <- markEpAnnL an0 lapr_rest AnnModule
- return (an1, prov)
+ m' <- markEpToken m
+ return (t, m', prov)
e' <- markAnnotated e
- an2 <- markAnnCloseP' an1
- return (HsAnnotation (an2,src) prov' e')
+ c' <- printStringAtAA c "#-}"
+ return (HsAnnotation (AnnPragma o' c' s l1 l2 t' m',src) prov' e')
-- ---------------------------------------------------------------------
@@ -3418,13 +3345,11 @@ instance ExactPrint (HsPragE GhcPs) where
getAnnotationEntry HsPragSCC{} = NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (HsPragSCC (an,st) sl) = do
- an0 <- markAnnOpenP' an st "{-# SCC"
- let txt = sourceTextToString (sl_st sl) (unpackFS $ sl_fs sl)
- an1 <- markEpAnnLMS'' an0 lapr_rest AnnVal (Just txt) -- optional
- an2 <- markEpAnnLMS'' an1 lapr_rest AnnValStr (Just txt) -- optional
- an3 <- markAnnCloseP' an2
- return (HsPragSCC (an3,st) sl)
+ exact (HsPragSCC (AnnPragma o c s l1 l2 t m,st) sl) = do
+ o' <- markAnnOpen'' o st "{-# SCC"
+ l1' <- printStringAtAA l1 (sourceTextToString (sl_st sl) (unpackFS $ sl_fs sl))
+ c' <- printStringAtAA c "#-}"
+ return (HsPragSCC (AnnPragma o' c' s l1' l2 t m,st) sl)
-- ---------------------------------------------------------------------
@@ -4178,11 +4103,11 @@ instance ExactPrint (HsType GhcPs) where
lo' <- markAnnotated lo
t2' <- markAnnotated t2
return (HsOpTy x promoted t1' lo' t2')
- exact (HsParTy an ty) = do
- an0 <- markOpeningParen an
+ exact (HsParTy (o,c) ty) = do
+ o' <- markEpToken o
ty' <- markAnnotated ty
- an1 <- markClosingParen an0
- return (HsParTy an1 ty')
+ c' <- markEpToken c
+ return (HsParTy (o',c') ty')
exact (HsIParamTy an n t) = do
n' <- markAnnotated n
an0 <- markEpUniToken an
@@ -4273,7 +4198,7 @@ instance ExactPrint (HsDerivingClause GhcPs) where
exact (HsDerivingClause { deriv_clause_ext = an
, deriv_clause_strategy = dcs
, deriv_clause_tys = dct }) = do
- an0 <- markEpAnnL an lidl AnnDeriving
+ an0 <- markEpToken an
dcs0 <- case dcs of
Just (L _ ViaStrategy{}) -> return dcs
_ -> mapM markAnnotated dcs
@@ -4292,16 +4217,16 @@ instance ExactPrint (DerivStrategy GhcPs) where
setAnnotationAnchor a _ _ _ = a
exact (StockStrategy an) = do
- an0 <- markEpAnnL an lid AnnStock
+ an0 <- markEpToken an
return (StockStrategy an0)
exact (AnyclassStrategy an) = do
- an0 <- markEpAnnL an lid AnnAnyclass
+ an0 <- markEpToken an
return (AnyclassStrategy an0)
exact (NewtypeStrategy an) = do
- an0 <- markEpAnnL an lid AnnNewtype
+ an0 <- markEpToken an
return (NewtypeStrategy an0)
exact (ViaStrategy (XViaStrategyPs an ty)) = do
- an0 <- markEpAnnL an lid AnnVia
+ an0 <- markEpToken an
ty' <- markAnnotated ty
return (ViaStrategy (XViaStrategyPs an0 ty'))
@@ -4468,27 +4393,27 @@ instance ExactPrint (ConDecl GhcPs) where
setAnnotationAnchor a _ _ _ = a
-- based on pprConDecl
- exact (ConDeclH98 { con_ext = an
+ exact (ConDeclH98 { con_ext = AnnConDeclH98 tforall tdot tdarrow
, con_name = con
, con_forall = has_forall
, con_ex_tvs = ex_tvs
, con_mb_cxt = mcxt
, con_args = args
, con_doc = doc }) = do
- an0 <- if has_forall
- then markEpAnnL an lidl AnnForall
- else return an
+ tforall' <- if has_forall
+ then markEpUniToken tforall
+ else return tforall
ex_tvs' <- mapM markAnnotated ex_tvs
- an1 <- if has_forall
- then markEpAnnL an0 lidl AnnDot
- else return an0
+ tdot' <- if has_forall
+ then markEpToken tdot
+ else return tdot
mcxt' <- mapM markAnnotated mcxt
- an2 <- if (isJust mcxt)
- then markEpAnnL an1 lidl AnnDarrow
- else return an1
+ tdarrow' <- if (isJust mcxt)
+ then markEpUniToken tdarrow
+ else return tdarrow
(con', args') <- exact_details args
- return (ConDeclH98 { con_ext = an2
+ return (ConDeclH98 { con_ext = AnnConDeclH98 tforall' tdot' tdarrow'
, con_name = con'
, con_forall = has_forall
, con_ex_tvs = ex_tvs'
@@ -4516,14 +4441,15 @@ instance ExactPrint (ConDecl GhcPs) where
-- -----------------------------------
- exact (ConDeclGADT { con_g_ext = (dcol, an)
+ exact (ConDeclGADT { con_g_ext = AnnConDeclGADT ops cps dcol
, con_names = cons
, con_bndrs = bndrs
, con_mb_cxt = mcxt, con_g_args = args
, con_res_ty = res_ty, con_doc = doc }) = do
cons' <- mapM markAnnotated cons
dcol' <- markEpUniToken dcol
- an1 <- annotationsToComments an lidl [AnnOpenP, AnnCloseP]
+ epTokensToComments AnnOpenP ops
+ epTokensToComments AnnCloseP cps
-- Work around https://gitlab.haskell.org/ghc/ghc/-/issues/20558
bndrs' <- case bndrs of
@@ -4531,9 +4457,6 @@ instance ExactPrint (ConDecl GhcPs) where
_ -> markAnnotated bndrs
mcxt' <- mapM markAnnotated mcxt
- an2 <- if (isJust mcxt)
- then markEpAnnL an1 lidl AnnDarrow
- else return an1
args' <-
case args of
(PrefixConGADT x args0) -> do
@@ -4544,7 +4467,7 @@ instance ExactPrint (ConDecl GhcPs) where
rarr' <- markEpUniToken rarr
return (RecConGADT rarr' fields')
res_ty' <- markAnnotated res_ty
- return (ConDeclGADT { con_g_ext = (dcol', an2)
+ return (ConDeclGADT { con_g_ext = AnnConDeclGADT [] [] dcol'
, con_names = cons'
, con_bndrs = bndrs'
, con_mb_cxt = mcxt', con_g_args = args'
@@ -4579,11 +4502,11 @@ instance ExactPrint (ConDeclField GhcPs) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (ConDeclField an names ftype mdoc) = do
+ exact (ConDeclField td names ftype mdoc) = do
names' <- markAnnotated names
- an0 <- markEpAnnL an lidl AnnDcolon
+ td' <- markEpUniToken td
ftype' <- markAnnotated ftype
- return (ConDeclField an0 names' ftype' mdoc)
+ return (ConDeclField td' names' ftype' mdoc)
-- ---------------------------------------------------------------------
@@ -4610,15 +4533,15 @@ instance ExactPrint (LocatedP CType) where
getAnnotationEntry = entryFromLocatedA
setAnnotationAnchor = setAnchorAn
- exact (L an (CType stp mh (stct,ct))) = do
- an0 <- markAnnOpenP an stp "{-# CTYPE"
- an1 <- case mh of
- Nothing -> return an0
+ exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (CType stp mh (stct,ct))) = do
+ o' <- markAnnOpen'' o stp "{-# CTYPE"
+ l1' <- case mh of
+ Nothing -> return l1
Just (Header srcH _h) ->
- markEpAnnLMS an0 lapr_rest AnnHeader (Just (toSourceTextWithSuffix srcH "" ""))
- an2 <- markEpAnnLMS an1 lapr_rest AnnVal (Just (toSourceTextWithSuffix stct (unpackFS ct) ""))
- an3 <- markAnnCloseP an2
- return (L an3 (CType stp mh (stct,ct)))
+ printStringAtAA l1 (toSourceTextWithSuffix srcH "" "")
+ l2' <- printStringAtAA l2 (toSourceTextWithSuffix stct (unpackFS ct) "")
+ c' <- printStringAtAA c "#-}"
+ return (L (EpAnn l (AnnPragma o' c' s l1' l2' t m) cs) (CType stp mh (stct,ct)))
-- ---------------------------------------------------------------------
=====================================
utils/check-exact/Main.hs
=====================================
@@ -105,7 +105,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/printer/Ppr012.hs" Nothing
-- "../../testsuite/tests/printer/Ppr013.hs" Nothing
-- "../../testsuite/tests/printer/Ppr014.hs" Nothing
- -- "../../testsuite/tests/printer/Ppr015.hs" Nothing
+ "../../testsuite/tests/printer/Ppr015.hs" Nothing
-- "../../testsuite/tests/printer/Ppr016.hs" Nothing
-- "../../testsuite/tests/printer/Ppr017.hs" Nothing
-- "../../testsuite/tests/printer/Ppr018.hs" Nothing
@@ -212,7 +212,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/printer/Test21355.hs" Nothing
-- "../../testsuite/tests/printer/Test22765.hs" Nothing
-- "../../testsuite/tests/printer/Test22771.hs" Nothing
- "../../testsuite/tests/printer/Test23465.hs" Nothing
+ -- "../../testsuite/tests/printer/Test23465.hs" Nothing
-- cloneT does not need a test, function can be retired
=====================================
utils/haddock/haddock-api/src/Haddock/Types.hs
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
@@ -820,7 +821,7 @@ type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA
type instance Anno (HsSigType DocNameI) = SrcSpanAnnA
type XRecCond a =
- ( XParTy a ~ AnnParen
+ ( XParTy a ~ (EpToken "(", EpToken ")")
, NoGhcTc a ~ a
, MapXRec a
, UnXRec a
@@ -852,7 +853,7 @@ type instance XListTy DocNameI = EpAnn AnnParen
type instance XTupleTy DocNameI = EpAnn AnnParen
type instance XSumTy DocNameI = EpAnn AnnParen
type instance XOpTy DocNameI = EpAnn [AddEpAnn]
-type instance XParTy DocNameI = AnnParen
+type instance XParTy DocNameI = (EpToken "(", EpToken ")")
type instance XIParamTy DocNameI = EpAnn [AddEpAnn]
type instance XKindSig DocNameI = EpAnn [AddEpAnn]
type instance XSpliceTy DocNameI = DataConCantHappen
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c8601c77ecd1abfe94eca65d619324e6bc9b2bd4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c8601c77ecd1abfe94eca65d619324e6bc9b2bd4
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/20241020/a4fd7d14/attachment-0001.html>
More information about the ghc-commits
mailing list