[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: EPA: Remove [AddEpAnn] Commit 5
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Oct 21 15:14:19 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
7f61ed4e by Alan Zimmerman at 2024-10-21T06:39:45-04: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
- - - - -
f8694fe7 by Cheng Shao at 2024-10-21T06:40:21-04:00
wasm: bump dyld v8 heap size limit
This patch adds `--max-old-space-size=8192` to wasm dyld shebang
arguments to bump V8 heap size limit. The default limit
(`heap_size_limit` returned by `v8.getHeapStatistics()`) is
dynamically determined and a bit too low under certain workloads, and
V8 would waste too much CPU time to garbage collect old generation
heap more aggressively. Bumping the limit to 8G doesn't imply dyld
would really take that much memory at run-time, but it lessens V8 heap
stress significantly.
- - - - -
bad6a849 by Andrzej Rybczak at 2024-10-21T11:13:40-04:00
Adjust catches to properly rethrow exceptions
https://gitlab.haskell.org/ghc/ghc/-/merge_requests/13302 implemented exception
rethrowing proposal, but it didn't adjust `catches`. This fixes it.
- - - - -
46c8e121 by Cheng Shao at 2024-10-21T11:13:41-04:00
hadrian: fix bindist executable wrapper logic for cross targets
This commit fixes an oversight of hadrian wrapper generation logic:
when doing cross compilation, `wrapper` is called on executable names
with cross prefix, therefore we must use `isSuffixOf` when matching to
take the cross prefix into account. Also add missing cross prefix to
ghci wrapper content.
- - - - -
25 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
- hadrian/src/Rules/BinaryDist.hs
- libraries/ghc-internal/src/GHC/Internal/Control/Exception.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
- utils/jsffi/dyld.mjs
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)
=====================================
hadrian/src/Rules/BinaryDist.hs
=====================================
@@ -437,13 +437,14 @@ pkgToWrappers pkg = do
| otherwise -> pure []
wrapper :: FilePath -> Action String
-wrapper "ghc" = ghcWrapper
-wrapper "ghc-pkg" = ghcPkgWrapper
-wrapper "ghci" = ghciScriptWrapper
-wrapper "haddock" = haddockWrapper
-wrapper "hsc2hs" = hsc2hsWrapper
-wrapper "runghc" = runGhcWrapper
-wrapper "runhaskell" = runGhcWrapper
+wrapper wrapper_name
+ | "runghc" `isSuffixOf` wrapper_name = runGhcWrapper
+ | "ghc" `isSuffixOf` wrapper_name = ghcWrapper
+ | "ghc-pkg" `isSuffixOf` wrapper_name = ghcPkgWrapper
+ | "ghci" `isSuffixOf` wrapper_name = ghciScriptWrapper
+ | "haddock" `isSuffixOf` wrapper_name = haddockWrapper
+ | "hsc2hs" `isSuffixOf` wrapper_name = hsc2hsWrapper
+ | "runhaskell" `isSuffixOf` wrapper_name = runGhcWrapper
wrapper _ = commonWrapper
-- | Wrapper scripts for different programs. Common is default wrapper.
@@ -473,9 +474,10 @@ runGhcWrapper = pure $ "exec \"$executablename\" -f \"$exedir/ghc\" ${1+\"$@\"}\
-- | --interactive flag.
ghciScriptWrapper :: Action String
ghciScriptWrapper = do
+ prefix <- crossPrefix
version <- setting ProjectVersion
pure $ unlines
- [ "executable=\"$bindir/ghc-" ++ version ++ "\""
+ [ "executable=\"$bindir/" ++ prefix ++ "ghc-" ++ version ++ "\""
, "exec $executable --interactive \"$@\"" ]
-- | When not on Windows, we want to ship the 3 flavours of the iserv program
@@ -548,4 +550,3 @@ createGhcii outDir = do
[ "#!/bin/sh"
, "exec \"$(dirname \"$0\")\"/ghc --interactive \"$@\""
]
-
=====================================
libraries/ghc-internal/src/GHC/Internal/Control/Exception.hs
=====================================
@@ -119,6 +119,7 @@ module GHC.Internal.Control.Exception (
) where
import GHC.Internal.Control.Exception.Base
+import GHC.Internal.Exception.Type (ExceptionWithContext(..), whileHandling)
import GHC.Internal.Base
import GHC.Internal.IO (interruptible)
@@ -149,13 +150,15 @@ Instead, we provide a function 'catches', which would be used thus:
> Handler (\ (ex :: IOException) -> handleIO ex)]
-}
catches :: IO a -> [Handler a] -> IO a
-catches io handlers = io `catch` catchesHandler handlers
-
-catchesHandler :: [Handler a] -> SomeException -> IO a
-catchesHandler handlers e = foldr tryHandler (throw e) handlers
- where tryHandler (Handler handler) res
- = case fromException e of
- Just e' -> handler e'
+catches io handlers = io `catchNoPropagate` catchesHandler handlers
+
+catchesHandler :: [Handler a] -> ExceptionWithContext SomeException -> IO a
+catchesHandler handlers ec@(ExceptionWithContext _ e) =
+ foldr tryHandler (rethrowIO ec) handlers
+ where
+ tryHandler (Handler handler) res =
+ case fromException e of
+ Just e' -> annotateIO (whileHandling ec) (handler e')
Nothing -> res
-- -----------------------------------------------------------------------------
=====================================
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
=====================================
utils/jsffi/dyld.mjs
=====================================
@@ -1,4 +1,4 @@
-#!/usr/bin/env -S node --disable-warning=ExperimentalWarning --experimental-wasm-type-reflection --no-turbo-fast-api-calls --wasm-lazy-validation
+#!/usr/bin/env -S node --disable-warning=ExperimentalWarning --experimental-wasm-type-reflection --max-old-space-size=8192 --no-turbo-fast-api-calls --wasm-lazy-validation
// Note [The Wasm Dynamic Linker]
// ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e54f034315b461c03d8fb2cbf41ca29208df04c0...46c8e121fa45e250b214eaf1fbef2818d1f15e05
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e54f034315b461c03d8fb2cbf41ca29208df04c0...46c8e121fa45e250b214eaf1fbef2818d1f15e05
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/20241021/ed4c054f/attachment-0001.html>
More information about the ghc-commits
mailing list