From 81fb8885819c63e926376019b14cf994e88a167c Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Wed, 11 Oct 2023 19:24:07 +0100
Subject: [PATCH] EPA: Use full range for Anchor
This change requires a series of related changes, which must all land
at the same time, otherwise all the EPA tests break.
* Use the current Anchor end as prior end
Use the original anchor location end as the source of truth for
calculating print deltas.
This allows original spacing to apply in most cases, only changed
AST items need initial delta positions.
* Add DArrow to TrailingAnn
* EPA Introduce HasTrailing in ExactPrint
Use [TrailingAnn] in enterAnn and remove it from
ExactPrint (LocatedN RdrName)
* In HsDo, put TrailingAnns at top of LastStmt
* EPA: do not convert comments to deltas when balancing.
* EPA: deal with fallout from getMonoBind
* EPA fix captureLineSpacing
* EPA print any comments in the span before exiting it
* EPA: Add comments to AnchorOperation
* EPA: remove AnnEofComment, it is no longer used
Updates Haddock submodule
---
compiler/GHC/Hs/Type.hs | 4 +-
compiler/GHC/Hs/Utils.hs | 9 +-
compiler/GHC/Iface/Ext/Ast.hs | 7 +-
compiler/GHC/Parser.y | 218 ++--
compiler/GHC/Parser/Annotation.hs | 87 +-
compiler/GHC/ThToHs.hs | 2 +-
.../driver/recompChangedPackage/q/q.cabal | 2 +-
.../ghc-api/exactprint/AddDecl1.expected.hs | 4 +-
.../tests/ghc-api/exactprint/Test20239.stderr | 10 +-
.../should_compile_flag_haddock/T17544.stderr | 32 +-
.../T17544_kw.stderr | 6 +-
.../should_compile/DumpParsedAst.stderr | 46 +-
.../should_compile/DumpRenamedAst.stderr | 32 +-
.../parser/should_compile/DumpSemis.stderr | 20 +-
.../parser/should_compile/KindSigs.stderr | 60 +-
.../tests/parser/should_compile/T14189.stderr | 2 +-
.../tests/parser/should_compile/T15323.stderr | 8 +-
.../tests/parser/should_compile/T20452.stderr | 8 +-
.../tests/parser/should_compile/T20846.stderr | 4 +-
.../should_compile/T23315/T23315.stderr | 6 +-
utils/check-exact/ExactPrint.hs | 952 +++++++++++-------
utils/check-exact/Main.hs | 61 +-
utils/check-exact/Preprocess.hs | 9 +-
utils/check-exact/Transform.hs | 351 ++++---
utils/check-exact/Utils.hs | 98 +-
utils/haddock | 2 +-
26 files changed, 1182 insertions(+), 858 deletions(-)
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index 3bbf6d82dddf..d158f967847b 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -1438,5 +1438,5 @@ type instance Anno (HsOuterTyVarBndrs _ (GhcPass _)) = SrcSpanAnnA
type instance Anno HsIPName = SrcAnn NoEpAnns
type instance Anno (ConDeclField (GhcPass p)) = SrcSpanAnnA
-type instance Anno (FieldOcc (GhcPass p)) = SrcAnn NoEpAnns
-type instance Anno (AmbiguousFieldOcc (GhcPass p)) = SrcAnn NoEpAnns
+type instance Anno (FieldOcc (GhcPass p)) = SrcSpanAnnA
+type instance Anno (AmbiguousFieldOcc (GhcPass p)) = SrcSpanAnnA
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 6f1d0d71a85d..efb5ffff7b94 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -387,10 +387,13 @@ mkHsIsString src s = OverLit noExtField (HsIsString src s)
mkHsDo ctxt stmts = HsDo noAnn ctxt stmts
mkHsDoAnns ctxt stmts anns = HsDo anns ctxt stmts
mkHsComp ctxt stmts expr = mkHsCompAnns ctxt stmts expr noAnn
-mkHsCompAnns ctxt stmts expr anns = mkHsDoAnns ctxt (mkLocatedList (stmts ++ [last_stmt])) anns
+mkHsCompAnns ctxt stmts expr@(L l e) anns = mkHsDoAnns ctxt (L loc (stmts ++ [last_stmt])) anns
where
- -- Strip the annotations from the location, they are in the embedded expr
- last_stmt = L (noAnnSrcSpan $ getLocA expr) $ mkLastStmt expr
+ -- Move the annotations to the top of the last_stmt
+ last = mkLastStmt (L (noAnnSrcSpan $ getLocA expr) e)
+ last_stmt = L l last
+ -- last_stmt actually comes first in a list comprehension, consider all spans
+ loc = noAnnSrcSpan $ getHasLocList (last_stmt:stmts)
-- restricted to GhcPs because other phases might need a SyntaxExpr
mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> EpAnn AnnsIf
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 317daa36c5cd..26a7ea1127fb 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1161,7 +1161,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
]
HsUnboundVar _ _ -> [] -- there is an unbound name here, but that causes trouble
HsRecSel _ fld ->
- [ toHie $ RFC RecFieldOcc Nothing (L (l2l mspan:: SrcAnn NoEpAnns) fld)
+ [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)
]
HsOverLabel {} -> []
HsIPVar _ _ -> []
@@ -1439,14 +1439,15 @@ instance ( ToHie (RFContext label)
, toHie expr
]
-instance HiePass p => ToHie (RFContext (LocatedAn NoEpAnns (FieldOcc (GhcPass p)))) where
+instance HiePass p => ToHie (RFContext (LocatedA (FieldOcc (GhcPass p)))) where
toHie (RFC c rhs (L nspan f)) = concatM $ case f of
FieldOcc fld _ ->
case hiePass @p of
HieRn -> [toHie $ C (RecField c rhs) (L (locA nspan) fld)]
HieTc -> [toHie $ C (RecField c rhs) (L (locA nspan) fld)]
-instance HiePass p => ToHie (RFContext (LocatedAn NoEpAnns (AmbiguousFieldOcc (GhcPass p)))) where
+instance HiePass p => ToHie (RFContext (LocatedA (AmbiguousFieldOcc (GhcPass p)))) where
+
toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
Unambiguous fld _ ->
case hiePass @p of
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index d73dd07923b1..c082c493e459 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -1193,7 +1193,7 @@ importlist1 :: { OrdList (LIE GhcPs) }
import :: { OrdList (LIE GhcPs) }
: qcname_ext export_subspec {% fmap (unitOL . reLocA . (sLL $1 $>)) $ mkModuleImpExp Nothing (fst $ unLoc $2) $1 (snd $ unLoc $2) }
- | 'module' modid {% fmap (unitOL . reLocA) $ acs (\cs -> sLL $1 $> (IEModuleContents (Nothing, EpAnn (glR $1) [mj AnnModule $1] cs) $2)) }
+ | 'module' modid {% fmap (unitOL . reLocA) $ acs (\cs -> sLL $1 $> (IEModuleContents (Nothing, EpAnn (glEE $1 $>) [mj AnnModule $1] cs) $2)) }
| 'pattern' qcon { unitOL $ reLocA $ sLL $1 $> $ IEVar Nothing (sLLa $1 $> (IEPattern (glAA $1) $2)) }
-----------------------------------------------------------------------------
@@ -1255,11 +1255,11 @@ topdecl :: { LHsDecl GhcPs }
| stand_alone_deriving { sL1a $1 (DerivD noExtField (unLoc $1)) }
| role_annot { sL1a $1 (RoleAnnotD noExtField (unLoc $1)) }
| 'default' '(' comma_types0 ')' {% acsA (\cs -> sLL $1 $>
- (DefD noExtField (DefaultDecl (EpAnn (glR $1) [mj AnnDefault $1,mop $2,mcp $4] cs) $3))) }
- | 'foreign' fdecl {% acsA (\cs -> sLL $1 $> ((snd $ unLoc $2) (EpAnn (glR $1) (mj AnnForeign $1:(fst $ unLoc $2)) cs))) }
- | '{-# DEPRECATED' deprecations '#-}' {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings ((EpAnn (glR $1) [mo $1,mc $3] cs), (getDEPRECATED_PRAGs $1)) (fromOL $2))) }
- | '{-# WARNING' warnings '#-}' {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings ((EpAnn (glR $1) [mo $1,mc $3] cs), (getWARNING_PRAGs $1)) (fromOL $2))) }
- | '{-# RULES' rules '#-}' {% acsA (\cs -> sLL $1 $> $ RuleD noExtField (HsRules ((EpAnn (glR $1) [mo $1,mc $3] cs), (getRULES_PRAGs $1)) (reverse $2))) }
+ (DefD noExtField (DefaultDecl (EpAnn (glEE $1 $>) [mj AnnDefault $1,mop $2,mcp $4] cs) $3))) }
+ | 'foreign' fdecl {% acsA (\cs -> sLL $1 $> ((snd $ unLoc $2) (EpAnn (glEE $1 $>) (mj AnnForeign $1:(fst $ unLoc $2)) cs))) }
+ | '{-# DEPRECATED' deprecations '#-}' {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings ((EpAnn (glEE $1 $>) [mo $1,mc $3] cs), (getDEPRECATED_PRAGs $1)) (fromOL $2))) }
+ | '{-# WARNING' warnings '#-}' {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings ((EpAnn (glEE $1 $>) [mo $1,mc $3] cs), (getWARNING_PRAGs $1)) (fromOL $2))) }
+ | '{-# RULES' rules '#-}' {% acsA (\cs -> sLL $1 $> $ RuleD noExtField (HsRules ((EpAnn (glEE $1 $>) [mo $1,mc $3] cs), (getRULES_PRAGs $1)) (reverse $2))) }
| annotation { $1 }
| decl_no_th { $1 }
@@ -1348,7 +1348,7 @@ inst_decl :: { LInstDecl GhcPs }
{% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $5)
; let anns = (mj AnnInstance $1 : (fst $ unLoc $5))
; let cid cs = ClsInstDecl
- { cid_ext = ($2, EpAnn (glR $1) anns cs, NoAnnSortKey)
+ { cid_ext = ($2, EpAnn (spanAsAnchor (comb3 $1 $4 $5)) anns cs, NoAnnSortKey)
, cid_poly_ty = $4, cid_binds = binds
, cid_sigs = mkClassOpSigs sigs
, cid_tyfam_insts = ats
@@ -1398,7 +1398,7 @@ deriv_strategy_no_via :: { LDerivStrategy GhcPs }
| 'newtype' {% acsA (\cs -> sL1 $1 (NewtypeStrategy (EpAnn (glR $1) [mj AnnNewtype $1] cs))) }
deriv_strategy_via :: { LDerivStrategy GhcPs }
- : 'via' sigktype {% acsA (\cs -> sLL $1 $> (ViaStrategy (XViaStrategyPs (EpAnn (glR $1) [mj AnnVia $1] cs)
+ : 'via' sigktype {% acsA (\cs -> sLL $1 $> (ViaStrategy (XViaStrategyPs (EpAnn (glEE $1 $>) [mj AnnVia $1] cs)
$2))) }
deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) }
@@ -1463,7 +1463,7 @@ ty_fam_inst_eqn :: { LTyFamInstEqn GhcPs }
; tvbs <- fromSpecTyVarBndrs $2
; let loc = comb2 $1 $>
; cs <- getCommentsFor loc
- ; mkTyFamInstEqn loc (mkHsOuterExplicit (EpAnn (glR $1) (mu AnnForall $1, mj AnnDot $3) cs) tvbs) $4 $6 [mj AnnEqual $5] }}
+ ; mkTyFamInstEqn loc (mkHsOuterExplicit (EpAnn (glEE $1 $3) (mu AnnForall $1, mj AnnDot $3) cs) tvbs) $4 $6 [mj AnnEqual $5] }}
| type '=' ktype
{% mkTyFamInstEqn (comb2 $1 $>) mkHsOuterImplicit $1 $3 (mj AnnEqual $2:[]) }
-- Note the use of type for the head; this allows
@@ -1594,13 +1594,13 @@ datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs
>>= \tvbs ->
(acs (\cs -> (sLL $1 $>
(Just ( addTrailingDarrowC $4 $5 cs)
- , mkHsOuterExplicit (EpAnn (glR $1) (mu AnnForall $1, mj AnnDot $3) emptyComments) tvbs, $6))))
+ , mkHsOuterExplicit (EpAnn (glEE $1 $3) (mu AnnForall $1, mj AnnDot $3) emptyComments) tvbs, $6))))
}
| 'forall' tv_bndrs '.' type {% do { hintExplicitForall $1
; tvbs <- fromSpecTyVarBndrs $2
; let loc = comb2 $1 $>
; cs <- getCommentsFor loc
- ; return (sL loc (Nothing, mkHsOuterExplicit (EpAnn (glR $1) (mu AnnForall $1, mj AnnDot $3) cs) tvbs, $4))
+ ; return (sL loc (Nothing, mkHsOuterExplicit (EpAnn (glEE $1 $3) (mu AnnForall $1, mj AnnDot $3) cs) tvbs, $4))
} }
| context '=>' type {% acs (\cs -> (sLL $1 $>(Just (addTrailingDarrowC $1 $2 cs), mkHsOuterImplicit, $3))) }
| type { sL1 $1 (Nothing, mkHsOuterImplicit, $1) }
@@ -1627,7 +1627,7 @@ stand_alone_deriving :: { LDerivDecl GhcPs }
{% do { let { err = text "in the stand-alone deriving instance"
<> colon <+> quotes (ppr $6) }
; acsA (\cs -> sLL $1 $>
- (DerivDecl ($4, EpAnn (glR $1) [mj AnnDeriving $1, mj AnnInstance $3] cs) (mkHsWildCardBndrs $6) $2 $5)) }}
+ (DerivDecl ($4, EpAnn (glEE $1 $>) [mj AnnDeriving $1, mj AnnInstance $3] cs) (mkHsWildCardBndrs $6) $2 $5)) }}
-----------------------------------------------------------------------------
-- Role annotations
@@ -1659,19 +1659,19 @@ pattern_synonym_decl :: { LHsDecl GhcPs }
{% let (name, args, as ) = $2 in
acsA (\cs -> sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4
ImplicitBidirectional
- (EpAnn (glR $1) (as ++ [mj AnnPattern $1, mj AnnEqual $3]) cs)) }
+ (EpAnn (glEE $1 $>) (as ++ [mj AnnPattern $1, mj AnnEqual $3]) cs)) }
| 'pattern' pattern_synonym_lhs '<-' pat
{% let (name, args, as) = $2 in
acsA (\cs -> sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 Unidirectional
- (EpAnn (glR $1) (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) cs)) }
+ (EpAnn (glEE $1 $>) (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) cs)) }
| 'pattern' pattern_synonym_lhs '<-' pat where_decls
{% do { let (name, args, as) = $2
; mg <- mkPatSynMatchGroup name $5
; acsA (\cs -> sLL $1 $> . ValD noExtField $
mkPatSynBind name args $4 (ExplicitBidirectional mg)
- (EpAnn (glR $1) (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) cs))
+ (EpAnn (glEE $1 $>) (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) cs))
}}
pattern_synonym_lhs :: { (LocatedN RdrName, HsPatSynDetails GhcPs, [AddEpAnn]) }
@@ -1697,7 +1697,7 @@ where_decls :: { LocatedL (OrdList (LHsDecl GhcPs)) }
pattern_synonym_sig :: { LSig GhcPs }
: 'pattern' con_list '::' sigtype
{% acsA (\cs -> sLL $1 $>
- $ PatSynSig (EpAnn (glR $1) (AnnSig (mu AnnDcolon $3) [mj AnnPattern $1]) cs)
+ $ PatSynSig (EpAnn (glEE $1 $>) (AnnSig (mu AnnDcolon $3) [mj AnnPattern $1]) cs)
(toList $ unLoc $2) $4) }
qvarcon :: { LocatedN RdrName }
@@ -1719,7 +1719,7 @@ decl_cls : at_decl_cls { $1 }
do { v <- checkValSigLhs $2
; let err = text "in default signature" <> colon <+>
quotes (ppr $2)
- ; acsA (\cs -> sLL $1 $> $ SigD noExtField $ ClassOpSig (EpAnn (glR $1) (AnnSig (mu AnnDcolon $3) [mj AnnDefault $1]) cs) True [v] $4) }}
+ ; acsA (\cs -> sLL $1 $> $ SigD noExtField $ ClassOpSig (EpAnn (glEE $1 $>) (AnnSig (mu AnnDcolon $3) [mj AnnDefault $1]) cs) True [v] $4) }}
decls_cls :: { Located ([AddEpAnn],OrdList (LHsDecl GhcPs)) } -- Reversed
: decls_cls ';' decl_cls {% if isNilOL (snd $ unLoc $1)
@@ -1844,7 +1844,7 @@ binds :: { Located (HsLocalBinds GhcPs) }
; return (sL1 $1 $ HsValBinds (fixValbindsAnn $ EpAnn (glR $1) (fst $ unLoc $1) cs) val_binds)} }
| '{' dbinds '}' {% acs (\cs -> (L (comb3 $1 $2 $3)
- $ HsIPBinds (EpAnn (glR $1) (AnnList (Just$ glR $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) }
+ $ HsIPBinds (EpAnn (spanAsAnchor (comb3 $1 $2 $3)) (AnnList (Just$ glR $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) }
| vocurly dbinds close {% acs (\cs -> (L (gl $2)
$ HsIPBinds (EpAnn (glR $1) (AnnList (Just $ glR $2) Nothing Nothing [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) }
@@ -1880,7 +1880,7 @@ rule :: { LRuleDecl GhcPs }
{%runPV (unECP $4) >>= \ $4 ->
runPV (unECP $6) >>= \ $6 ->
acsA (\cs -> (sLL $1 $> $ HsRule
- { rd_ext = (EpAnn (glR $1) ((fstOf3 $3) (mj AnnEqual $5 : (fst $2))) cs, getSTRINGs $1)
+ { rd_ext = (EpAnn (glEE $1 $>) ((fstOf3 $3) (mj AnnEqual $5 : (fst $2))) cs, getSTRINGs $1)
, rd_name = L (noAnnSrcSpan $ gl $1) (getSTRING $1)
, rd_act = (snd $2) `orElse` AlwaysActive
, rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3
@@ -1941,7 +1941,7 @@ rule_vars :: { [LRuleTyTmVar] }
rule_var :: { LRuleTyTmVar }
: varid { sL1a $1 (RuleTyTmVar noAnn $1 Nothing) }
- | '(' varid '::' ctype ')' {% acsA (\cs -> sLL $1 $> (RuleTyTmVar (EpAnn (glR $1) [mop $1,mu AnnDcolon $3,mcp $5] cs) $2 (Just $4))) }
+ | '(' varid '::' ctype ')' {% acsA (\cs -> sLL $1 $> (RuleTyTmVar (EpAnn (glEE $1 $>) [mop $1,mu AnnDcolon $3,mcp $5] cs) $2 (Just $4))) }
{- Note [Parsing explicit foralls in Rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2026,7 +2026,7 @@ deprecations :: { OrdList (LWarnDecl GhcPs) }
-- SUP: TEMPORARY HACK, not checking for `module Foo'
deprecation :: { OrdList (LWarnDecl GhcPs) }
: namelist strings
- {% fmap unitOL $ acsA (\cs -> sLL $1 $> $ (Warning (EpAnn (glR $1) (fst $ unLoc $2) cs) (unLoc $1)
+ {% fmap unitOL $ acsA (\cs -> sLL $1 $> $ (Warning (EpAnn (glEE $1 $>) (fst $ unLoc $2) cs) (unLoc $1)
(DeprecatedTxt NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc $2))) }
strings :: { Located ([AddEpAnn],[Located StringLiteral]) }
@@ -2052,19 +2052,19 @@ stringlist :: { Located (OrdList (Located StringLiteral)) }
annotation :: { LHsDecl GhcPs }
: '{-# ANN' name_var aexp '#-}' {% runPV (unECP $3) >>= \ $3 ->
acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation
- ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $4) []) cs),
+ ((EpAnn (glEE $1 $>) (AnnPragma (mo $1) (mc $4) []) cs),
(getANN_PRAGs $1))
(ValueAnnProvenance $2) $3)) }
| '{-# ANN' 'type' otycon aexp '#-}' {% runPV (unECP $4) >>= \ $4 ->
acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation
- ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $5) [mj AnnType $2]) cs),
+ ((EpAnn (glEE $1 $>) (AnnPragma (mo $1) (mc $5) [mj AnnType $2]) cs),
(getANN_PRAGs $1))
(TypeAnnProvenance $3) $4)) }
| '{-# ANN' 'module' aexp '#-}' {% runPV (unECP $3) >>= \ $3 ->
acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation
- ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $4) [mj AnnModule $2]) cs),
+ ((EpAnn (glEE $1 $>) (AnnPragma (mo $1) (mc $4) [mj AnnModule $2]) cs),
(getANN_PRAGs $1))
ModuleAnnProvenance $3)) }
@@ -2121,7 +2121,7 @@ opt_tyconsig :: { ([AddEpAnn], Maybe (LocatedN RdrName)) }
sigktype :: { LHsSigType GhcPs }
: sigtype { $1 }
| ctype '::' kind {% acsA (\cs -> sLL $1 $> $ mkHsImplicitSigType $
- sLLa $1 $> $ HsKindSig (EpAnn (glAR $1) [mu AnnDcolon $2] cs) $1 $3) }
+ sLLa $1 $> $ HsKindSig (EpAnn (glEE $1 $>) [mu AnnDcolon $2] cs) $1 $3) }
-- Like ctype, but for types that obey the forall-or-nothing rule.
-- See Note [forall-or-nothing rule] in GHC.Hs.Type. To avoid duplicating the
@@ -2152,16 +2152,16 @@ unpackedness :: { Located UnpackednessPragma }
forall_telescope :: { Located (HsForAllTelescope GhcPs) }
: 'forall' tv_bndrs '.' {% do { hintExplicitForall $1
; acs (\cs -> (sLL $1 $> $
- mkHsForAllInvisTele (EpAnn (glR $1) (mu AnnForall $1,mu AnnDot $3) cs) $2 )) }}
+ mkHsForAllInvisTele (EpAnn (glEE $1 $>) (mu AnnForall $1,mu AnnDot $3) cs) $2 )) }}
| 'forall' tv_bndrs '->' {% do { hintExplicitForall $1
; req_tvbs <- fromSpecTyVarBndrs $2
; acs (\cs -> (sLL $1 $> $
- mkHsForAllVisTele (EpAnn (glR $1) (mu AnnForall $1,mu AnnRarrow $3) cs) req_tvbs )) }}
+ mkHsForAllVisTele (EpAnn (glEE $1 $>) (mu AnnForall $1,mu AnnRarrow $3) cs) req_tvbs )) }}
-- A ktype is a ctype, possibly with a kind annotation
ktype :: { LHsType GhcPs }
: ctype { $1 }
- | ctype '::' kind {% acsA (\cs -> sLL $1 $> $ HsKindSig (EpAnn (glAR $1) [mu AnnDcolon $2] cs) $1 $3) }
+ | ctype '::' kind {% acsA (\cs -> sLL $1 $> $ HsKindSig (EpAnn (glEE $1 $>) [mu AnnDcolon $2] cs) $1 $3) }
-- A ctype is a for-all type
ctype :: { LHsType GhcPs }
@@ -2174,7 +2174,7 @@ ctype :: { LHsType GhcPs }
, hst_xqual = NoExtField
, hst_body = $3 })) }
- | ipvar '::' ctype {% acsA (\cs -> sLL $1 $> (HsIParamTy (EpAnn (glR $1) [mu AnnDcolon $2] cs) (reLocA $1) $3)) }
+ | ipvar '::' ctype {% acsA (\cs -> sLL $1 $> (HsIParamTy (EpAnn (glEE $1 $>) [mu AnnDcolon $2] cs) (reLocA $1) $3)) }
| type { $1 }
----------------------
@@ -2207,16 +2207,16 @@ type :: { LHsType GhcPs }
-- See Note [%shift: type -> btype]
: btype %shift { $1 }
| btype '->' ctype {% acsA (\cs -> sLL $1 $>
- $ HsFunTy (EpAnn (glAR $1) NoEpAnns cs) (HsUnrestrictedArrow (hsUniTok $2)) $1 $3) }
+ $ HsFunTy (EpAnn (glEE $1 $>) NoEpAnns cs) (HsUnrestrictedArrow (hsUniTok $2)) $1 $3) }
| btype mult '->' ctype {% hintLinear (getLoc $2)
>> let arr = (unLoc $2) (hsUniTok $3)
in acsA (\cs -> sLL $1 $>
- $ HsFunTy (EpAnn (glAR $1) NoEpAnns cs) arr $1 $4) }
+ $ HsFunTy (EpAnn (glEE $1 $>) NoEpAnns cs) arr $1 $4) }
| btype '->.' ctype {% hintLinear (getLoc $2) >>
acsA (\cs -> sLL $1 $>
- $ HsFunTy (EpAnn (glAR $1) NoEpAnns cs) (HsLinearArrow (HsLolly (hsTok $2))) $1 $3) }
+ $ HsFunTy (EpAnn (glEE $1 $>) NoEpAnns cs) (HsLinearArrow (HsLolly (hsTok $2))) $1 $3) }
-- [mu AnnLollyU $2] }
mult :: { Located (LHsUniToken "->" "\8594" GhcPs -> HsArrow GhcPs) }
@@ -2266,38 +2266,38 @@ atype :: { LHsType GhcPs }
; return $ sL1a $1 (HsStarTy noExtField (isUnicode $1)) } }
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
- | PREFIX_TILDE atype {% acsA (\cs -> sLL $1 $> (mkBangTy (EpAnn (glR $1) [mj AnnTilde $1] cs) SrcLazy $2)) }
- | PREFIX_BANG atype {% acsA (\cs -> sLL $1 $> (mkBangTy (EpAnn (glR $1) [mj AnnBang $1] cs) SrcStrict $2)) }
+ | PREFIX_TILDE atype {% acsA (\cs -> sLL $1 $> (mkBangTy (EpAnn (glEE $1 $>) [mj AnnTilde $1] cs) SrcLazy $2)) }
+ | PREFIX_BANG atype {% acsA (\cs -> sLL $1 $> (mkBangTy (EpAnn (glEE $1 $>) [mj AnnBang $1] cs) SrcStrict $2)) }
- | '{' fielddecls '}' {% do { decls <- acsA (\cs -> (sLL $1 $> $ HsRecTy (EpAnn (glR $1) (AnnList (listAsAnchorM $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) $2))
+ | '{' fielddecls '}' {% do { decls <- acsA (\cs -> (sLL $1 $> $ HsRecTy (EpAnn (glEE $1 $>) (AnnList (listAsAnchorM $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) $2))
; checkRecordSyntax decls }}
-- Constructor sigs only
- | '(' ')' {% acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glR $1) (AnnParen AnnParens (glAA $1) (glAA $2)) cs)
+ | '(' ')' {% acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glEE $1 $>) (AnnParen AnnParens (glAA $1) (glAA $2)) cs)
HsBoxedOrConstraintTuple []) }
| '(' ktype ',' comma_types1 ')' {% do { h <- addTrailingCommaA $2 (gl $3)
- ; acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glR $1) (AnnParen AnnParens (glAA $1) (glAA $5)) cs)
+ ; acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glEE $1 $>) (AnnParen AnnParens (glAA $1) (glAA $5)) cs)
HsBoxedOrConstraintTuple (h : $4)) }}
- | '(#' '#)' {% acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glR $1) (AnnParen AnnParensHash (glAA $1) (glAA $2)) cs) HsUnboxedTuple []) }
- | '(#' comma_types1 '#)' {% acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glR $1) (AnnParen AnnParensHash (glAA $1) (glAA $3)) cs) HsUnboxedTuple $2) }
- | '(#' bar_types2 '#)' {% acsA (\cs -> sLL $1 $> $ HsSumTy (EpAnn (glR $1) (AnnParen AnnParensHash (glAA $1) (glAA $3)) cs) $2) }
- | '[' ktype ']' {% acsA (\cs -> sLL $1 $> $ HsListTy (EpAnn (glR $1) (AnnParen AnnParensSquare (glAA $1) (glAA $3)) cs) $2) }
- | '(' ktype ')' {% acsA (\cs -> sLL $1 $> $ HsParTy (EpAnn (glR $1) (AnnParen AnnParens (glAA $1) (glAA $3)) cs) $2) }
+ | '(#' '#)' {% acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glEE $1 $>) (AnnParen AnnParensHash (glAA $1) (glAA $2)) cs) HsUnboxedTuple []) }
+ | '(#' comma_types1 '#)' {% acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glEE $1 $>) (AnnParen AnnParensHash (glAA $1) (glAA $3)) cs) HsUnboxedTuple $2) }
+ | '(#' bar_types2 '#)' {% acsA (\cs -> sLL $1 $> $ HsSumTy (EpAnn (glEE $1 $>) (AnnParen AnnParensHash (glAA $1) (glAA $3)) cs) $2) }
+ | '[' ktype ']' {% acsA (\cs -> sLL $1 $> $ HsListTy (EpAnn (glEE $1 $>) (AnnParen AnnParensSquare (glAA $1) (glAA $3)) cs) $2) }
+ | '(' ktype ')' {% acsA (\cs -> sLL $1 $> $ HsParTy (EpAnn (glEE $1 $>) (AnnParen AnnParens (glAA $1) (glAA $3)) cs) $2) }
| quasiquote { mapLocA (HsSpliceTy noExtField) $1 }
| splice_untyped { mapLocA (HsSpliceTy noExtField) $1 }
-- see Note [Promotion] for the followings
- | SIMPLEQUOTE qcon_nowiredlist {% acsA (\cs -> sLL $1 $> $ HsTyVar (EpAnn (glR $1) [mj AnnSimpleQuote $1,mjN AnnName $2] cs) IsPromoted $2) }
+ | SIMPLEQUOTE qcon_nowiredlist {% acsA (\cs -> sLL $1 $> $ HsTyVar (EpAnn (glEE $1 $>) [mj AnnSimpleQuote $1,mjN AnnName $2] cs) IsPromoted $2) }
| SIMPLEQUOTE '(' ktype ',' comma_types1 ')'
{% do { h <- addTrailingCommaA $3 (gl $4)
- ; acsA (\cs -> sLL $1 $> $ HsExplicitTupleTy (EpAnn (glR $1) [mj AnnSimpleQuote $1,mop $2,mcp $6] cs) (h : $5)) }}
- | SIMPLEQUOTE '[' comma_types0 ']' {% acsA (\cs -> sLL $1 $> $ HsExplicitListTy (EpAnn (glR $1) [mj AnnSimpleQuote $1,mos $2,mcs $4] cs) IsPromoted $3) }
- | SIMPLEQUOTE var {% acsA (\cs -> sLL $1 $> $ HsTyVar (EpAnn (glR $1) [mj AnnSimpleQuote $1,mjN AnnName $2] cs) IsPromoted $2) }
+ ; acsA (\cs -> sLL $1 $> $ HsExplicitTupleTy (EpAnn (glEE $1 $>) [mj AnnSimpleQuote $1,mop $2,mcp $6] cs) (h : $5)) }}
+ | SIMPLEQUOTE '[' comma_types0 ']' {% acsA (\cs -> sLL $1 $> $ HsExplicitListTy (EpAnn (glEE $1 $>) [mj AnnSimpleQuote $1,mos $2,mcs $4] cs) IsPromoted $3) }
+ | SIMPLEQUOTE var {% acsA (\cs -> sLL $1 $> $ HsTyVar (EpAnn (glEE $1 $>) [mj AnnSimpleQuote $1,mjN AnnName $2] cs) IsPromoted $2) }
-- Two or more [ty, ty, ty] must be a promoted list type, just as
-- if you had written '[ty, ty, ty]
-- (One means a list type, zero means the list type constructor,
-- so you have to quote those.)
| '[' ktype ',' comma_types1 ']' {% do { h <- addTrailingCommaA $2 (gl $3)
- ; acsA (\cs -> sLL $1 $> $ HsExplicitListTy (EpAnn (glR $1) [mos $1,mcs $5] cs) NotPromoted (h:$4)) }}
+ ; acsA (\cs -> sLL $1 $> $ HsExplicitListTy (EpAnn (glEE $1 $>) [mos $1,mcs $5] cs) NotPromoted (h:$4)) }}
| INTEGER { sLLa $1 $> $ HsTyLit noExtField $ HsNumTy (getINTEGERs $1)
(il_value (getINTEGER $1)) }
| CHAR { sLLa $1 $> $ HsTyLit noExtField $ HsCharTy (getCHARs $1)
@@ -2308,7 +2308,7 @@ atype :: { LHsType GhcPs }
-- Type variables are never exported, so `M.tyvar` will be rejected by the renamer.
-- We let it pass the parser because the renamer can generate a better error message.
| QVARID {% let qname = mkQual tvName (getQVARID $1)
- in acsa (\cs -> sL1a $1 (HsTyVar (EpAnn (glR $1) [] cs) NotPromoted (sL1n $1 $ qname)))}
+ in acsa (\cs -> sL1a $1 (HsTyVar (EpAnn (glEE $1 $>) [] cs) NotPromoted (sL1n $1 $ qname)))}
-- An inst_type is what occurs in the head of an instance decl
-- e.g. (Foo a, Gaz b) => Wibble a b
@@ -2343,12 +2343,12 @@ tv_bndrs :: { [LHsTyVarBndr Specificity GhcPs] }
tv_bndr :: { LHsTyVarBndr Specificity GhcPs }
: tv_bndr_no_braces { $1 }
- | '{' tyvar '}' {% acsA (\cs -> sLL $1 $> (UserTyVar (EpAnn (glR $1) [moc $1, mcc $3] cs) InferredSpec $2)) }
- | '{' tyvar '::' kind '}' {% acsA (\cs -> sLL $1 $> (KindedTyVar (EpAnn (glR $1) [moc $1,mu AnnDcolon $3 ,mcc $5] cs) InferredSpec $2 $4)) }
+ | '{' tyvar '}' {% acsA (\cs -> sLL $1 $> (UserTyVar (EpAnn (glEE $1 $>) [moc $1, mcc $3] cs) InferredSpec $2)) }
+ | '{' tyvar '::' kind '}' {% acsA (\cs -> sLL $1 $> (KindedTyVar (EpAnn (glEE $1 $>) [moc $1,mu AnnDcolon $3 ,mcc $5] cs) InferredSpec $2 $4)) }
tv_bndr_no_braces :: { LHsTyVarBndr Specificity GhcPs }
- : tyvar {% acsA (\cs -> (sL1 $1 (UserTyVar (EpAnn (glNR $1) [] cs) SpecifiedSpec $1))) }
- | '(' tyvar '::' kind ')' {% acsA (\cs -> (sLL $1 $> (KindedTyVar (EpAnn (glR $1) [mop $1,mu AnnDcolon $3 ,mcp $5] cs) SpecifiedSpec $2 $4))) }
+ : tyvar {% acsA (\cs -> (sL1 $1 (UserTyVar (EpAnn (glNR $1) [] cs) SpecifiedSpec $1))) }
+ | '(' tyvar '::' kind ')' {% acsA (\cs -> (sLL $1 $> (KindedTyVar (EpAnn (glEE $1 $>) [mop $1,mu AnnDcolon $3 ,mcp $5] cs) SpecifiedSpec $2 $4))) }
fds :: { Located ([AddEpAnn],[LHsFunDep GhcPs]) }
: {- empty -} { noLoc ([],[]) }
@@ -2364,7 +2364,7 @@ fds1 :: { Located [LHsFunDep GhcPs] }
fd :: { LHsFunDep GhcPs }
: varids0 '->' varids0 {% acsA (\cs -> L (comb3 $1 $2 $3)
- (FunDep (EpAnn (glR $1) [mu AnnRarrow $2] cs)
+ (FunDep (EpAnn (spanAsAnchor (comb3 $1 $2 $3)) [mu AnnRarrow $2] cs)
(reverse (unLoc $1))
(reverse (unLoc $3)))) }
@@ -2501,8 +2501,9 @@ fielddecl :: { LConDeclField GhcPs }
-- A list because of f,g :: Int
: sig_vars '::' ctype
{% acsA (\cs -> L (comb2 $1 $3)
- (ConDeclField (EpAnn (glR $1) [mu AnnDcolon $2] cs)
- (reverse (map (\ln@(L l n) -> L (l2l l) $ FieldOcc noExtField ln) (unLoc $1))) $3 Nothing))}
+ (ConDeclField (EpAnn (glEE $1 $>) [mu AnnDcolon $2] cs)
+ (reverse (map (\ln@(L l n)
+ -> L (fromTrailingN l) $ FieldOcc noExtField (L (noTrailingN l) n)) (unLoc $1))) $3 Nothing))}
-- Reversed!
maybe_derivings :: { Located (HsDeriving GhcPs) }
@@ -2519,15 +2520,15 @@ derivings :: { Located (HsDeriving GhcPs) }
deriving :: { LHsDerivingClause GhcPs }
: 'deriving' deriv_clause_types
{% let { full_loc = comb2 $1 $> }
- in acsA (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR $1) [mj AnnDeriving $1] cs) Nothing $2) }
+ in acsA (\cs -> L full_loc $ HsDerivingClause (EpAnn (glEE $1 $>) [mj AnnDeriving $1] cs) Nothing $2) }
| 'deriving' deriv_strategy_no_via deriv_clause_types
{% let { full_loc = comb2 $1 $> }
- in acsA (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR $1) [mj AnnDeriving $1] cs) (Just $2) $3) }
+ in acsA (\cs -> L full_loc $ HsDerivingClause (EpAnn (glEE $1 $>) [mj AnnDeriving $1] cs) (Just $2) $3) }
| 'deriving' deriv_clause_types deriv_strategy_via
{% let { full_loc = comb2 $1 $> }
- in acsA (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR $1) [mj AnnDeriving $1] cs) (Just $3) $2) }
+ in acsA (\cs -> L full_loc $ HsDerivingClause (EpAnn (glEE $1 $>) [mj AnnDeriving $1] cs) (Just $3) $2) }
deriv_clause_types :: { LDerivClauseTys GhcPs }
: qtycon { let { tc = sL1a $1 $ mkHsImplicitSigType $
@@ -2602,7 +2603,7 @@ gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] }
gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) }
: '|' guardquals '=' exp {% runPV (unECP $4) >>= \ $4 ->
- acsA (\cs -> sL (comb2 $1 $>) $ GRHS (EpAnn (glR $1) (GrhsAnn (Just $ glAA $1) (mj AnnEqual $3)) cs) (unLoc $2) $4) }
+ acsA (\cs -> sL (comb2 $1 $>) $ GRHS (EpAnn (glEE $1 $>) (GrhsAnn (Just $ glAA $1) (mj AnnEqual $3)) cs) (unLoc $2) $4) }
sigdecl :: { LHsDecl GhcPs }
:
@@ -2611,7 +2612,7 @@ sigdecl :: { LHsDecl GhcPs }
{% do { $1 <- runPV (unECP $1)
; v <- checkValSigLhs $1
; acsA (\cs -> (sLL $1 $> $ SigD noExtField $
- TypeSig (EpAnn (glAR $1) (AnnSig (mu AnnDcolon $2) []) cs) [v] (mkHsWildCardBndrs $3)))} }
+ TypeSig (EpAnn (glEE $1 $>) (AnnSig (mu AnnDcolon $2) []) cs) [v] (mkHsWildCardBndrs $3)))} }
| var ',' sig_vars '::' sigtype
{% do { v <- addTrailingCommaN $1 (gl $2)
@@ -2629,7 +2630,7 @@ sigdecl :: { LHsDecl GhcPs }
Nothing -> (NoSourceText, maxPrecedence)
Just l2 -> (fst $ unLoc l2, snd $ unLoc l2)
; acsA (\cs -> sLL $1 $> $ SigD noExtField
- (FixSig (EpAnn (glR $1) (mj AnnInfix $1 : maybeToList mbPrecAnn) cs) (FixitySig noExtField (fromOL $ unLoc $3)
+ (FixSig (EpAnn (glEE $1 $>) (mj AnnInfix $1 : maybeToList mbPrecAnn) cs) (FixitySig noExtField (fromOL $ unLoc $3)
(Fixity fixText fixPrec (unLoc $1)))))
}}
@@ -2639,42 +2640,42 @@ sigdecl :: { LHsDecl GhcPs }
{% let (dcolon, tc) = $3
in acsA
(\cs -> sLL $1 $>
- (SigD noExtField (CompleteMatchSig ((EpAnn (glR $1) ([ mo $1 ] ++ dcolon ++ [mc $4]) cs), (getCOMPLETE_PRAGs $1)) $2 tc))) }
+ (SigD noExtField (CompleteMatchSig ((EpAnn (glEE $1 $>) ([ mo $1 ] ++ dcolon ++ [mc $4]) cs), (getCOMPLETE_PRAGs $1)) $2 tc))) }
-- This rule is for both INLINE and INLINABLE pragmas
| '{-# INLINE' activation qvarcon '#-}'
- {% acsA (\cs -> (sLL $1 $> $ SigD noExtField (InlineSig (EpAnn (glR $1) ((mo $1:fst $2) ++ [mc $4]) cs) $3
+ {% acsA (\cs -> (sLL $1 $> $ SigD noExtField (InlineSig (EpAnn (glEE $1 $>) ((mo $1:fst $2) ++ [mc $4]) cs) $3
(mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1)
(snd $2))))) }
| '{-# OPAQUE' qvar '#-}'
- {% acsA (\cs -> (sLL $1 $> $ SigD noExtField (InlineSig (EpAnn (glR $1) [mo $1, mc $3] cs) $2
+ {% acsA (\cs -> (sLL $1 $> $ SigD noExtField (InlineSig (EpAnn (glEE $1 $>) [mo $1, mc $3] cs) $2
(mkOpaquePragma (getOPAQUE_PRAGs $1))))) }
| '{-# SCC' qvar '#-}'
- {% acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig ((EpAnn (glR $1) [mo $1, mc $3] cs), (getSCC_PRAGs $1)) $2 Nothing))) }
+ {% acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig ((EpAnn (glEE $1 $>) [mo $1, mc $3] cs), (getSCC_PRAGs $1)) $2 Nothing))) }
| '{-# SCC' qvar STRING '#-}'
{% do { scc <- getSCC $3
; let str_lit = StringLiteral (getSTRINGs $3) scc Nothing
- ; acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig ((EpAnn (glR $1) [mo $1, mc $4] cs), (getSCC_PRAGs $1)) $2 (Just ( sL1a $3 str_lit))))) }}
+ ; acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig ((EpAnn (glEE $1 $>) [mo $1, mc $4] cs), (getSCC_PRAGs $1)) $2 (Just ( sL1a $3 str_lit))))) }}
| '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
{% acsA (\cs ->
let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)
(NoUserInlinePrag, FunLike) (snd $2)
- in sLL $1 $> $ SigD noExtField (SpecSig (EpAnn (glR $1) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) cs) $3 (fromOL $5) inl_prag)) }
+ in sLL $1 $> $ SigD noExtField (SpecSig (EpAnn (glEE $1 $>) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) cs) $3 (fromOL $5) inl_prag)) }
| '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
- {% acsA (\cs -> sLL $1 $> $ SigD noExtField (SpecSig (EpAnn (glR $1) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) cs) $3 (fromOL $5)
+ {% acsA (\cs -> sLL $1 $> $ SigD noExtField (SpecSig (EpAnn (glEE $1 $>) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) cs) $3 (fromOL $5)
(mkInlinePragma (getSPEC_INLINE_PRAGs $1)
(getSPEC_INLINE $1) (snd $2)))) }
| '{-# SPECIALISE' 'instance' inst_type '#-}'
{% acsA (\cs -> sLL $1 $>
- $ SigD noExtField (SpecInstSig ((EpAnn (glR $1) [mo $1,mj AnnInstance $2,mc $4] cs), (getSPEC_PRAGs $1)) $3)) }
+ $ SigD noExtField (SpecInstSig ((EpAnn (glEE $1 $>) [mo $1,mj AnnInstance $2,mc $4] cs), (getSPEC_PRAGs $1)) $3)) }
-- A minimal complete definition
| '{-# MINIMAL' name_boolformula_opt '#-}'
- {% acsA (\cs -> sLL $1 $> $ SigD noExtField (MinimalSig ((EpAnn (glR $1) [mo $1,mc $3] cs), (getMINIMAL_PRAGs $1)) $2)) }
+ {% acsA (\cs -> sLL $1 $> $ SigD noExtField (MinimalSig ((EpAnn (glEE $1 $>) [mo $1,mc $3] cs), (getMINIMAL_PRAGs $1)) $2)) }
activation :: { ([AddEpAnn],Maybe Activation) }
-- See Note [%shift: activation -> {- empty -}]
@@ -2711,22 +2712,22 @@ exp :: { ECP }
| infixexp '-<' exp {% runPV (unECP $1) >>= \ $1 ->
runPV (unECP $3) >>= \ $3 ->
fmap ecpFromCmd $
- acsA (\cs -> sLL $1 $> $ HsCmdArrApp (EpAnn (glAR $1) (mu Annlarrowtail $2) cs) $1 $3
+ acsA (\cs -> sLL $1 $> $ HsCmdArrApp (EpAnn (glEE $1 $>) (mu Annlarrowtail $2) cs) $1 $3
HsFirstOrderApp True) }
| infixexp '>-' exp {% runPV (unECP $1) >>= \ $1 ->
runPV (unECP $3) >>= \ $3 ->
fmap ecpFromCmd $
- acsA (\cs -> sLL $1 $> $ HsCmdArrApp (EpAnn (glAR $1) (mu Annrarrowtail $2) cs) $3 $1
+ acsA (\cs -> sLL $1 $> $ HsCmdArrApp (EpAnn (glEE $1 $>) (mu Annrarrowtail $2) cs) $3 $1
HsFirstOrderApp False) }
| infixexp '-<<' exp {% runPV (unECP $1) >>= \ $1 ->
runPV (unECP $3) >>= \ $3 ->
fmap ecpFromCmd $
- acsA (\cs -> sLL $1 $> $ HsCmdArrApp (EpAnn (glAR $1) (mu AnnLarrowtail $2) cs) $1 $3
+ acsA (\cs -> sLL $1 $> $ HsCmdArrApp (EpAnn (glEE $1 $>) (mu AnnLarrowtail $2) cs) $1 $3
HsHigherOrderApp True) }
| infixexp '>>-' exp {% runPV (unECP $1) >>= \ $1 ->
runPV (unECP $3) >>= \ $3 ->
fmap ecpFromCmd $
- acsA (\cs -> sLL $1 $> $ HsCmdArrApp (EpAnn (glAR $1) (mu AnnRarrowtail $2) cs) $3 $1
+ acsA (\cs -> sLL $1 $> $ HsCmdArrApp (EpAnn (glEE $1 $>) (mu AnnRarrowtail $2) cs) $3 $1
HsHigherOrderApp False) }
-- See Note [%shift: exp -> infixexp]
| infixexp %shift { $1 }
@@ -2821,12 +2822,12 @@ prag_e :: { Located (HsPragE GhcPs) }
: '{-# SCC' STRING '#-}' {% do { scc <- getSCC $2
; acs (\cs -> (sLL $1 $>
(HsPragSCC
- ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnValStr $2]) cs),
+ ((EpAnn (glEE $1 $>) (AnnPragma (mo $1) (mc $3) [mj AnnValStr $2]) cs),
(getSCC_PRAGs $1))
(StringLiteral (getSTRINGs $2) scc Nothing))))} }
| '{-# SCC' VARID '#-}' {% acs (\cs -> (sLL $1 $>
(HsPragSCC
- ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) cs),
+ ((EpAnn (glEE $1 $>) (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) cs),
(getSCC_PRAGs $1))
(StringLiteral NoSourceText (getVARID $2) Nothing)))) }
@@ -2844,7 +2845,7 @@ fexp :: { ECP }
| 'static' aexp {% runPV (unECP $2) >>= \ $2 ->
fmap ecpFromExp $
- acsA (\cs -> sLL $1 $> $ HsStatic (EpAnn (glR $1) [mj AnnStatic $1] cs) $2) }
+ acsA (\cs -> sLL $1 $> $ HsStatic (EpAnn (glEE $1 $>) [mj AnnStatic $1] cs) $2) }
| aexp { $1 }
@@ -2875,7 +2876,7 @@ aexp :: { ECP }
mkHsLamPV (comb2 $1 $>) LamSingle
(sLLl $1 $>
[sLLa $1 $>
- $ Match { m_ext = EpAnn (glR $1) [] emptyComments
+ $ Match { m_ext = EpAnn (glEE $1 $>) [] emptyComments
, m_ctxt = LamAlt LamSingle
, m_pats = $2
, m_grhss = unguardedGRHSs (comb2 $3 $4) $4 (EpAnn (glR $3) (GrhsAnn Nothing (mu AnnRarrow $3)) emptyComments) }])
@@ -2901,7 +2902,7 @@ aexp :: { ECP }
| 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >>= \_ ->
fmap ecpFromExp $
- acsA (\cs -> sLL $1 $> $ HsMultiIf (EpAnn (glR $1) (mj AnnIf $1:(fst $ unLoc $2)) cs)
+ acsA (\cs -> sLL $1 $> $ HsMultiIf (EpAnn (glEE $1 $>) (mj AnnIf $1:(fst $ unLoc $2)) cs)
(reverse $ snd $ unLoc $2)) }
| 'case' exp 'of' altslist(pats1) {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->
return $ ECP $
@@ -2923,12 +2924,12 @@ aexp :: { ECP }
(mkHsDoAnns (MDoExpr $
fmap mkModuleNameFS (getMDO $1))
$2
- (EpAnn (glR $1) (AnnList (Just $ glAR $2) Nothing Nothing [mj AnnMdo $1] []) cs) )) }
+ (EpAnn (glEE $1 $>) (AnnList (Just $ glAR $2) Nothing Nothing [mj AnnMdo $1] []) cs) )) }
| 'proc' aexp '->' exp
{% (checkPattern <=< runPV) (unECP $2) >>= \ p ->
runPV (unECP $4) >>= \ $4@cmd ->
fmap ecpFromExp $
- acsA (\cs -> sLL $1 $> $ HsProc (EpAnn (glR $1) [mj AnnProc $1,mu AnnRarrow $3] cs) p (sLLa $1 $> $ HsCmdTop noExtField cmd)) }
+ acsA (\cs -> sLL $1 $> $ HsProc (EpAnn (glEE $1 $>) [mj AnnProc $1,mu AnnRarrow $3] cs) p (sLLa $1 $> $ HsCmdTop noExtField cmd)) }
| aexp1 { $1 }
@@ -2946,7 +2947,7 @@ aexp1 :: { ECP }
{% runPV (unECP $1) >>= \ $1 ->
fmap ecpFromExp $ acsa (\cs ->
let fl = sLLa $2 $> (DotFieldOcc ((EpAnn (glR $2) (AnnFieldLabel (Just $ glAA $2)) emptyComments)) $3) in
- mkRdrGetField (noAnnSrcSpan $ comb2 $1 $>) $1 fl (EpAnn (glAR $1) NoEpAnns cs)) }
+ mkRdrGetField (noAnnSrcSpan $ comb2 $1 $>) $1 fl (EpAnn (glEE $1 $>) NoEpAnns cs)) }
| aexp2 { $1 }
@@ -2979,7 +2980,7 @@ aexp2 :: { ECP }
-- This case is only possible when 'OverloadedRecordDotBit' is enabled.
| '(' projection ')' { ECP $
- acsA (\cs -> sLL $1 $> $ mkRdrProjection (NE.reverse (unLoc $2)) (EpAnn (glR $1) (AnnProjection (glAA $1) (glAA $3)) cs))
+ acsA (\cs -> sLL $1 $> $ mkRdrProjection (NE.reverse (unLoc $2)) (EpAnn (glEE $1 $>) (AnnProjection (glAA $1) (glAA $3)) cs))
>>= ecpFromExp'
}
@@ -2999,40 +3000,40 @@ aexp2 :: { ECP }
| splice_untyped { ECP $ pvA $ mkHsSplicePV $1 }
| splice_typed { ecpFromExp $ fmap (uncurry HsTypedSplice) (reLocA $1) }
- | SIMPLEQUOTE qvar {% fmap ecpFromExp $ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) }
- | SIMPLEQUOTE qcon {% fmap ecpFromExp $ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) }
- | TH_TY_QUOTE tyvar {% fmap ecpFromExp $ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glR $1) [mj AnnThTyQuote $1 ] cs) (VarBr noExtField False $2)) }
- | TH_TY_QUOTE gtycon {% fmap ecpFromExp $ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glR $1) [mj AnnThTyQuote $1 ] cs) (VarBr noExtField False $2)) }
+ | SIMPLEQUOTE qvar {% fmap ecpFromExp $ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glEE $1 $>) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) }
+ | SIMPLEQUOTE qcon {% fmap ecpFromExp $ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glEE $1 $>) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) }
+ | TH_TY_QUOTE tyvar {% fmap ecpFromExp $ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glEE $1 $>) [mj AnnThTyQuote $1 ] cs) (VarBr noExtField False $2)) }
+ | TH_TY_QUOTE gtycon {% fmap ecpFromExp $ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glEE $1 $>) [mj AnnThTyQuote $1 ] cs) (VarBr noExtField False $2)) }
-- See Note [%shift: aexp2 -> TH_TY_QUOTE]
| TH_TY_QUOTE %shift {% reportEmptyDoubleQuotes (getLoc $1) }
| '[|' exp '|]' {% runPV (unECP $2) >>= \ $2 ->
fmap ecpFromExp $
- acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glR $1) (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3]
+ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glEE $1 $>) (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3]
else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) cs) (ExpBr noExtField $2)) }
| '[||' exp '||]' {% runPV (unECP $2) >>= \ $2 ->
fmap ecpFromExp $
- acsA (\cs -> sLL $1 $> $ HsTypedBracket (EpAnn (glR $1) (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) cs) $2) }
+ acsA (\cs -> sLL $1 $> $ HsTypedBracket (EpAnn (glEE $1 $>) (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) cs) $2) }
| '[t|' ktype '|]' {% fmap ecpFromExp $
- acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glR $1) [mo $1,mu AnnCloseQ $3] cs) (TypBr noExtField $2)) }
+ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glEE $1 $>) [mo $1,mu AnnCloseQ $3] cs) (TypBr noExtField $2)) }
| '[p|' infixexp '|]' {% (checkPattern <=< runPV) (unECP $2) >>= \p ->
fmap ecpFromExp $
- acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glR $1) [mo $1,mu AnnCloseQ $3] cs) (PatBr noExtField p)) }
+ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glEE $1 $>) [mo $1,mu AnnCloseQ $3] cs) (PatBr noExtField p)) }
| '[d|' cvtopbody '|]' {% fmap ecpFromExp $
- acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glR $1) (mo $1:mu AnnCloseQ $3:fst $2) cs) (DecBrL noExtField (snd $2))) }
+ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glEE $1 $>) (mo $1:mu AnnCloseQ $3:fst $2) cs) (DecBrL noExtField (snd $2))) }
| quasiquote { ECP $ pvA $ mkHsSplicePV $1 }
-- arrow notation extension
| '(|' aexp cmdargs '|)' {% runPV (unECP $2) >>= \ $2 ->
fmap ecpFromCmd $
- acsA (\cs -> sLL $1 $> $ HsCmdArrForm (EpAnn (glR $1) (AnnList (Just $ glR $1) (Just $ mu AnnOpenB $1) (Just $ mu AnnCloseB $4) [] []) cs) $2 Prefix
+ acsA (\cs -> sLL $1 $> $ HsCmdArrForm (EpAnn (glEE $1 $>) (AnnList (glRM $1) (Just $ mu AnnOpenB $1) (Just $ mu AnnCloseB $4) [] []) cs) $2 Prefix
Nothing (reverse $3)) }
projection :: { Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))) }
projection
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parsing.Lexer
: projection TIGHT_INFIX_PROJ field
- {% acs (\cs -> sLL $1 $> ((sLLa $2 $> $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $2)) cs) $3) `NE.cons` unLoc $1)) }
- | PREFIX_PROJ field {% acs (\cs -> sLL $1 $> ((sLLa $1 $> $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) $2) :| [])) }
+ {% acs (\cs -> sLL $1 $> ((sLLa $2 $> $ DotFieldOcc (EpAnn (glEE $1 $>) (AnnFieldLabel (Just $ glAA $2)) cs) $3) `NE.cons` unLoc $1)) }
+ | PREFIX_PROJ field {% acs (\cs -> sLL $1 $> ((sLLa $1 $> $ DotFieldOcc (EpAnn (glEE $1 $>) (AnnFieldLabel (Just $ glAA $1)) cs) $2) :| [])) }
splice_exp :: { LHsExpr GhcPs }
: splice_untyped { fmap (HsUntypedSplice noAnn) (reLocA $1) }
@@ -3041,13 +3042,13 @@ splice_exp :: { LHsExpr GhcPs }
splice_untyped :: { Located (HsUntypedSplice GhcPs) }
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
: PREFIX_DOLLAR aexp2 {% runPV (unECP $2) >>= \ $2 ->
- acs (\cs -> sLL $1 $> $ HsUntypedSpliceExpr (EpAnn (glR $1) [mj AnnDollar $1] cs) $2) }
+ acs (\cs -> sLL $1 $> $ HsUntypedSpliceExpr (EpAnn (glEE $1 $>) [mj AnnDollar $1] cs) $2) }
splice_typed :: { Located ((EpAnnCO, EpAnn [AddEpAnn]), LHsExpr GhcPs) }
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
: PREFIX_DOLLAR_DOLLAR aexp2
{% runPV (unECP $2) >>= \ $2 ->
- acs (\cs -> sLL $1 $> $ ((noAnn, EpAnn (glR $1) [mj AnnDollarDollar $1] cs), $2)) }
+ acs (\cs -> sLL $1 $> $ ((noAnn, EpAnn (glEE $1 $>) [mj AnnDollarDollar $1] cs), $2)) }
cmdargs :: { [LHsCmdTop GhcPs] }
: cmdargs acmd { $2 : $1 }
@@ -3359,7 +3360,7 @@ ifgdpats :: { Located ([AddEpAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) }
gdpat :: { forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b)) }
: '|' guardquals '->' exp
{ unECP $4 >>= \ $4 ->
- acsA (\cs -> sL (comb2 $1 $>) $ GRHS (EpAnn (glR $1) (GrhsAnn (Just $ glAA $1) (mu AnnRarrow $3)) cs) (unLoc $2) $4) }
+ acsA (\cs -> sL (comb2 $1 $>) $ GRHS (EpAnn (glEE $1 $>) (GrhsAnn (Just $ glAA $1) (mu AnnRarrow $3)) cs) (unLoc $2) $4) }
-- 'pat' recognises a pattern, including one with a bang at the top
-- e.g. "!x" or "!(x,y)" or "C a b" etc
@@ -3435,17 +3436,17 @@ stmt :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }
: qual { $1 }
| 'rec' stmtlist { $2 >>= \ $2 ->
acsA (\cs -> (sLL $1 $> $ mkRecStmt
- (EpAnn (glR $1) (hsDoAnn $1 $2 AnnRec) cs)
+ (EpAnn (glEE $1 $>) (hsDoAnn $1 $2 AnnRec) cs)
$2)) }
qual :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }
: bindpat '<-' exp { unECP $3 >>= \ $3 ->
acsA (\cs -> sLL $1 $>
- $ mkPsBindStmt (EpAnn (glAR $1) [mu AnnLarrow $2] cs) $1 $3) }
+ $ mkPsBindStmt (EpAnn (glEE $1 $>) [mu AnnLarrow $2] cs) $1 $3) }
| exp { unECP $1 >>= \ $1 ->
return $ sL1a $1 $ mkBodyStmt $1 }
| 'let' binds { acsA (\cs -> (sLL $1 $>
- $ mkLetStmt (EpAnn (glR $1) [mj AnnLet $1] cs) (unLoc $2))) }
+ $ mkLetStmt (EpAnn (glEE $1 $>) [mj AnnLet $1] cs) (unLoc $2))) }
-----------------------------------------------------------------------------
-- Record Field Update/Construction
@@ -3534,7 +3535,7 @@ dbinds :: { Located [LIPBind GhcPs] } -- reversed
dbind :: { LIPBind GhcPs }
dbind : ipvar '=' exp {% runPV (unECP $3) >>= \ $3 ->
- acsA (\cs -> sLL $1 $> (IPBind (EpAnn (glR $1) [mj AnnEqual $2] cs) (reLocA $1) $3)) }
+ acsA (\cs -> sLL $1 $> (IPBind (EpAnn (glEE $1 $>) [mj AnnEqual $2] cs) (reLocA $1) $3)) }
ipvar :: { Located HsIPName }
: IPDUPVARID { sL1 $1 (HsIPName (getIPDUPVARID $1)) }
@@ -3765,7 +3766,7 @@ qopm :: { forall b. DisambInfixOp b => PV (LocatedN b) } -- used in section
hole_op :: { forall b. DisambInfixOp b => PV (Located b) } -- used in sections
hole_op : '`' '_' '`' { mkHsInfixHolePV (comb2 $1 $>)
- (\cs -> EpAnn (glR $1) (EpAnnUnboundVar (glAA $1, glAA $3) (glAA $2)) cs) }
+ (\cs -> EpAnn (glEE $1 $>) (EpAnnUnboundVar (glAA $1, glAA $3) (glAA $2)) cs) }
qvarop :: { LocatedN RdrName }
: qvarsym { $1 }
@@ -4310,6 +4311,12 @@ glMR :: Maybe (Located a) -> Located b -> Anchor
glMR (Just la) _ = glR la
glMR _ la = glR la
+glEE :: (HasLoc a, HasLoc b) => a -> b -> Anchor
+glEE x y = spanAsAnchor $ comb2 x y
+
+glRM :: Located a -> Maybe Anchor
+glRM (L l _) = Just $ spanAsAnchor l
+
glAA :: Located a -> EpaLocation
glAA = srcSpan2e . getLoc
@@ -4570,4 +4577,9 @@ adaptWhereBinds (Just (L l (b, mc))) = L l (b, maybe emptyComments id mc)
combineHasLocs :: (HasLoc a, HasLoc b) => a -> b -> SrcSpan
combineHasLocs a b = combineSrcSpans (getHasLoc a) (getHasLoc b)
+
+fromTrailingN :: SrcSpanAnnN -> SrcSpanAnnA
+fromTrailingN (SrcSpanAnn EpAnnNotUsed l) = SrcSpanAnn EpAnnNotUsed l
+fromTrailingN (SrcSpanAnn (EpAnn anc ann cs) l)
+ = SrcSpanAnn (EpAnn anc (AnnListItem (nann_trailing ann)) cs) l
}
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index f15bbec30c48..65ccdfff07fd 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -46,6 +46,7 @@ module GHC.Parser.Annotation (
-- ** Trailing annotations in lists
TrailingAnn(..), trailingAnnToAddEpAnn,
addTrailingAnnToA, addTrailingAnnToL, addTrailingCommaToN,
+ noTrailingN,
-- ** Utilities for converting between different 'GenLocated' when
-- ** we do not care about the annotations.
@@ -65,6 +66,7 @@ module GHC.Parser.Annotation (
epAnnAnns, epAnnAnnsL,
annParen2AddEpAnn,
epAnnComments,
+ s_comments, s_entry,
-- ** Working with locations of annotations
sortLocatedA,
@@ -83,8 +85,9 @@ module GHC.Parser.Annotation (
-- ** Working with comments in annotations
noComments, comment, addCommentsToSrcAnn, setCommentsSrcAnn,
addCommentsToEpAnn, setCommentsEpAnn,
- transferAnnsA, transferAnnsOnlyA, transferCommentsOnlyA, commentsOnlyA,
- removeCommentsA,
+ transferAnnsA, transferAnnsOnlyA, transferCommentsOnlyA,
+ transferPriorCommentsA, transferFollowingA,
+ commentsOnlyA, removeCommentsA,
placeholderRealSpan,
) where
@@ -371,13 +374,6 @@ data EpaCommentTok =
| EpaDocOptions String -- ^ doc options (prune, ignore-exports, etc)
| EpaLineComment String -- ^ comment starting by "--"
| EpaBlockComment String -- ^ comment in {- -}
- | EpaEofComment -- ^ empty comment, capturing
- -- location of EOF
-
- -- See #19697 for a discussion of EpaEofComment's use and how it
- -- should be removed in favour of capturing it in the location for
- -- 'Located HsModule' in the parser.
-
deriving (Eq, Data, Show)
-- Note: these are based on the Token versions, but the Token type is
-- defined in GHC.Parser.Lexer and bringing it in here would create a loop
@@ -409,7 +405,7 @@ data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Eq)
-- sort the relative order.
data EpaLocation = EpaSpan !RealSrcSpan !(Strict.Maybe BufSpan)
| EpaDelta !DeltaPos ![LEpaComment]
- deriving (Data,Eq)
+ deriving (Data,Eq,Show)
-- | Tokens embedded in the AST have an EpaLocation, unless they come from
-- generated code (e.g. by TH).
@@ -539,7 +535,7 @@ data Anchor = Anchor { anchor :: RealSrcSpan
-- anchor to be freely moved, without worrying about recalculating the
-- appropriate anchor span.
data AnchorOperation = UnchangedAnchor
- | MovedAnchor DeltaPos
+ | MovedAnchor !DeltaPos ![LEpaComment]
deriving (Data, Eq, Show)
@@ -647,15 +643,19 @@ meaning we can have type LocatedN RdrName
-- | Captures the location of punctuation occurring between items,
-- normally in a list. It is captured as a trailing annotation.
data TrailingAnn
- = AddSemiAnn EpaLocation -- ^ Trailing ';'
- | AddCommaAnn EpaLocation -- ^ Trailing ','
- | AddVbarAnn EpaLocation -- ^ Trailing '|'
+ = AddSemiAnn { ta_location :: EpaLocation } -- ^ Trailing ';'
+ | AddCommaAnn { ta_location :: EpaLocation } -- ^ Trailing ','
+ | AddVbarAnn { ta_location :: EpaLocation } -- ^ Trailing '|'
+ | AddDarrowAnn { ta_location :: EpaLocation } -- ^ Trailing '=>'
+ | AddDarrowUAnn { ta_location :: EpaLocation } -- ^ Trailing "⇒"
deriving (Data, Eq)
instance Outputable TrailingAnn where
ppr (AddSemiAnn ss) = text "AddSemiAnn" <+> ppr ss
ppr (AddCommaAnn ss) = text "AddCommaAnn" <+> ppr ss
ppr (AddVbarAnn ss) = text "AddVbarAnn" <+> ppr ss
+ ppr (AddDarrowAnn ss) = text "AddDarrowAnn" <+> ppr ss
+ ppr (AddDarrowUAnn ss) = text "AddDarrowUAnn" <+> ppr ss
-- | Annotation for items appearing in a list. They can have one or
-- more trailing punctuations items, such as commas or semicolons.
@@ -925,6 +925,8 @@ trailingAnnToAddEpAnn :: TrailingAnn -> AddEpAnn
trailingAnnToAddEpAnn (AddSemiAnn ss) = AddEpAnn AnnSemi ss
trailingAnnToAddEpAnn (AddCommaAnn ss) = AddEpAnn AnnComma ss
trailingAnnToAddEpAnn (AddVbarAnn ss) = AddEpAnn AnnVbar ss
+trailingAnnToAddEpAnn (AddDarrowUAnn ss) = AddEpAnn AnnDarrowU ss
+trailingAnnToAddEpAnn (AddDarrowAnn ss) = AddEpAnn AnnDarrow ss
-- | Helper function used in the parser to add a 'TrailingAnn' items
-- to an existing annotation.
@@ -961,6 +963,11 @@ addTrailingCommaToN _ n l = n { anns = addTrailing (anns n) l }
addTrailing :: NameAnn -> EpaLocation -> NameAnn
addTrailing n l = n { nann_trailing = nann_trailing n ++ [AddCommaAnn l]}
+noTrailingN :: SrcSpanAnnN -> SrcSpanAnnN
+noTrailingN (SrcSpanAnn EpAnnNotUsed l) = SrcSpanAnn EpAnnNotUsed l
+noTrailingN (SrcSpanAnn s l)
+ = SrcSpanAnn (s { anns = (anns s) { nann_trailing = [] } }) l
+
{-
Note [list append in addTrailing*]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1165,6 +1172,13 @@ epAnnComments :: EpAnn an -> EpAnnComments
epAnnComments EpAnnNotUsed = EpaComments []
epAnnComments (EpAnn _ _ cs) = cs
+-- Forward compatibility
+s_comments :: SrcAnn ann -> EpAnnComments
+s_comments (SrcSpanAnn an _) = epAnnComments an
+
+s_entry :: SrcAnn ann -> EpaLocation
+s_entry = epaLocationFromSrcAnn
+
-- ---------------------------------------------------------------------
-- sortLocatedA :: [LocatedA a] -> [LocatedA a]
sortLocatedA :: [GenLocated (SrcSpanAnn' a) e] -> [GenLocated (SrcSpanAnn' a) e]
@@ -1274,6 +1288,26 @@ transferAnnsA (SrcSpanAnn (EpAnn a an cs) l) to
(SrcSpanAnn (EpAnn a an' cs') loc)
-> SrcSpanAnn (EpAnn a (an' <> an) (cs' <> cs)) loc
+-- | Transfer trailing items but not comments from the annotations in the
+-- first 'SrcSpanAnnA' argument to those in the second.
+transferFollowingA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
+transferFollowingA (SrcSpanAnn EpAnnNotUsed l1) (SrcSpanAnn ann2 l2)
+ = (SrcSpanAnn EpAnnNotUsed l1, SrcSpanAnn ann2 l2)
+transferFollowingA (SrcSpanAnn (EpAnn a1 an1 cs1) l1) (SrcSpanAnn EpAnnNotUsed l2)
+ = (SrcSpanAnn (EpAnn a1 noAnn cs1') l1, SrcSpanAnn (EpAnn (spanAsAnchor l2) an1 cs2') l2)
+ where
+ pc = priorComments cs1
+ fc = getFollowingComments cs1
+ cs1' = setPriorComments emptyComments pc
+ cs2' = setFollowingComments emptyComments fc
+transferFollowingA (SrcSpanAnn (EpAnn a1 an1 cs1) l1) (SrcSpanAnn (EpAnn a2 an2 cs2) l2)
+ = (SrcSpanAnn (EpAnn a1 noAnn cs1') l1, SrcSpanAnn (EpAnn a2 (an1 <> an2) cs2') l2)
+ where
+ pc = priorComments cs1
+ fc = getFollowingComments cs1
+ cs1' = setPriorComments emptyComments pc
+ cs2' = setFollowingComments cs2 fc
+
-- | Transfer trailing items from the annotations in the
-- first 'SrcSpanAnnA' argument to those in the second.
transferAnnsOnlyA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
@@ -1294,6 +1328,27 @@ transferCommentsOnlyA (SrcSpanAnn (EpAnn a an cs) l) (SrcSpanAnn EpAnnNotUsed l'
transferCommentsOnlyA (SrcSpanAnn (EpAnn a an cs) l) (SrcSpanAnn (EpAnn a' an' cs') l')
= (SrcSpanAnn (EpAnn a an emptyComments) l, SrcSpanAnn (EpAnn a' an' (cs <> cs')) l')
+-- | Transfer prior comments only from the annotations in the
+-- first 'SrcSpanAnnA' argument to those in the second.
+transferPriorCommentsA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
+transferPriorCommentsA (SrcSpanAnn EpAnnNotUsed l1) (SrcSpanAnn ann2 l2)
+ = (SrcSpanAnn EpAnnNotUsed l1, SrcSpanAnn ann2 l2)
+transferPriorCommentsA (SrcSpanAnn (EpAnn a1 an1 cs1) l1) (SrcSpanAnn EpAnnNotUsed l2)
+ = (SrcSpanAnn (EpAnn a1 an1 cs1') l1, SrcSpanAnn (EpAnn (spanAsAnchor l2) noAnn cs2') l2)
+ where
+ pc = priorComments cs1
+ fc = getFollowingComments cs1
+ cs1' = setFollowingComments emptyComments fc
+ cs2' = setPriorComments emptyComments pc
+transferPriorCommentsA (SrcSpanAnn (EpAnn a1 an1 cs1) l1) (SrcSpanAnn (EpAnn a2 an2 cs2) l2)
+ = (SrcSpanAnn (EpAnn a1 an1 cs1') l1, SrcSpanAnn (EpAnn a2 an2 cs2') l2)
+ where
+ pc = priorComments cs1
+ fc = getFollowingComments cs1
+ cs1' = setFollowingComments emptyComments fc
+ cs2' = setPriorComments cs2 (priorComments cs2 <> pc)
+
+
-- | Remove the exact print annotations payload, leaving only the
-- anchor and comments.
commentsOnlyA :: NoAnn ann => SrcAnn ann -> SrcAnn ann
@@ -1379,8 +1434,8 @@ instance Outputable Anchor where
ppr (Anchor a o) = text "Anchor" <+> ppr a <+> ppr o
instance Outputable AnchorOperation where
- ppr UnchangedAnchor = text "UnchangedAnchor"
- ppr (MovedAnchor d) = text "MovedAnchor" <+> ppr d
+ ppr UnchangedAnchor = text "UnchangedAnchor"
+ ppr (MovedAnchor d cs) = text "MovedAnchor" <+> ppr d <+> ppr cs
instance Outputable DeltaPos where
ppr (SameLine c) = text "SameLine" <+> ppr c
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 92aa77c0f547..4abbec364765 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1200,7 +1200,7 @@ which we don't want.
-}
cvtFld :: (RdrName -> CvtM t) -> (TH.Name, TH.Exp)
- -> CvtM (LHsFieldBind GhcPs (LocatedAn NoEpAnns t) (LHsExpr GhcPs))
+ -> CvtM (LHsFieldBind GhcPs (LocatedA t) (LHsExpr GhcPs))
cvtFld f (v,e)
= do { v' <- vNameL v
; lhs' <- traverse f v'
diff --git a/testsuite/tests/driver/recompChangedPackage/q/q.cabal b/testsuite/tests/driver/recompChangedPackage/q/q.cabal
index 01c41cd9d08a..f9f1e871cb8c 100644
--- a/testsuite/tests/driver/recompChangedPackage/q/q.cabal
+++ b/testsuite/tests/driver/recompChangedPackage/q/q.cabal
@@ -17,7 +17,7 @@ build-type: Simple
extra-source-files: CHANGELOG.md
library
- exposed-modules: QLib
+ exposed-modules: QLib PLib
-- other-modules:
-- other-extensions:
build-depends: base >=4 && <5
diff --git a/testsuite/tests/ghc-api/exactprint/AddDecl1.expected.hs b/testsuite/tests/ghc-api/exactprint/AddDecl1.expected.hs
index 88ef0fdd7def..5e2e71b874e8 100644
--- a/testsuite/tests/ghc-api/exactprint/AddDecl1.expected.hs
+++ b/testsuite/tests/ghc-api/exactprint/AddDecl1.expected.hs
@@ -1,9 +1,9 @@
module AddDecl where
-nn = n2
-
-- Adding a declaration to an existing file
+nn = n2
+
-- | Do foo
foo a b = a + b
diff --git a/testsuite/tests/ghc-api/exactprint/Test20239.stderr b/testsuite/tests/ghc-api/exactprint/Test20239.stderr
index bb84374f1e32..877552eeac7a 100644
--- a/testsuite/tests/ghc-api/exactprint/Test20239.stderr
+++ b/testsuite/tests/ghc-api/exactprint/Test20239.stderr
@@ -198,7 +198,7 @@
(HsParTy
(EpAnn
(Anchor
- { Test20239.hs:7:50 }
+ { Test20239.hs:7:50-86 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
@@ -211,7 +211,7 @@
(HsFunTy
(EpAnn
(Anchor
- { Test20239.hs:7:51-60 }
+ { Test20239.hs:7:51-85 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -260,7 +260,7 @@
(HsParTy
(EpAnn
(Anchor
- { Test20239.hs:7:68 }
+ { Test20239.hs:7:68-85 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
@@ -311,7 +311,7 @@
(HsTupleTy
(EpAnn
(Anchor
- { Test20239.hs:7:83 }
+ { Test20239.hs:7:83-84 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
@@ -326,5 +326,5 @@
-Test20239.hs:5:15: [GHC-76037]
+Test20239.hs:5:15: error: [GHC-76037]
Not in scope: type constructor or class ‘Method’
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
index 869c7609ff00..2b0581e55bf5 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
@@ -83,7 +83,7 @@
(ClassOpSig
(EpAnn
(Anchor
- { T17544.hs:6:3-4 }
+ { T17544.hs:6:3-16 }
(UnchangedAnchor))
(AnnSig
(AddEpAnn AnnDcolon (EpaSpan { T17544.hs:6:6-7 }))
@@ -106,7 +106,7 @@
(HsFunTy
(EpAnn
(Anchor
- { T17544.hs:6:9 }
+ { T17544.hs:6:9-16 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -220,7 +220,7 @@
(ClassOpSig
(EpAnn
(Anchor
- { T17544.hs:10:3-4 }
+ { T17544.hs:10:3-16 }
(UnchangedAnchor))
(AnnSig
(AddEpAnn AnnDcolon (EpaSpan { T17544.hs:10:6-7 }))
@@ -243,7 +243,7 @@
(HsFunTy
(EpAnn
(Anchor
- { T17544.hs:10:9 }
+ { T17544.hs:10:9-16 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -355,7 +355,7 @@
(ClassOpSig
(EpAnn
(Anchor
- { T17544.hs:14:3-4 }
+ { T17544.hs:14:3-16 }
(UnchangedAnchor))
(AnnSig
(AddEpAnn AnnDcolon (EpaSpan { T17544.hs:14:6-7 }))
@@ -378,7 +378,7 @@
(HsFunTy
(EpAnn
(Anchor
- { T17544.hs:14:9 }
+ { T17544.hs:14:9-16 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -493,7 +493,7 @@
(ClassOpSig
(EpAnn
(Anchor
- { T17544.hs:18:3-4 }
+ { T17544.hs:18:3-16 }
(UnchangedAnchor))
(AnnSig
(AddEpAnn AnnDcolon (EpaSpan { T17544.hs:18:6-7 }))
@@ -516,7 +516,7 @@
(HsFunTy
(EpAnn
(Anchor
- { T17544.hs:18:9 }
+ { T17544.hs:18:9-16 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -561,7 +561,7 @@
(ClassOpSig
(EpAnn
(Anchor
- { T17544.hs:20:3-4 }
+ { T17544.hs:20:3-16 }
(UnchangedAnchor))
(AnnSig
(AddEpAnn AnnDcolon (EpaSpan { T17544.hs:20:6-7 }))
@@ -584,7 +584,7 @@
(HsFunTy
(EpAnn
(Anchor
- { T17544.hs:20:9 }
+ { T17544.hs:20:9-16 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -750,7 +750,7 @@
(Nothing)
(EpAnn
(Anchor
- { T17544.hs:23:1-8 }
+ { T17544.hs:(23,1)-(25,18) }
(UnchangedAnchor))
[(AddEpAnn AnnInstance (EpaSpan { T17544.hs:23:1-8 }))
,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:23:17-21 }))]
@@ -1028,7 +1028,7 @@
(Nothing)
(EpAnn
(Anchor
- { T17544.hs:29:1-8 }
+ { T17544.hs:(29,1)-(31,18) }
(UnchangedAnchor))
[(AddEpAnn AnnInstance (EpaSpan { T17544.hs:29:1-8 }))
,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:29:17-21 }))]
@@ -1306,7 +1306,7 @@
(Nothing)
(EpAnn
(Anchor
- { T17544.hs:35:1-8 }
+ { T17544.hs:(35,1)-(37,18) }
(UnchangedAnchor))
[(AddEpAnn AnnInstance (EpaSpan { T17544.hs:35:1-8 }))
,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:35:17-21 }))]
@@ -1584,7 +1584,7 @@
(Nothing)
(EpAnn
(Anchor
- { T17544.hs:41:1-8 }
+ { T17544.hs:(41,1)-(43,18) }
(UnchangedAnchor))
[(AddEpAnn AnnInstance (EpaSpan { T17544.hs:41:1-8 }))
,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:41:17-21 }))]
@@ -1862,7 +1862,7 @@
(Nothing)
(EpAnn
(Anchor
- { T17544.hs:47:1-8 }
+ { T17544.hs:(47,1)-(49,18) }
(UnchangedAnchor))
[(AddEpAnn AnnInstance (EpaSpan { T17544.hs:47:1-8 }))
,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:47:17-21 }))]
@@ -2140,7 +2140,7 @@
(Nothing)
(EpAnn
(Anchor
- { T17544.hs:53:1-8 }
+ { T17544.hs:(53,1)-(55,20) }
(UnchangedAnchor))
[(AddEpAnn AnnInstance (EpaSpan { T17544.hs:53:1-8 }))
,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:53:18-22 }))]
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
index 6d8d524ef17e..76a250341630 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
@@ -12,7 +12,7 @@
(AnnsModule
[(AddEpAnn AnnModule (EpaSpan { T17544_kw.hs:11:1-6 }))
,(AddEpAnn AnnWhere (EpaSpan { T17544_kw.hs:13:13-17 }))]
- []
+ []
(Just
((,)
{ T17544_kw.hs:25:1 }
@@ -211,7 +211,7 @@
(HsTupleTy
(EpAnn
(Anchor
- { T17544_kw.hs:19:18 }
+ { T17544_kw.hs:19:18-19 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
@@ -303,7 +303,7 @@
(ClassOpSig
(EpAnn
(Anchor
- { T17544_kw.hs:24:5-13 }
+ { T17544_kw.hs:24:5-18 }
(UnchangedAnchor))
(AnnSig
(AddEpAnn AnnDcolon (EpaSpan { T17544_kw.hs:24:15-16 }))
diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
index 6389ffcc91bf..be08561529bc 100644
--- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
@@ -201,7 +201,7 @@
(HsFunTy
(EpAnn
(Anchor
- { DumpParsedAst.hs:9:16-18 }
+ { DumpParsedAst.hs:9:16-27 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -216,7 +216,7 @@
(HsListTy
(EpAnn
(Anchor
- { DumpParsedAst.hs:9:16 }
+ { DumpParsedAst.hs:9:16-18 }
(UnchangedAnchor))
(AnnParen
(AnnParensSquare)
@@ -302,7 +302,7 @@
(HsParTy
(EpAnn
(Anchor
- { DumpParsedAst.hs:11:10 }
+ { DumpParsedAst.hs:11:10-17 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
@@ -374,7 +374,7 @@
(HsParTy
(EpAnn
(Anchor
- { DumpParsedAst.hs:11:26 }
+ { DumpParsedAst.hs:11:26-36 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
@@ -438,7 +438,7 @@
(HsExplicitListTy
(EpAnn
(Anchor
- { DumpParsedAst.hs:12:10 }
+ { DumpParsedAst.hs:12:10-12 }
(UnchangedAnchor))
[(AddEpAnn AnnSimpleQuote (EpaSpan { DumpParsedAst.hs:12:10 }))
,(AddEpAnn AnnOpenS (EpaSpan { DumpParsedAst.hs:12:11 }))
@@ -492,7 +492,7 @@
(HsListTy
(EpAnn
(Anchor
- { DumpParsedAst.hs:10:27 }
+ { DumpParsedAst.hs:10:27-29 }
(UnchangedAnchor))
(AnnParen
(AnnParensSquare)
@@ -652,7 +652,7 @@
(HsParTy
(EpAnn
(Anchor
- { DumpParsedAst.hs:15:25 }
+ { DumpParsedAst.hs:15:25-29 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
@@ -731,7 +731,7 @@
(HsFunTy
(EpAnn
(Anchor
- { DumpParsedAst.hs:17:12 }
+ { DumpParsedAst.hs:17:12-35 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -761,7 +761,7 @@
(HsFunTy
(EpAnn
(Anchor
- { DumpParsedAst.hs:17:17-27 }
+ { DumpParsedAst.hs:17:17-35 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -776,7 +776,7 @@
(HsParTy
(EpAnn
(Anchor
- { DumpParsedAst.hs:17:17 }
+ { DumpParsedAst.hs:17:17-27 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
@@ -789,7 +789,7 @@
(HsFunTy
(EpAnn
(Anchor
- { DumpParsedAst.hs:17:18 }
+ { DumpParsedAst.hs:17:18-26 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -1076,7 +1076,7 @@
(HsFunTy
(EpAnn
(Anchor
- { DumpParsedAst.hs:18:31 }
+ { DumpParsedAst.hs:18:31-39 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -1183,7 +1183,7 @@
(HsFunTy
(EpAnn
(Anchor
- { DumpParsedAst.hs:21:20 }
+ { DumpParsedAst.hs:21:20-33 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -1213,7 +1213,7 @@
(HsFunTy
(EpAnn
(Anchor
- { DumpParsedAst.hs:21:25 }
+ { DumpParsedAst.hs:21:25-33 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -1291,7 +1291,7 @@
(HsParTy
(EpAnn
(Anchor
- { DumpParsedAst.hs:22:22 }
+ { DumpParsedAst.hs:22:22-37 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
@@ -1304,7 +1304,7 @@
(HsKindSig
(EpAnn
(Anchor
- { DumpParsedAst.hs:22:23 }
+ { DumpParsedAst.hs:22:23-36 }
(UnchangedAnchor))
[(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:22:25-26 }))]
(EpaComments
@@ -1329,7 +1329,7 @@
(HsFunTy
(EpAnn
(Anchor
- { DumpParsedAst.hs:22:28 }
+ { DumpParsedAst.hs:22:28-36 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -1380,7 +1380,7 @@
(HsFunTy
(EpAnn
(Anchor
- { DumpParsedAst.hs:22:42-52 }
+ { DumpParsedAst.hs:22:42-60 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -1395,7 +1395,7 @@
(HsParTy
(EpAnn
(Anchor
- { DumpParsedAst.hs:22:42 }
+ { DumpParsedAst.hs:22:42-52 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
@@ -1408,7 +1408,7 @@
(HsFunTy
(EpAnn
(Anchor
- { DumpParsedAst.hs:22:43 }
+ { DumpParsedAst.hs:22:43-51 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -1508,7 +1508,7 @@
(HsParTy
(EpAnn
(Anchor
- { DumpParsedAst.hs:23:10 }
+ { DumpParsedAst.hs:23:10-34 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
@@ -1523,7 +1523,7 @@
(HsForAllInvis
(EpAnn
(Anchor
- { DumpParsedAst.hs:23:11-16 }
+ { DumpParsedAst.hs:23:11-20 }
(UnchangedAnchor))
((,)
(AddEpAnn AnnForall (EpaSpan { DumpParsedAst.hs:23:11-16 }))
@@ -1550,7 +1550,7 @@
(HsFunTy
(EpAnn
(Anchor
- { DumpParsedAst.hs:23:22-25 }
+ { DumpParsedAst.hs:23:22-33 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
index 7b65432466d8..ea2a4172182d 100644
--- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
@@ -315,7 +315,7 @@
(HsListTy
(EpAnn
(Anchor
- { DumpRenamedAst.hs:12:27 }
+ { DumpRenamedAst.hs:12:27-29 }
(UnchangedAnchor))
(AnnParen
(AnnParensSquare)
@@ -373,7 +373,7 @@
(HsFunTy
(EpAnn
(Anchor
- { DumpRenamedAst.hs:11:16-18 }
+ { DumpRenamedAst.hs:11:16-27 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -388,7 +388,7 @@
(HsListTy
(EpAnn
(Anchor
- { DumpRenamedAst.hs:11:16 }
+ { DumpRenamedAst.hs:11:16-18 }
(UnchangedAnchor))
(AnnParen
(AnnParensSquare)
@@ -448,7 +448,7 @@
(HsFunTy
(EpAnn
(Anchor
- { DumpRenamedAst.hs:16:20 }
+ { DumpRenamedAst.hs:16:20-33 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -471,7 +471,7 @@
(HsFunTy
(EpAnn
(Anchor
- { DumpRenamedAst.hs:16:25 }
+ { DumpRenamedAst.hs:16:25-33 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -530,7 +530,7 @@
(HsKindSig
(EpAnn
(Anchor
- { DumpRenamedAst.hs:19:23 }
+ { DumpRenamedAst.hs:19:23-36 }
(UnchangedAnchor))
[(AddEpAnn AnnDcolon (EpaSpan { DumpRenamedAst.hs:19:25-26 }))]
(EpaComments
@@ -548,7 +548,7 @@
(HsFunTy
(EpAnn
(Anchor
- { DumpRenamedAst.hs:19:28 }
+ { DumpRenamedAst.hs:19:28-36 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -585,7 +585,7 @@
(HsFunTy
(EpAnn
(Anchor
- { DumpRenamedAst.hs:19:42-52 }
+ { DumpRenamedAst.hs:19:42-60 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -604,7 +604,7 @@
(HsFunTy
(EpAnn
(Anchor
- { DumpRenamedAst.hs:19:43 }
+ { DumpRenamedAst.hs:19:43-51 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -701,7 +701,7 @@
(HsFunTy
(EpAnn
(Anchor
- { DumpRenamedAst.hs:20:22-25 }
+ { DumpRenamedAst.hs:20:22-33 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -1061,7 +1061,7 @@
(HsFunTy
(EpAnn
(Anchor
- { DumpRenamedAst.hs:25:31 }
+ { DumpRenamedAst.hs:25:31-39 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -1129,7 +1129,7 @@
(HsFunTy
(EpAnn
(Anchor
- { DumpRenamedAst.hs:24:12 }
+ { DumpRenamedAst.hs:24:12-35 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -1152,7 +1152,7 @@
(HsFunTy
(EpAnn
(Anchor
- { DumpRenamedAst.hs:24:17-27 }
+ { DumpRenamedAst.hs:24:17-35 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -1171,7 +1171,7 @@
(HsFunTy
(EpAnn
(Anchor
- { DumpRenamedAst.hs:24:18 }
+ { DumpRenamedAst.hs:24:18-26 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -1334,7 +1334,7 @@
(HsListTy
(EpAnn
(Anchor
- { DumpRenamedAst.hs:31:12 }
+ { DumpRenamedAst.hs:31:12-14 }
(UnchangedAnchor))
(AnnParen
(AnnParensSquare)
@@ -1376,7 +1376,7 @@
(HsListTy
(EpAnn
(Anchor
- { DumpRenamedAst.hs:32:10 }
+ { DumpRenamedAst.hs:32:10-12 }
(UnchangedAnchor))
(AnnParen
(AnnParensSquare)
diff --git a/testsuite/tests/parser/should_compile/DumpSemis.stderr b/testsuite/tests/parser/should_compile/DumpSemis.stderr
index 6ead4e3dceae..2497f5ab94c5 100644
--- a/testsuite/tests/parser/should_compile/DumpSemis.stderr
+++ b/testsuite/tests/parser/should_compile/DumpSemis.stderr
@@ -152,7 +152,7 @@
(TypeSig
(EpAnn
(Anchor
- { DumpSemis.hs:9:1-3 }
+ { DumpSemis.hs:9:1-12 }
(UnchangedAnchor))
(AnnSig
(AddEpAnn AnnDcolon (EpaSpan { DumpSemis.hs:9:5-6 }))
@@ -195,7 +195,7 @@
(HsTupleTy
(EpAnn
(Anchor
- { DumpSemis.hs:9:11 }
+ { DumpSemis.hs:9:11-12 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
@@ -394,7 +394,7 @@
(TypeSig
(EpAnn
(Anchor
- { DumpSemis.hs:14:1-3 }
+ { DumpSemis.hs:14:1-12 }
(UnchangedAnchor))
(AnnSig
(AddEpAnn AnnDcolon (EpaSpan { DumpSemis.hs:14:5-6 }))
@@ -437,7 +437,7 @@
(HsTupleTy
(EpAnn
(Anchor
- { DumpSemis.hs:14:11 }
+ { DumpSemis.hs:14:11-12 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
@@ -604,7 +604,7 @@
(TypeSig
(EpAnn
(Anchor
- { DumpSemis.hs:21:1-3 }
+ { DumpSemis.hs:21:1-12 }
(UnchangedAnchor))
(AnnSig
(AddEpAnn AnnDcolon (EpaSpan { DumpSemis.hs:21:5-6 }))
@@ -647,7 +647,7 @@
(HsTupleTy
(EpAnn
(Anchor
- { DumpSemis.hs:21:11 }
+ { DumpSemis.hs:21:11-12 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
@@ -1101,7 +1101,7 @@
(ClassOpSig
(EpAnn
(Anchor
- { DumpSemis.hs:29:3-7 }
+ { DumpSemis.hs:29:3-23 }
(UnchangedAnchor))
(AnnSig
(AddEpAnn AnnDcolon (EpaSpan { DumpSemis.hs:29:9-10 }))
@@ -1124,7 +1124,7 @@
(HsFunTy
(EpAnn
(Anchor
- { DumpSemis.hs:29:12-16 }
+ { DumpSemis.hs:29:12-23 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -1183,7 +1183,7 @@
(TypeSig
(EpAnn
(Anchor
- { DumpSemis.hs:31:1 }
+ { DumpSemis.hs:31:1-30 }
(UnchangedAnchor))
(AnnSig
(AddEpAnn AnnDcolon (EpaSpan { DumpSemis.hs:31:3-4 }))
@@ -1303,7 +1303,7 @@
(HsFunTy
(EpAnn
(Anchor
- { DumpSemis.hs:31:25 }
+ { DumpSemis.hs:31:25-30 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr
index 40dc650b73f3..d047f37c72d5 100644
--- a/testsuite/tests/parser/should_compile/KindSigs.stderr
+++ b/testsuite/tests/parser/should_compile/KindSigs.stderr
@@ -120,7 +120,7 @@
(HsKindSig
(EpAnn
(Anchor
- { KindSigs.hs:12:11-13 }
+ { KindSigs.hs:12:11-21 }
(UnchangedAnchor))
[(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:12:15-16 }))]
(EpaComments
@@ -232,7 +232,7 @@
(HsTupleTy
(EpAnn
(Anchor
- { KindSigs.hs:15:14 }
+ { KindSigs.hs:15:14-51 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
@@ -254,7 +254,7 @@
(HsKindSig
(EpAnn
(Anchor
- { KindSigs.hs:15:16-18 }
+ { KindSigs.hs:15:16-26 }
(UnchangedAnchor))
[(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:15:20-21 }))]
(EpaComments
@@ -317,7 +317,7 @@
(HsKindSig
(EpAnn
(Anchor
- { KindSigs.hs:15:35-41 }
+ { KindSigs.hs:15:35-49 }
(UnchangedAnchor))
[(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:15:43-44 }))]
(EpaComments
@@ -418,7 +418,7 @@
(HsTupleTy
(EpAnn
(Anchor
- { KindSigs.hs:16:15-16 }
+ { KindSigs.hs:16:15-54 }
(UnchangedAnchor))
(AnnParen
(AnnParensHash)
@@ -440,7 +440,7 @@
(HsKindSig
(EpAnn
(Anchor
- { KindSigs.hs:16:18-20 }
+ { KindSigs.hs:16:18-28 }
(UnchangedAnchor))
[(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:16:22-23 }))]
(EpaComments
@@ -503,7 +503,7 @@
(HsKindSig
(EpAnn
(Anchor
- { KindSigs.hs:16:37-43 }
+ { KindSigs.hs:16:37-51 }
(UnchangedAnchor))
[(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:16:45-46 }))]
(EpaComments
@@ -590,7 +590,7 @@
(HsListTy
(EpAnn
(Anchor
- { KindSigs.hs:19:12 }
+ { KindSigs.hs:19:12-26 }
(UnchangedAnchor))
(AnnParen
(AnnParensSquare)
@@ -603,7 +603,7 @@
(HsKindSig
(EpAnn
(Anchor
- { KindSigs.hs:19:14-16 }
+ { KindSigs.hs:19:14-24 }
(UnchangedAnchor))
[(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:19:18-19 }))]
(EpaComments
@@ -652,7 +652,7 @@
(TypeSig
(EpAnn
(Anchor
- { KindSigs.hs:22:1-3 }
+ { KindSigs.hs:22:1-44 }
(UnchangedAnchor))
(AnnSig
(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:22:5-6 }))
@@ -676,7 +676,7 @@
(HsFunTy
(EpAnn
(Anchor
- { KindSigs.hs:22:8-20 }
+ { KindSigs.hs:22:8-44 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -691,7 +691,7 @@
(HsParTy
(EpAnn
(Anchor
- { KindSigs.hs:22:8 }
+ { KindSigs.hs:22:8-20 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
@@ -704,7 +704,7 @@
(HsKindSig
(EpAnn
(Anchor
- { KindSigs.hs:22:9-11 }
+ { KindSigs.hs:22:9-19 }
(UnchangedAnchor))
[(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:22:13-14 }))]
(EpaComments
@@ -744,7 +744,7 @@
(HsFunTy
(EpAnn
(Anchor
- { KindSigs.hs:22:25-28 }
+ { KindSigs.hs:22:25-44 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -774,7 +774,7 @@
(HsParTy
(EpAnn
(Anchor
- { KindSigs.hs:22:33 }
+ { KindSigs.hs:22:33-44 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
@@ -787,7 +787,7 @@
(HsKindSig
(EpAnn
(Anchor
- { KindSigs.hs:22:34-35 }
+ { KindSigs.hs:22:34-43 }
(UnchangedAnchor))
[(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:22:37-38 }))]
(EpaComments
@@ -797,7 +797,7 @@
(HsTupleTy
(EpAnn
(Anchor
- { KindSigs.hs:22:34 }
+ { KindSigs.hs:22:34-35 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
@@ -946,7 +946,7 @@
(HsExplicitListTy
(EpAnn
(Anchor
- { KindSigs.hs:26:13 }
+ { KindSigs.hs:26:13-29 }
(UnchangedAnchor))
[(AddEpAnn AnnSimpleQuote (EpaSpan { KindSigs.hs:26:13 }))
,(AddEpAnn AnnOpenS (EpaSpan { KindSigs.hs:26:14 }))
@@ -959,7 +959,7 @@
(HsKindSig
(EpAnn
(Anchor
- { KindSigs.hs:26:16-19 }
+ { KindSigs.hs:26:16-27 }
(UnchangedAnchor))
[(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:26:21-22 }))]
(EpaComments
@@ -1027,7 +1027,7 @@
(HsExplicitListTy
(EpAnn
(Anchor
- { KindSigs.hs:27:14 }
+ { KindSigs.hs:27:14-45 }
(UnchangedAnchor))
[(AddEpAnn AnnOpenS (EpaSpan { KindSigs.hs:27:14 }))
,(AddEpAnn AnnCloseS (EpaSpan { KindSigs.hs:27:45 }))]
@@ -1047,7 +1047,7 @@
(HsKindSig
(EpAnn
(Anchor
- { KindSigs.hs:27:16-19 }
+ { KindSigs.hs:27:16-27 }
(UnchangedAnchor))
[(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:27:21-22 }))]
(EpaComments
@@ -1087,7 +1087,7 @@
(HsKindSig
(EpAnn
(Anchor
- { KindSigs.hs:27:30-34 }
+ { KindSigs.hs:27:30-42 }
(UnchangedAnchor))
[(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:27:36-37 }))]
(EpaComments
@@ -1169,7 +1169,7 @@
(HsExplicitTupleTy
(EpAnn
(Anchor
- { KindSigs.hs:28:16 }
+ { KindSigs.hs:28:16-44 }
(UnchangedAnchor))
[(AddEpAnn AnnSimpleQuote (EpaSpan { KindSigs.hs:28:16 }))
,(AddEpAnn AnnOpenP (EpaSpan { KindSigs.hs:28:17 }))
@@ -1189,7 +1189,7 @@
(HsKindSig
(EpAnn
(Anchor
- { KindSigs.hs:28:19-29 }
+ { KindSigs.hs:28:19-39 }
(UnchangedAnchor))
[(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:28:31-32 }))]
(EpaComments
@@ -1199,7 +1199,7 @@
(HsExplicitListTy
(EpAnn
(Anchor
- { KindSigs.hs:28:19 }
+ { KindSigs.hs:28:19-29 }
(UnchangedAnchor))
[(AddEpAnn AnnOpenS (EpaSpan { KindSigs.hs:28:19 }))
,(AddEpAnn AnnCloseS (EpaSpan { KindSigs.hs:28:29 }))]
@@ -1249,7 +1249,7 @@
(HsListTy
(EpAnn
(Anchor
- { KindSigs.hs:28:34 }
+ { KindSigs.hs:28:34-39 }
(UnchangedAnchor))
(AnnParen
(AnnParensSquare)
@@ -1320,7 +1320,7 @@
(HsKindSig
(EpAnn
(Anchor
- { KindSigs.hs:31:21-23 }
+ { KindSigs.hs:31:21-31 }
(UnchangedAnchor))
[(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:31:25-26 }))]
(EpaComments
@@ -1369,7 +1369,7 @@
(TypeSig
(EpAnn
(Anchor
- { KindSigs.hs:34:1-4 }
+ { KindSigs.hs:34:1-22 }
(UnchangedAnchor))
(AnnSig
(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:34:6-7 }))
@@ -1393,7 +1393,7 @@
(HsParTy
(EpAnn
(Anchor
- { KindSigs.hs:34:9 }
+ { KindSigs.hs:34:9-22 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
@@ -1406,7 +1406,7 @@
(HsKindSig
(EpAnn
(Anchor
- { KindSigs.hs:34:10-13 }
+ { KindSigs.hs:34:10-21 }
(UnchangedAnchor))
[(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:34:15-16 }))]
(EpaComments
diff --git a/testsuite/tests/parser/should_compile/T14189.stderr b/testsuite/tests/parser/should_compile/T14189.stderr
index 5fd2724f1650..431ae3845ae1 100644
--- a/testsuite/tests/parser/should_compile/T14189.stderr
+++ b/testsuite/tests/parser/should_compile/T14189.stderr
@@ -114,7 +114,7 @@
(L
(SrcSpanAnn (EpAnn
(Anchor
- { T14189.hs:6:31 }
+ { T14189.hs:6:31-42 }
(UnchangedAnchor))
(AnnList
(Just
diff --git a/testsuite/tests/parser/should_compile/T15323.stderr b/testsuite/tests/parser/should_compile/T15323.stderr
index 9ec7d7748d94..1da3125d2a30 100644
--- a/testsuite/tests/parser/should_compile/T15323.stderr
+++ b/testsuite/tests/parser/should_compile/T15323.stderr
@@ -102,16 +102,16 @@
(L
(SrcSpanAnn (EpAnn
(Anchor
- { T15323.hs:6:20-25 }
+ { T15323.hs:6:20-29 }
(UnchangedAnchor))
(AnnListItem
[])
(EpaComments
- [])) { T15323.hs:6:20-25 })
+ [])) { T15323.hs:6:20-29 })
(HsOuterExplicit
(EpAnn
(Anchor
- { T15323.hs:6:20-25 }
+ { T15323.hs:6:20-29 }
(UnchangedAnchor))
((,)
(AddEpAnn AnnForall (EpaSpan { T15323.hs:6:20-25 }))
@@ -153,7 +153,7 @@
(HsParTy
(EpAnn
(Anchor
- { T15323.hs:6:31 }
+ { T15323.hs:6:31-36 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
diff --git a/testsuite/tests/parser/should_compile/T20452.stderr b/testsuite/tests/parser/should_compile/T20452.stderr
index a3bb2e778172..77a5dff85ebf 100644
--- a/testsuite/tests/parser/should_compile/T20452.stderr
+++ b/testsuite/tests/parser/should_compile/T20452.stderr
@@ -334,7 +334,7 @@
(HsListTy
(EpAnn
(Anchor
- { T20452.hs:8:57 }
+ { T20452.hs:8:57-74 }
(UnchangedAnchor))
(AnnParen
(AnnParensSquare)
@@ -347,7 +347,7 @@
(HsTupleTy
(EpAnn
(Anchor
- { T20452.hs:8:58 }
+ { T20452.hs:8:58-73 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
@@ -534,7 +534,7 @@
(HsListTy
(EpAnn
(Anchor
- { T20452.hs:9:57 }
+ { T20452.hs:9:57-74 }
(UnchangedAnchor))
(AnnParen
(AnnParensSquare)
@@ -547,7 +547,7 @@
(HsTupleTy
(EpAnn
(Anchor
- { T20452.hs:9:58 }
+ { T20452.hs:9:58-73 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
diff --git a/testsuite/tests/parser/should_compile/T20846.stderr b/testsuite/tests/parser/should_compile/T20846.stderr
index 4a1981b6e10a..a19f42be17a8 100644
--- a/testsuite/tests/parser/should_compile/T20846.stderr
+++ b/testsuite/tests/parser/should_compile/T20846.stderr
@@ -44,7 +44,7 @@
(FixSig
(EpAnn
(Anchor
- { T20846.hs:3:1-6 }
+ { T20846.hs:3:1-11 }
(UnchangedAnchor))
[(AddEpAnn AnnInfix (EpaSpan { T20846.hs:3:1-6 }))]
(EpaComments
@@ -145,3 +145,5 @@
{OccName: undefined}))))))]
(EmptyLocalBinds
(NoExtField)))))])))))]))
+
+
diff --git a/testsuite/tests/parser/should_compile/T23315/T23315.stderr b/testsuite/tests/parser/should_compile/T23315/T23315.stderr
index 1cc94f80b84a..4a4f2637d9bb 100644
--- a/testsuite/tests/parser/should_compile/T23315/T23315.stderr
+++ b/testsuite/tests/parser/should_compile/T23315/T23315.stderr
@@ -12,7 +12,7 @@
(AnnsModule
[(AddEpAnn AnnSignature (EpaSpan { T23315.hsig:1:1-9 }))
,(AddEpAnn AnnWhere (EpaSpan { T23315.hsig:1:18-22 }))]
- []
+ []
(Nothing))
(EpaComments
[]))
@@ -57,7 +57,7 @@
(TypeSig
(EpAnn
(Anchor
- { T23315.hsig:3:1 }
+ { T23315.hsig:3:1-7 }
(UnchangedAnchor))
(AnnSig
(AddEpAnn AnnDcolon (EpaSpan { T23315.hsig:3:3-4 }))
@@ -81,7 +81,7 @@
(HsTupleTy
(EpAnn
(Anchor
- { T23315.hsig:3:6 }
+ { T23315.hsig:3:6-7 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index d16f17af347b..add9eaf4fbd4 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -68,6 +68,8 @@ import qualified Data.Map.Strict as Map
import Data.Maybe ( isJust, mapMaybe )
import Data.Void
+import Orphans ()
+
import Lookup
import Utils
import Types
@@ -108,13 +110,14 @@ runEP epReader action = do
defaultEPState :: EPState
defaultEPState = EPState
{ epPos = (1,1)
- , dLHS = 1
+ , dLHS = 0
, pMarkLayout = False
- , pLHS = 1
+ , pLHS = 0
, dMarkLayout = False
, dPriorEndPosition = (1,1)
, uAnchorSpan = badRealSrcSpan
, uExtraDP = Nothing
+ , pAcceptSpan = False
, epComments = []
, epCommentsApplied = []
, epEof = Nothing
@@ -176,6 +179,13 @@ data EPState = EPState
-- Annotation
, uExtraDP :: !(Maybe Anchor) -- ^ Used to anchor a
-- list
+ , pAcceptSpan :: Bool -- ^ When we have processed an
+ -- entry of EpaDelta, accept the
+ -- next `EpaSpan` start as the
+ -- current output position. i.e. do
+ -- not advance epPos. Achieved by
+ -- setting dPriorEndPosition to the
+ -- end of the span.
-- Print phase
, epPos :: !Pos -- ^ Current output position
@@ -201,6 +211,34 @@ data EPState = EPState
class HasEntry ast where
fromAnn :: ast -> Entry
+class HasTrailing a where
+ trailing :: a -> [TrailingAnn]
+ setTrailing :: a -> [TrailingAnn] -> a
+
+setAnchorEpa :: (HasTrailing an, NoAnn an)
+ => EpAnn an -> Anchor -> [TrailingAnn] -> EpAnnComments -> EpAnn an
+setAnchorEpa EpAnnNotUsed anc ts cs = EpAnn anc (setTrailing noAnn ts) cs
+setAnchorEpa (EpAnn _ an _) anc ts cs = EpAnn anc (setTrailing an ts) cs
+
+setAnchorHsModule :: HsModule GhcPs -> Anchor -> EpAnnComments -> HsModule GhcPs
+setAnchorHsModule hsmod anc cs = hsmod { hsmodExt = (hsmodExt hsmod) {hsmodAnn = an'} }
+ where
+ anc' = anc
+ an' = setAnchorEpa (hsmodAnn $ hsmodExt hsmod) anc' [] cs
+
+setAnchorAn :: (HasTrailing an, NoAnn an)
+ => LocatedAn an a -> Anchor -> [TrailingAnn] -> EpAnnComments -> LocatedAn an a
+setAnchorAn (L (SrcSpanAnn EpAnnNotUsed l) a) anc ts cs
+ = (L (SrcSpanAnn (EpAnn anc (setTrailing noAnn ts) cs) l) a)
+ -- `debug` ("setAnchorAn: anc=" ++ showAst anc)
+setAnchorAn (L (SrcSpanAnn (EpAnn _ an _) l) a) anc ts cs
+ = (L (SrcSpanAnn (EpAnn anc (setTrailing an ts) cs) l) a)
+ -- `debug` ("setAnchorAn: anc=" ++ showAst anc)
+
+setAnchorEpaL :: EpAnn AnnList -> Anchor -> [TrailingAnn] -> EpAnnComments -> EpAnn AnnList
+setAnchorEpaL EpAnnNotUsed anc ts cs = EpAnn anc (setTrailing noAnn ts) cs
+setAnchorEpaL (EpAnn _ an _) anc ts cs = EpAnn anc (setTrailing (an {al_anchor = Nothing}) ts) cs
+
-- ---------------------------------------------------------------------
-- | Key entry point. Switches to an independent AST element with its
@@ -220,30 +258,134 @@ data CanUpdateAnchor = CanUpdateAnchor
| NoCanUpdateAnchor
deriving (Eq, Show)
-data Entry = Entry Anchor EpAnnComments FlushComments CanUpdateAnchor
+data Entry = Entry Anchor [TrailingAnn] EpAnnComments FlushComments CanUpdateAnchor
| NoEntryVal
-- | For flagging whether to capture comments in an EpaDelta or not
data CaptureComments = CaptureComments
| NoCaptureComments
-mkEntry :: Anchor -> EpAnnComments -> Entry
-mkEntry anc cs = Entry anc cs NoFlushComments CanUpdateAnchor
+mkEntry :: Anchor -> [TrailingAnn] -> EpAnnComments -> Entry
+mkEntry anc ts cs = Entry anc ts cs NoFlushComments CanUpdateAnchor
-instance HasEntry (SrcSpanAnn' (EpAnn an)) where
- fromAnn (SrcSpanAnn EpAnnNotUsed ss) = mkEntry (spanAsAnchor ss) emptyComments
+instance (HasTrailing an) => HasEntry (SrcSpanAnn' (EpAnn an)) where
+ fromAnn (SrcSpanAnn EpAnnNotUsed ss) = mkEntry (spanAsAnchor ss) [] emptyComments
fromAnn (SrcSpanAnn an _) = fromAnn an
-instance HasEntry (EpAnn a) where
- fromAnn (EpAnn anchor _ cs) = mkEntry anchor cs
+instance (HasTrailing a) => HasEntry (EpAnn a) where
+ fromAnn (EpAnn anc a cs) = mkEntry anc (trailing a) cs
fromAnn EpAnnNotUsed = NoEntryVal
-- ---------------------------------------------------------------------
+instance HasTrailing NoEpAnns where
+ trailing _ = []
+ setTrailing a _ = a
+
+instance HasTrailing EpaLocation where
+ trailing _ = []
+ setTrailing a _ = a
+
+instance HasTrailing AddEpAnn where
+ trailing _ = []
+ setTrailing a _ = a
+
+instance HasTrailing [AddEpAnn] where
+ trailing _ = []
+ setTrailing a _ = a
+
+instance HasTrailing (AddEpAnn, AddEpAnn) where
+ trailing _ = []
+ setTrailing a _ = a
+
+instance HasTrailing EpAnnSumPat where
+ trailing _ = []
+ setTrailing a _ = a
+
+instance HasTrailing AnnList where
+ trailing a = al_trailing a
+ setTrailing a ts = a { al_trailing = ts }
+
+instance HasTrailing AnnListItem where
+ trailing a = lann_trailing a
+ setTrailing a ts = a { lann_trailing = ts }
+
+instance HasTrailing AnnPragma where
+ trailing _ = []
+ setTrailing a _ = a
+
+instance HasTrailing AnnContext where
+ trailing (AnnContext ma _opens _closes)
+ = case ma of
+ Just (UnicodeSyntax, r) -> [AddDarrowUAnn r]
+ Just (NormalSyntax, r) -> [AddDarrowAnn r]
+ Nothing -> []
+
+ setTrailing a [AddDarrowUAnn r] = a {ac_darrow = Just (UnicodeSyntax, r)}
+ setTrailing a [AddDarrowAnn r] = a{ac_darrow = Just (NormalSyntax, r)}
+ setTrailing a [] = a{ac_darrow = Nothing}
+ setTrailing a ts = error $ "Cannot setTrailing " ++ showAst ts ++ " for " ++ showAst a
+
+
+instance HasTrailing AnnParen where
+ trailing _ = []
+ setTrailing a _ = a
+
+instance HasTrailing AnnsIf where
+ trailing _ = []
+ setTrailing a _ = a
+
+instance HasTrailing EpAnnHsCase where
+ trailing _ = []
+ setTrailing a _ = a
+
+instance HasTrailing AnnFieldLabel where
+ trailing _ = []
+ setTrailing a _ = a
+
+instance HasTrailing AnnProjection where
+ trailing _ = []
+ setTrailing a _ = a
+
+instance HasTrailing AnnExplicitSum where
+ trailing _ = []
+ setTrailing a _ = a
+
+instance HasTrailing EpAnnUnboundVar where
+ trailing _ = []
+ setTrailing a _ = a
+
+instance HasTrailing GrhsAnn where
+ trailing _ = []
+ setTrailing a _ = a
+
+instance HasTrailing AnnSig where
+ trailing _ = []
+ setTrailing a _ = a
+
+instance HasTrailing HsRuleAnn where
+ trailing _ = []
+ setTrailing a _ = a
+
+instance HasTrailing EpAnnImportDecl where
+ trailing _ = []
+ setTrailing a _ = a
+
+instance HasTrailing AnnsModule where
+ -- Report none, as all are used internally
+ trailing _ = []
+ setTrailing a _ = a
+
+instance HasTrailing NameAnn where
+ trailing a = nann_trailing a
+ setTrailing a ts = a { nann_trailing = ts }
+
+-- ---------------------------------------------------------------------
+
fromAnn' :: (HasEntry a) => a -> Entry
fromAnn' an = case fromAnn an of
NoEntryVal -> NoEntryVal
- Entry a c _ u -> Entry a c FlushComments u
+ Entry a ts c _ u -> Entry a ts c FlushComments u
-- ---------------------------------------------------------------------
@@ -257,6 +399,7 @@ cua NoCanUpdateAnchor _ = return []
-- | "Enter" an annotation, by using the associated 'anchor' field as
-- the new reference point for calculating all DeltaPos positions.
+-- This is the heart of the exact printing process.
--
-- This is combination of the ghc=exactprint Delta.withAST and
-- Print.exactPC functions and effectively does the delta processing
@@ -268,28 +411,48 @@ enterAnn NoEntryVal a = do
r <- exact a
debugM $ "enterAnn:done:NO ANN:p =" ++ show (p, astId a)
return r
-enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do
+enterAnn (Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
+ acceptSpan <- getAcceptSpan
+ setAcceptSpan False
+ case anchor' of
+ Anchor _ (MovedAnchor _ _) -> setAcceptSpan True
+ _ -> return ()
p <- getPosP
- debugM $ "enterAnn:starting:(p,a) =" ++ show (p, astId a)
- -- debugM $ "enterAnn:(cs) =" ++ showGhc (cs)
- let curAnchor = anchor anchor' -- As a base for the current AST element
+ pe0 <- getPriorEndD
+ debugM $ "enterAnn:starting:(p,pe,anchor',a) =" ++ show (p, pe0, showAst anchor', astId a)
+ debugM $ "enterAnn:anchor_op=" ++ showGhc (anchor_op anchor')
+ prevAnchor <- getAnchorU
+ let curAnchor = case anchor' of
+ Anchor r UnchangedAnchor -> r
+ _ -> prevAnchor
debugM $ "enterAnn:(curAnchor):=" ++ show (rs2range curAnchor)
case canUpdateAnchor of
CanUpdateAnchor -> pushAppliedComments
_ -> return ()
- addCommentsA (priorComments cs)
+ case anchor' of
+ Anchor _ (MovedAnchor _ dcs) -> do
+ debugM $ "enterAnn:Printing comments:" ++ showGhc (priorComments cs)
+ mapM_ printOneComment (concatMap tokComment $ priorComments cs)
+ debugM $ "enterAnn:Printing EpaDelta comments:" ++ showGhc dcs
+ mapM_ printOneComment (concatMap tokComment dcs)
+ _ -> do
+ debugM $ "enterAnn:Adding comments:" ++ showGhc (priorComments cs)
+ addCommentsA (priorComments cs)
debugM $ "enterAnn:Added comments"
- printComments curAnchor
+ printCommentsBefore curAnchor
priorCs <- cua canUpdateAnchor takeAppliedComments -- no pop
-- -------------------------
case anchor_op anchor' of
- MovedAnchor dp -> do
+ MovedAnchor dp _ -> do
debugM $ "enterAnn: MovedAnchor:" ++ show dp
-- Set the original anchor as prior end, so the rest of this AST
-- fragment has a reference
setPriorEndNoLayoutD (ss2pos curAnchor)
_ -> do
- return ()
+ if acceptSpan
+ then setPriorEndNoLayoutD (ss2pos curAnchor)
+ else return ()
+
-- -------------------------
if ((fst $ fst $ rs2range curAnchor) >= 0)
then
@@ -322,7 +485,7 @@ enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do
off (ss2delta priorEndAfterComments curAnchor)
debugM $ "enterAnn: (edp',off,priorEndAfterComments,curAnchor):" ++ show (edp',off,priorEndAfterComments,rs2range curAnchor)
let edp'' = case anchor_op anchor' of
- MovedAnchor dp -> dp
+ MovedAnchor dp _ -> dp
_ -> edp'
-- ---------------------------------------------
-- let edp = edp''
@@ -330,14 +493,13 @@ enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do
setExtraDP Nothing
let edp = case med of
Nothing -> edp''
- Just (Anchor _ (MovedAnchor dp)) -> dp
+ Just (Anchor _ (MovedAnchor dp _)) -> dp
-- Replace original with desired one. Allows all
-- list entry values to be DP (1,0)
Just (Anchor r _) -> dp
where
dp = adjustDeltaForOffset
off (ss2delta priorEndAfterComments r)
- when (isJust med) $ debugM $ "enterAnn:(med,edp)=" ++ show (med,edp)
-- ---------------------------------------------
-- Preparation complete, perform the action
when (priorEndAfterComments < spanStart) (do
@@ -345,7 +507,7 @@ enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do
modify (\s -> s { dPriorEndPosition = spanStart } ))
debugM $ "enterAnn: (anchor_op, curAnchor):" ++ show (anchor_op anchor', rs2range curAnchor)
- debugM $ "enterAnn: (dLHS,spanStart,pec,edp)=" ++ show (off,spanStart,priorEndAfterComments,edp)
+ -- debugM $ "enterAnn: (dLHS,spanStart,pec,edp)=" ++ show (off,spanStart,priorEndAfterComments,edp)
p0 <- getPosP
d <- getPriorEndD
debugM $ "enterAnn: (posp, posd)=" ++ show (p0,d)
@@ -354,21 +516,12 @@ enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do
-- -------------------------------------------------------------------
-- start of print phase processing
- let mflush = when (flush == FlushComments) $ do
- debugM $ "flushing comments in enterAnn:" ++ showAst cs
- flushComments (getFollowingComments cs)
-
advance edp
a' <- exact a
- mflush
-
- -- end of sub-Anchor processing, start of tail end processing
- postCs <- cua canUpdateAnchor takeAppliedCommentsPop
- when (flush == NoFlushComments) $ do
- when ((getFollowingComments cs) /= []) $ do
- debugM $ "starting trailing comments:" ++ showAst (getFollowingComments cs)
- mapM_ printOneComment (concatMap tokComment $ getFollowingComments cs)
- debugM $ "ending trailing comments"
+ when (flush == FlushComments) $ do
+ debugM $ "flushing comments in enterAnn:" ++ showAst cs
+ flushComments (getFollowingComments cs)
+ debugM $ "flushing comments in enterAnn done"
eof <- getEofPos
case eof of
@@ -377,18 +530,41 @@ enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do
let dp = if pos == prior
then (DifferentLine 1 0)
else origDelta pos prior
- debugM $ "EOF:(pos,prior,dp) =" ++ showGhc (ss2pos pos, ss2pos prior, dp)
+ debugM $ "EOF:(pos,posEnd,prior,dp) =" ++ showGhc (ss2pos pos, ss2posEnd pos, ss2pos prior, dp)
printStringAtLsDelta dp ""
setEofPos Nothing -- Only do this once
- let newAchor = anchor' { anchor_op = MovedAnchor edp }
+ -- Deal with exit from the current anchor
+ when (flush == NoFlushComments) $ do
+ printCommentsIn curAnchor -- Make sure all comments in the span are printed
+
+ p1 <- getPosP
+ pe1 <- getPriorEndD
+ debugM $ "enterAnn:done:(p,pe,anchor,a) =" ++ show (p1, pe1, showAst anchor', astId a')
+
+ case anchor' of
+ Anchor _ (MovedAnchor _ _) -> return ()
+ Anchor rss UnchangedAnchor -> do
+ setAcceptSpan False
+ setPriorEndD (snd $ rs2range rss)
+
+ -- Outside the anchor, mark any trailing
+ postCs <- cua canUpdateAnchor takeAppliedCommentsPop
+ when (flush == NoFlushComments) $ do
+ when ((getFollowingComments cs) /= []) $ do
+
+ -- debugM $ "enterAnn:in:(anchor') =" ++ show (eloc2str anchor')
+ debugM $ "starting trailing comments:" ++ showAst (getFollowingComments cs)
+ mapM_ printOneComment (concatMap tokComment $ getFollowingComments cs)
+ debugM $ "ending trailing comments"
+ trailing' <- markTrailing trailing_anns
+
+ -- Update original anchor, comments based on the printing process
+ let newAchor = anchor' { anchor_op = MovedAnchor edp [] }
let r = case canUpdateAnchor of
- CanUpdateAnchor -> setAnnotationAnchor a' newAchor (mkEpaComments (priorCs++ postCs) [])
- CanUpdateAnchorOnly -> setAnnotationAnchor a' newAchor emptyComments
+ CanUpdateAnchor -> setAnnotationAnchor a' newAchor trailing' (mkEpaComments (priorCs ++ postCs) [])
+ CanUpdateAnchorOnly -> setAnnotationAnchor a' newAchor [] emptyComments
NoCanUpdateAnchor -> a'
- -- debugM $ "calling setAnnotationAnchor:(curAnchor, newAchor,priorCs,postCs)=" ++ showAst (show (rs2range curAnchor), newAchor, priorCs, postCs)
- -- debugM $ "calling setAnnotationAnchor:(newAchor,postCs)=" ++ showAst (newAchor, postCs)
- debugM $ "enterAnn:done:(p,a) =" ++ show (p0, astId a')
return r
-- ---------------------------------------------------------------------
@@ -424,11 +600,13 @@ addComments csNew = do
-- | Just before we print out the EOF comments, flush the remaining
-- ones in the state.
flushComments :: (Monad m, Monoid w) => [LEpaComment] -> EP w m ()
-flushComments trailing = do
- addCommentsA trailing
+flushComments trailing_anns = do
+ addCommentsA trailing_anns
cs <- getUnallocatedComments
debugM $ "flushing comments starting"
+ -- AZ:TODO: is the sort still needed?
mapM_ printOneComment (sortComments cs)
+ putUnallocatedComments []
debugM $ "flushing comments done"
-- ---------------------------------------------------------------------
@@ -470,7 +648,7 @@ withPpr a = do
-- 'ppr'.
class (Typeable a) => ExactPrint a where
getAnnotationEntry :: a -> Entry
- setAnnotationAnchor :: a -> Anchor -> EpAnnComments -> a
+ setAnnotationAnchor :: a -> Anchor -> [TrailingAnn] -> EpAnnComments -> a
exact :: (Monad m, Monoid w) => a -> EP w m a
-- ---------------------------------------------------------------------
@@ -493,7 +671,7 @@ printStringAtRsC :: (Monad m, Monoid w)
=> CaptureComments -> RealSrcSpan -> String -> EP w m EpaLocation
printStringAtRsC capture pa str = do
debugM $ "printStringAtRsC: pa=" ++ showAst pa
- printComments pa
+ printCommentsBefore pa
pe <- getPriorEndD
debugM $ "printStringAtRsC:pe=" ++ show pe
let p = ss2delta pe pa
@@ -548,7 +726,7 @@ printStringAtAAC :: (Monad m, Monoid w)
=> CaptureComments -> EpaLocation -> String -> EP w m EpaLocation
printStringAtAAC capture (EpaSpan r _) s = printStringAtRsC capture r s
printStringAtAAC capture (EpaDelta d cs) s = do
- mapM_ printOneComment $ concatMap tokComment cs
+ mapM_ printOneComment $ concatMap tokComment cs
pe1 <- getPriorEndD
p1 <- getPosP
printStringAtLsDelta d s
@@ -815,9 +993,9 @@ lal_rest :: Lens AnnList [AddEpAnn]
lal_rest k parent = fmap (\new -> parent { al_rest = new })
(k (al_rest parent))
-lal_trailing :: Lens AnnList [TrailingAnn]
-lal_trailing k parent = fmap (\new -> parent { al_trailing = new })
- (k (al_trailing parent))
+-- lal_trailing :: Lens AnnList [TrailingAnn]
+-- lal_trailing k parent = fmap (\new -> parent { al_trailing = new })
+-- (k (al_trailing parent))
-- -------------------------------------
@@ -1107,12 +1285,6 @@ markLensKwM (EpAnn anc a cs) l kw = do
-- ---------------------------------------------------------------------
-markALocatedA :: (Monad m, Monoid w) => EpAnn AnnListItem -> EP w m (EpAnn AnnListItem)
-markALocatedA EpAnnNotUsed = return EpAnnNotUsed
-markALocatedA (EpAnn anc a cs) = do
- t <- markTrailing (lann_trailing a)
- return (EpAnn anc (a { lann_trailing = t }) cs)
-
markEpAnnL :: (Monad m, Monoid w)
=> EpAnn ann -> Lens ann [AddEpAnn] -> AnnKeywordId -> EP w m (EpAnn ann)
markEpAnnL EpAnnNotUsed _ _ = return EpAnnNotUsed
@@ -1183,6 +1355,8 @@ markKwT :: (Monad m, Monoid w) => TrailingAnn -> EP w m TrailingAnn
markKwT (AddSemiAnn ss) = AddSemiAnn <$> markKwA AnnSemi ss
markKwT (AddCommaAnn ss) = AddCommaAnn <$> markKwA AnnComma ss
markKwT (AddVbarAnn ss) = AddVbarAnn <$> markKwA AnnVbar ss
+markKwT (AddDarrowAnn ss) = AddDarrowAnn <$> markKwA AnnDarrow ss
+markKwT (AddDarrowUAnn ss) = AddDarrowUAnn <$> markKwA AnnDarrowU ss
-- ---------------------------------------------------------------------
@@ -1200,23 +1374,28 @@ markAnnListA :: (Monad m, Monoid w)
markAnnListA EpAnnNotUsed action = do
action EpAnnNotUsed
markAnnListA an action = do
- debugM $ "markAnnListA: an=" ++ showAst an
an0 <- markLensMAA an lal_open
an1 <- markEpAnnAllL an0 lal_rest AnnSemi
(an2, r) <- action an1
an3 <- markLensMAA an2 lal_close
- an4 <- markTrailingL an3 lal_trailing
- debugM $ "markAnnListA: an4=" ++ showAst an
- return (an4, r)
+ return (an3, r)
-- ---------------------------------------------------------------------
-printComments :: (Monad m, Monoid w) => RealSrcSpan -> EP w m ()
-printComments ss = do
- cs <- commentAllocation ss
- debugM $ "printComments: (ss): " ++ showPprUnsafe (rs2range ss)
+printCommentsBefore :: (Monad m, Monoid w) => RealSrcSpan -> EP w m ()
+printCommentsBefore ss = do
+ cs <- commentAllocationBefore ss
+ debugM $ "printCommentsBefore: (ss): " ++ showPprUnsafe (rs2range ss)
+ -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentAnchor cs)
+ mapM_ printOneComment cs
+
+printCommentsIn :: (Monad m, Monoid w) => RealSrcSpan -> EP w m ()
+printCommentsIn ss = do
+ cs <- commentAllocationIn ss
+ debugM $ "printCommentsIn: (ss): " ++ showPprUnsafe (rs2range ss)
-- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentAnchor cs)
mapM_ printOneComment cs
+ debugM $ "printCommentsIn:done"
-- ---------------------------------------------------------------------
@@ -1224,74 +1403,90 @@ printOneComment :: (Monad m, Monoid w) => Comment -> EP w m ()
printOneComment c@(Comment _str loc _r _mo) = do
debugM $ "printOneComment:c=" ++ showGhc c
dp <-case anchor_op loc of
- MovedAnchor dp -> return dp
+ MovedAnchor dp _ -> return dp
_ -> do
pe <- getPriorEndD
- let dp = ss2delta pe (anchor loc)
- debugM $ "printOneComment:(dp,pe,anchor loc)=" ++ showGhc (dp,pe,ss2pos $ anchor loc)
+ debugM $ "printOneComment:pe=" ++ showGhc pe
+ -- let dp = ss2delta pe (anchor loc)
+ let dp = case loc of
+ Anchor r UnchangedAnchor -> ss2delta pe r
+ Anchor _ (MovedAnchor dp1 _) -> dp1
+ debugM $ "printOneComment:(dp,pe,loc)=" ++ showGhc (dp,pe,loc)
adjustDeltaForOffsetM dp
mep <- getExtraDP
dp' <- case mep of
- Just (Anchor _ (MovedAnchor edp)) -> do
+ Just (Anchor _ (MovedAnchor edp _)) -> do
debugM $ "printOneComment:edp=" ++ show edp
- ddd <- fmap unTweakDelta $ adjustDeltaForOffsetM edp
- debugM $ "printOneComment:ddd=" ++ show ddd
- fmap unTweakDelta $ adjustDeltaForOffsetM edp
+ adjustDeltaForOffsetM edp
_ -> return dp
-- Start of debug printing
- -- LayoutStartCol dOff <- getLayoutOffsetD
- -- debugM $ "printOneComment:(dp,dp',dOff)=" ++ showGhc (dp,dp',dOff)
+ LayoutStartCol dOff <- getLayoutOffsetD
+ debugM $ "printOneComment:(dp,dp',dOff,loc)=" ++ showGhc (dp,dp',dOff,loc)
-- End of debug printing
- -- setPriorEndD (ss2posEnd (anchor loc))
updateAndApplyComment c dp'
- printQueuedComment (anchor loc) c dp'
-
--- | For comment-related deltas starting on a new line we have an
--- off-by-one problem. Adjust
-unTweakDelta :: DeltaPos -> DeltaPos
-unTweakDelta (SameLine d) = SameLine d
-unTweakDelta (DifferentLine l d) = DifferentLine l (d+1)
-
+ printQueuedComment c dp'
updateAndApplyComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m ()
updateAndApplyComment (Comment str anc pp mo) dp = do
- -- debugM $ "updateAndApplyComment: (dp,anc',co)=" ++ showAst (dp,anc',co)
applyComment (Comment str anc' pp mo)
where
anc' = anc { anchor_op = op}
(r,c) = ss2posEnd pp
- la = anchor anc
- dp'' = if r == 0
- then (ss2delta (r,c+0) la)
- else (ss2delta (r,c) la)
- dp' = if pp == anchor anc
- then dp
- else dp''
+ dp'' = case anc of
+ Anchor _ (MovedAnchor dp1 _) -> dp1
+ Anchor la _ ->
+ if r == 0
+ then (ss2delta (r,c+0) la)
+ else (ss2delta (r,c) la)
+ dp' = case anc of
+ Anchor r1 UnchangedAnchor ->
+ if pp == r1
+ then dp
+ else dp''
+ _ -> dp''
op' = case dp' of
SameLine n -> if n >= 0
- then MovedAnchor dp'
- else MovedAnchor dp
- _ -> MovedAnchor dp'
- op = if str == "" && op' == MovedAnchor (SameLine 0) -- EOF comment
- then MovedAnchor dp
- -- else op'
- else MovedAnchor dp
+ then MovedAnchor dp' []
+ else MovedAnchor dp []
+ _ -> MovedAnchor dp' []
+ op = if str == "" && op' == MovedAnchor (SameLine 0) [] -- EOF comment
+ then MovedAnchor dp []
+ else MovedAnchor dp []
-- ---------------------------------------------------------------------
-commentAllocation :: (Monad m, Monoid w) => RealSrcSpan -> EP w m [Comment]
-commentAllocation ss = do
+commentAllocationBefore :: (Monad m, Monoid w) => RealSrcSpan -> EP w m [Comment]
+commentAllocationBefore ss = do
cs <- getUnallocatedComments
-- Note: The CPP comment injection may change the file name in the
-- RealSrcSpan, which affects comparison, as the Ord instance for
-- RealSrcSpan compares the file first. So we sort via ss2pos
-- TODO: this is inefficient, use Pos all the way through
- let (earlier,later) = partition (\(Comment _str loc _r _mo) -> (ss2pos $ anchor loc) <= (ss2pos ss)) cs
+ let (earlier,later) = partition (\(Comment _str loc _r _mo) ->
+ case loc of
+ Anchor r UnchangedAnchor -> (ss2pos r) <= (ss2pos ss)
+ _ -> True -- Choose one
+ ) cs
putUnallocatedComments later
-- debugM $ "commentAllocation:(ss,earlier,later)" ++ show (rs2range ss,earlier,later)
return earlier
+commentAllocationIn :: (Monad m, Monoid w) => RealSrcSpan -> EP w m [Comment]
+commentAllocationIn ss = do
+ cs <- getUnallocatedComments
+ -- Note: The CPP comment injection may change the file name in the
+ -- RealSrcSpan, which affects comparison, as the Ord instance for
+ -- RealSrcSpan compares the file first. So we sort via ss2pos
+ -- TODO: this is inefficient, use Pos all the way through
+ let (earlier,later) = partition (\(Comment _str loc _r _mo) ->
+ case loc of
+ Anchor r UnchangedAnchor -> (ss2posEnd r) <= (ss2posEnd ss)
+ _ -> True -- Choose one
+ ) cs
+ putUnallocatedComments later
+ -- debugM $ "commentAllocation:(ss,earlier,later)" ++ show (rs2range ss,earlier,later)
+ return earlier
-- ---------------------------------------------------------------------
markAnnotatedWithLayout :: (Monad m, Monoid w) => ExactPrint ast => ast -> EP w m ast
@@ -1313,37 +1508,36 @@ markTopLevelList ls = mapM (\a -> setLayoutTopLevelP $ markAnnotated a) ls
instance (ExactPrint a) => ExactPrint (Located a) where
getAnnotationEntry (L l _) = case l of
UnhelpfulSpan _ -> NoEntryVal
- _ -> Entry (hackSrcSpanToAnchor l) emptyComments NoFlushComments CanUpdateAnchorOnly
+ _ -> Entry (hackSrcSpanToAnchor l) [] emptyComments NoFlushComments CanUpdateAnchorOnly
- setAnnotationAnchor (L _ a) anc _cs = (L (hackAnchorToSrcSpan anc) a)
- `debug` ("setAnnotationAnchor(Located):" ++ showAst anc)
+ setAnnotationAnchor (L l a) _anc _ts _cs = L l a
exact (L l a) = L l <$> markAnnotated a
instance (ExactPrint a) => ExactPrint (LocatedA a) where
getAnnotationEntry = entryFromLocatedA
- setAnnotationAnchor la anc cs = setAnchorAn la anc cs
+ setAnnotationAnchor la anc ts cs = setAnchorAn la anc ts cs
exact (L la a) = do
debugM $ "LocatedA a:la loc=" ++ show (ss2range $ locA la)
a' <- markAnnotated a
- ann' <- markALocatedA (ann la)
+ let ann' = ann la
return (L (la { ann = ann'}) a')
instance (ExactPrint a) => ExactPrint (LocatedAn NoEpAnns a) where
getAnnotationEntry = entryFromLocatedA
- setAnnotationAnchor la anc cs = setAnchorAn la anc cs
+ setAnnotationAnchor la anc ts cs = setAnchorAn la anc ts cs
exact (L la a) = do
a' <- markAnnotated a
return (L la a')
instance (ExactPrint a) => ExactPrint [a] where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor ls _ _ = ls
+ setAnnotationAnchor ls _ _ _ = ls
exact ls = mapM markAnnotated ls
instance (ExactPrint a) => ExactPrint (Maybe a) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor ma _ _ = ma
+ setAnnotationAnchor ma _ _ _ = ma
exact ma = mapM markAnnotated ma
-- ---------------------------------------------------------------------
@@ -1352,7 +1546,7 @@ instance (ExactPrint a) => ExactPrint (Maybe a) where
instance ExactPrint (HsModule GhcPs) where
getAnnotationEntry hsmod = fromAnn' (hsmodAnn $ hsmodExt hsmod)
-- A bit pointless actually changing anything here
- setAnnotationAnchor hsmod anc cs = setAnchorHsModule hsmod anc cs
+ setAnnotationAnchor hsmod anc _ts cs = setAnchorHsModule hsmod anc cs
`debug` ("setAnnotationAnchor hsmod called" ++ showAst (anc,cs))
exact hsmod@(HsModule {hsmodExt = XModulePs { hsmodAnn = EpAnnNotUsed }}) = withPpr hsmod >> return hsmod
@@ -1383,6 +1577,14 @@ instance ExactPrint (HsModule GhcPs) where
am_decls' <- markTrailing (am_decls $ anns an0)
imports' <- markTopLevelList imports
+
+ case lo of
+ ExplicitBraces _ _ -> return ()
+ _ -> do
+ -- Get rid of the balance of the preceding comments before starting on the decls
+ flushComments []
+ putUnallocatedComments []
+
decls' <- markTopLevelList (filter removeDocDecl decls)
lo1 <- case lo0 of
@@ -1412,7 +1614,7 @@ removeDocDecl _ = True
instance ExactPrint ModuleName where
getAnnotationEntry _ = NoEntryVal
- setAnnotationAnchor n _anc cs = n
+ setAnnotationAnchor n _anc _ cs = n
`debug` ("ModuleName.setAnnotationAnchor:cs=" ++ showAst cs)
exact n = do
debugM $ "ModuleName: " ++ showPprUnsafe n
@@ -1443,7 +1645,7 @@ instance ExactPrint (LocatedP (WarningTxt GhcPs)) where
instance ExactPrint InWarningCategory where
getAnnotationEntry _ = NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (InWarningCategory tkIn source (L l wc)) = do
tkIn' <- markLToken tkIn
@@ -1452,7 +1654,7 @@ instance ExactPrint InWarningCategory where
instance ExactPrint (SourceText, WarningCategory) where
getAnnotationEntry _ = NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (st, WarningCategory wc) = do
case st of
@@ -1464,8 +1666,8 @@ instance ExactPrint (SourceText, WarningCategory) where
instance ExactPrint (ImportDecl GhcPs) where
getAnnotationEntry idecl = fromAnn (ideclAnn $ ideclExt idecl)
- setAnnotationAnchor idecl anc cs = idecl { ideclExt
- = (ideclExt idecl) { ideclAnn = setAnchorEpa (ideclAnn $ ideclExt idecl) anc cs} }
+ setAnnotationAnchor idecl anc ts cs = idecl { ideclExt
+ = (ideclExt idecl) { ideclAnn = setAnchorEpa (ideclAnn $ ideclExt idecl) anc ts cs} }
exact x@(ImportDecl{ ideclExt = XImportDeclPass{ ideclAnn = EpAnnNotUsed } }) = withPpr x
exact (ImportDecl (XImportDeclPass ann msrc impl)
@@ -1538,7 +1740,7 @@ instance ExactPrint (ImportDecl GhcPs) where
instance ExactPrint HsDocString where
getAnnotationEntry _ = NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (MultiLineDocString decorator (x :| xs)) = do
printStringAdvance ("-- " ++ printDecorator decorator)
@@ -1555,7 +1757,7 @@ instance ExactPrint HsDocString where
instance ExactPrint HsDocStringChunk where
getAnnotationEntry _ = NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact chunk = do
printStringAdvance ("--" ++ unpackHDSC chunk)
return chunk
@@ -1563,7 +1765,7 @@ instance ExactPrint HsDocStringChunk where
instance ExactPrint a => ExactPrint (WithHsDocIdentifiers a GhcPs) where
getAnnotationEntry _ = NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (WithHsDocIdentifiers ds ids) = do
ds' <- exact ds
return (WithHsDocIdentifiers ds' ids)
@@ -1588,7 +1790,7 @@ instance ExactPrint (HsDecl GhcPs) where
-- We do not recurse, the generic traversal using this feature
-- should do that for us.
- setAnnotationAnchor d _ _ = d
+ setAnnotationAnchor d _ _ _ = d
exact (TyClD x d) = TyClD x <$> markAnnotated d
exact (InstD x d) = InstD x <$> markAnnotated d
@@ -1612,7 +1814,7 @@ instance ExactPrint (InstDecl GhcPs) where
getAnnotationEntry (DataFamInstD _ _) = NoEntryVal
getAnnotationEntry (TyFamInstD _ _) = NoEntryVal
- setAnnotationAnchor d _ _ = d
+ setAnnotationAnchor d _ _ _ = d
exact (ClsInstD a cid) = do
@@ -1637,8 +1839,8 @@ data DataFamInstDeclWithContext
instance ExactPrint DataFamInstDeclWithContext where
getAnnotationEntry (DataFamInstDeclWithContext _ _ (DataFamInstDecl (FamEqn { feqn_ext = an})))
= fromAnn an
- setAnnotationAnchor (DataFamInstDeclWithContext a c (DataFamInstDecl fe)) anc cs
- = (DataFamInstDeclWithContext a c (DataFamInstDecl (fe { feqn_ext = (setAnchorEpa (feqn_ext fe) anc cs)})))
+ setAnnotationAnchor (DataFamInstDeclWithContext a c (DataFamInstDecl fe)) anc ts cs
+ = (DataFamInstDeclWithContext a c (DataFamInstDecl (fe { feqn_ext = (setAnchorEpa (feqn_ext fe) anc ts cs)})))
exact (DataFamInstDeclWithContext an c d) = do
debugM $ "starting DataFamInstDeclWithContext:an=" ++ showAst an
(an', d') <- exactDataFamInstDecl an c d
@@ -1697,8 +1899,8 @@ rendering the DataDefn are contained in the FamEqn, and are called
instance ExactPrint (DerivDecl GhcPs) where
getAnnotationEntry (DerivDecl {deriv_ext = (_, an)} ) = fromAnn an
- setAnnotationAnchor (dd@DerivDecl {deriv_ext = (w, an)}) anc cs
- = dd { deriv_ext = (w, setAnchorEpa an anc cs) }
+ setAnnotationAnchor (dd@DerivDecl {deriv_ext = (w, an)}) anc ts cs
+ = dd { deriv_ext = (w, setAnchorEpa an anc ts cs) }
exact (DerivDecl (mw, an) typ ms mov) = do
an0 <- markEpAnnL an lidl AnnDeriving
ms' <- mapM markAnnotated ms
@@ -1714,8 +1916,8 @@ instance ExactPrint (ForeignDecl GhcPs) where
getAnnotationEntry (ForeignImport an _ _ _) = fromAnn an
getAnnotationEntry (ForeignExport an _ _ _) = fromAnn an
- setAnnotationAnchor (ForeignImport an a b c) anc cs = ForeignImport (setAnchorEpa an anc cs) a b c
- setAnnotationAnchor (ForeignExport an a b c) anc cs = ForeignExport (setAnchorEpa an anc cs) a b c
+ setAnnotationAnchor (ForeignImport an a b c) anc ts cs = ForeignImport (setAnchorEpa an anc ts cs) a b c
+ setAnnotationAnchor (ForeignExport an a b c) anc ts cs = ForeignExport (setAnchorEpa an anc ts cs) a b c
exact (ForeignImport an n ty fimport) = do
an0 <- markEpAnnL an lidl AnnForeign
@@ -1741,7 +1943,7 @@ instance ExactPrint (ForeignDecl GhcPs) where
instance ExactPrint (ForeignImport GhcPs) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (CImport (L ls src) cconv safety@(L ll _) mh imp) = do
cconv' <- markAnnotated cconv
unless (ll == noSrcSpan) $ markAnnotated safety >> return ()
@@ -1752,7 +1954,7 @@ instance ExactPrint (ForeignImport GhcPs) where
instance ExactPrint (ForeignExport GhcPs) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (CExport (L ls src) spec) = do
debugM $ "CExport starting"
spec' <- markAnnotated spec
@@ -1763,7 +1965,7 @@ instance ExactPrint (ForeignExport GhcPs) where
instance ExactPrint CExportSpec where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (CExportStatic st lbl cconv) = do
debugM $ "CExportStatic starting"
cconv' <- markAnnotated cconv
@@ -1773,21 +1975,21 @@ instance ExactPrint CExportSpec where
instance ExactPrint Safety where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact = withPpr
-- ---------------------------------------------------------------------
instance ExactPrint CCallConv where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact = withPpr
-- ---------------------------------------------------------------------
instance ExactPrint (WarnDecls GhcPs) where
getAnnotationEntry (Warnings (an,_) _) = fromAnn an
- setAnnotationAnchor (Warnings (an,a) b) anc cs = Warnings ((setAnchorEpa an anc cs),a) b
+ setAnnotationAnchor (Warnings (an,a) b) anc ts cs = Warnings ((setAnchorEpa an anc ts cs),a) b
exact (Warnings (an,src) warns) = do
an0 <- markAnnOpen an src "{-# WARNING" -- Note: might be {-# DEPRECATED
@@ -1799,7 +2001,7 @@ instance ExactPrint (WarnDecls GhcPs) where
instance ExactPrint (WarnDecl GhcPs) where
getAnnotationEntry (Warning an _ _) = fromAnn an
- setAnnotationAnchor (Warning an a b) anc cs = Warning (setAnchorEpa an anc cs) a b
+ setAnnotationAnchor (Warning an a b) anc ts cs = Warning (setAnchorEpa an anc ts cs) a b
exact (Warning an lns (WarningTxt mb_cat src ls )) = do
mb_cat' <- markAnnotated mb_cat
@@ -1820,7 +2022,7 @@ instance ExactPrint (WarnDecl GhcPs) where
instance ExactPrint StringLiteral where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact l@(StringLiteral src fs mcomma) = do
printSourceText src (show (unpackFS fs))
@@ -1831,7 +2033,7 @@ instance ExactPrint StringLiteral where
instance ExactPrint FastString where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
-- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies.
-- exact fs = printStringAdvance (show (unpackFS fs))
@@ -1841,7 +2043,7 @@ instance ExactPrint FastString where
instance ExactPrint (RuleDecls GhcPs) where
getAnnotationEntry (HsRules (an,_) _) = fromAnn an
- setAnnotationAnchor (HsRules (an,a) b) anc cs = HsRules ((setAnchorEpa an anc cs),a) b
+ setAnnotationAnchor (HsRules (an,a) b) anc ts cs = HsRules ((setAnchorEpa an anc ts cs),a) b
exact (HsRules (an, src) rules) = do
an0 <-
case src of
@@ -1855,8 +2057,8 @@ instance ExactPrint (RuleDecls GhcPs) where
instance ExactPrint (RuleDecl GhcPs) where
getAnnotationEntry (HsRule {rd_ext = (an,_)}) = fromAnn an
- setAnnotationAnchor r@(HsRule {rd_ext = (an,a)}) anc cs
- = r { rd_ext = (setAnchorEpa an anc cs, a)}
+ setAnnotationAnchor r@(HsRule {rd_ext = (an,a)}) anc ts cs
+ = r { rd_ext = (setAnchorEpa an anc ts cs, a)}
exact (HsRule (an,nsrc) (L ln n) act mtybndrs termbndrs lhs rhs) = do
debugM "HsRule entered"
(L ln' _) <- markAnnotated (L ln (nsrc, n))
@@ -1907,7 +2109,7 @@ markActivation an l act = do
instance ExactPrint (SpliceDecl GhcPs) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (SpliceDecl x splice flag) = do
splice' <- markAnnotated splice
@@ -1917,7 +2119,7 @@ instance ExactPrint (SpliceDecl GhcPs) where
instance ExactPrint (DocDecl GhcPs) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
-- We print these as plain comments instead, do a NOP here.
exact v = return v
@@ -1926,7 +2128,7 @@ instance ExactPrint (DocDecl GhcPs) where
instance ExactPrint (RoleAnnotDecl GhcPs) where
getAnnotationEntry (RoleAnnotDecl an _ _) = fromAnn an
- setAnnotationAnchor (RoleAnnotDecl an a b) anc cs = RoleAnnotDecl (setAnchorEpa an anc cs) a b
+ setAnnotationAnchor (RoleAnnotDecl an a b) anc ts cs = RoleAnnotDecl (setAnchorEpa an anc ts cs) a b
exact (RoleAnnotDecl an ltycon roles) = do
an0 <- markEpAnnL an lidl AnnType
an1 <- markEpAnnL an0 lidl AnnRole
@@ -1944,14 +2146,14 @@ instance ExactPrint (RoleAnnotDecl GhcPs) where
instance ExactPrint Role where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact = withPpr
-- ---------------------------------------------------------------------
instance ExactPrint (RuleBndr GhcPs) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (RuleBndr x ln) = do
ln' <- markAnnotated ln
@@ -1968,7 +2170,7 @@ instance ExactPrint (RuleBndr GhcPs) where
instance (ExactPrint body) => ExactPrint (FamEqn GhcPs body) where
getAnnotationEntry (FamEqn { feqn_ext = an}) = fromAnn an
- setAnnotationAnchor fe anc cs = fe {feqn_ext = setAnchorEpa (feqn_ext fe) anc cs}
+ setAnnotationAnchor fe anc ts cs = fe {feqn_ext = setAnchorEpa (feqn_ext fe) anc ts cs}
exact (FamEqn { feqn_ext = an
, feqn_tycon = tycon
, feqn_bndrs = bndrs
@@ -2037,7 +2239,7 @@ exactHsFamInstLHS an thing bndrs typats fixity mb_ctxt = do
instance (ExactPrint tm, ExactPrint ty, Outputable tm, Outputable ty)
=> ExactPrint (HsArg GhcPs tm ty) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact a@(HsValArg tm) = markAnnotated tm >> return a
exact a@(HsTypeArg at ty) = markToken at >> markAnnotated ty >> return a
@@ -2047,8 +2249,8 @@ instance (ExactPrint tm, ExactPrint ty, Outputable tm, Outputable ty)
instance ExactPrint (ClsInstDecl GhcPs) where
getAnnotationEntry (ClsInstDecl { cid_ext = (_, an, _) }) = fromAnn an
- setAnnotationAnchor (cid@ClsInstDecl { cid_ext = (mbWarn, an, sortKey) }) anc cs
- = cid { cid_ext = (mbWarn, setAnchorEpa an anc cs, sortKey) }
+ setAnnotationAnchor (cid@ClsInstDecl { cid_ext = (mbWarn, an, sortKey) }) anc ts cs
+ = cid { cid_ext = (mbWarn, setAnchorEpa an anc ts cs, sortKey) }
exact (ClsInstDecl { cid_ext = (mbWarn, an, sortKey)
, cid_poly_ty = inst_ty, cid_binds = binds
@@ -2090,7 +2292,7 @@ instance ExactPrint (ClsInstDecl GhcPs) where
instance ExactPrint (TyFamInstDecl GhcPs) where
getAnnotationEntry (TyFamInstDecl an _) = fromAnn an
- setAnnotationAnchor (TyFamInstDecl an a) anc cs = TyFamInstDecl (setAnchorEpa an anc cs) a
+ setAnnotationAnchor (TyFamInstDecl an a) anc ts cs = TyFamInstDecl (setAnchorEpa an anc ts cs) a
exact d@(TyFamInstDecl { tfid_xtn = an, tfid_eqn = eqn }) = do
an0 <- markEpAnnL an lidl AnnType
@@ -2143,8 +2345,8 @@ instance ExactPrint (HsBind GhcPs) where
getAnnotationEntry VarBind{} = NoEntryVal
getAnnotationEntry PatSynBind{} = NoEntryVal
- setAnnotationAnchor pb@PatBind{} anc cs = pb { pat_ext = setAnchorEpa (pat_ext pb) anc cs}
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor pb@PatBind{} anc ts cs = pb { pat_ext = setAnchorEpa (pat_ext pb) anc ts cs}
+ setAnnotationAnchor a _ _ _ = a
exact (FunBind x fid matches) = do
matches' <- markAnnotated matches
@@ -2170,7 +2372,7 @@ instance ExactPrint (HsBind GhcPs) where
instance ExactPrint (PatSynBind GhcPs GhcPs) where
getAnnotationEntry (PSB { psb_ext = an}) = fromAnn an
- setAnnotationAnchor p anc cs = p { psb_ext = setAnchorEpa (psb_ext p) anc cs}
+ setAnnotationAnchor p anc ts cs = p { psb_ext = setAnchorEpa (psb_ext p) anc ts cs}
exact (PSB{ psb_ext = an
, psb_id = psyn, psb_args = details
@@ -2223,7 +2425,7 @@ instance ExactPrint (PatSynBind GhcPs GhcPs) where
instance ExactPrint (RecordPatSynField GhcPs) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact r@(RecordPatSynField { recordPatSynField = v }) = markAnnotated v
>> return r
@@ -2231,7 +2433,7 @@ instance ExactPrint (RecordPatSynField GhcPs) where
instance ExactPrint (Match GhcPs (LocatedA (HsCmd GhcPs))) where
getAnnotationEntry (Match ann _ _ _) = fromAnn ann
- setAnnotationAnchor (Match an a b c) anc cs = Match (setAnchorEpa an anc cs) a b c
+ setAnnotationAnchor (Match an a b c) anc ts cs = Match (setAnchorEpa an anc ts cs) a b c
exact (Match an mctxt pats grhss) =
exactMatch (Match an mctxt pats grhss)
@@ -2240,14 +2442,15 @@ instance ExactPrint (Match GhcPs (LocatedA (HsCmd GhcPs))) where
instance ExactPrint (Match GhcPs (LocatedA (HsExpr GhcPs))) where
getAnnotationEntry (Match ann _ _ _) = fromAnn ann
- setAnnotationAnchor (Match an a b c) anc cs = Match (setAnchorEpa an anc cs) a b c
+ setAnnotationAnchor (Match an a b c) anc ts cs = Match (setAnchorEpa an anc ts cs) a b c
exact (Match an mctxt pats grhss) =
exactMatch (Match an mctxt pats grhss)
-- ---------------------------------------------------------------------
-exactMatch :: (Monad m, Monoid w) => (ExactPrint (GRHSs GhcPs body)) => (Match GhcPs body) -> EP w m (Match GhcPs body)
+exactMatch :: (Monad m, Monoid w, ExactPrint (GRHSs GhcPs body))
+ => (Match GhcPs body) -> EP w m (Match GhcPs body)
exactMatch (Match an mctxt pats grhss) = do
debugM $ "exact Match entered"
@@ -2308,7 +2511,7 @@ exactMatch (Match an mctxt pats grhss) = do
instance ExactPrint (GRHSs GhcPs (LocatedA (HsExpr GhcPs))) where
getAnnotationEntry (GRHSs _ _ _) = NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (GRHSs cs grhss binds) = do
addCommentsA $ priorComments cs
@@ -2321,7 +2524,7 @@ instance ExactPrint (GRHSs GhcPs (LocatedA (HsExpr GhcPs))) where
instance ExactPrint (GRHSs GhcPs (LocatedA (HsCmd GhcPs))) where
getAnnotationEntry (GRHSs _ _ _) = NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (GRHSs cs grhss binds) = do
addCommentsA $ priorComments cs
@@ -2338,8 +2541,8 @@ instance ExactPrint (HsLocalBinds GhcPs) where
getAnnotationEntry (HsIPBinds{}) = NoEntryVal
getAnnotationEntry (EmptyLocalBinds{}) = NoEntryVal
- setAnnotationAnchor (HsValBinds an a) anc cs = HsValBinds (setAnchorEpaL an anc cs) a
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor (HsValBinds an a) anc ts cs = HsValBinds (setAnchorEpaL an anc ts cs) a
+ setAnnotationAnchor a _ _ _ = a
exact (HsValBinds an valbinds) = do
debugM $ "exact HsValBinds: an=" ++ showAst an
@@ -2371,7 +2574,7 @@ instance ExactPrint (HsLocalBinds GhcPs) where
-- ---------------------------------------------------------------------
instance ExactPrint (HsValBindsLR GhcPs GhcPs) where
getAnnotationEntry _ = NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (ValBinds sortKey binds sigs) = do
decls <- setLayoutBoth $ mapM markAnnotated $ hsDeclsValBinds (ValBinds sortKey binds sigs)
@@ -2388,7 +2591,7 @@ undynamic ds = mapMaybe fromDynamic ds
instance ExactPrint (HsIPBinds GhcPs) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact b@(IPBinds _ binds) = setLayoutBoth $ markAnnotated binds >> return b
@@ -2396,7 +2599,7 @@ instance ExactPrint (HsIPBinds GhcPs) where
instance ExactPrint (IPBind GhcPs) where
getAnnotationEntry (IPBind an _ _) = fromAnn an
- setAnnotationAnchor (IPBind an a b) anc cs = IPBind (setAnchorEpa an anc cs) a b
+ setAnnotationAnchor (IPBind an a b) anc ts cs = IPBind (setAnchorEpa an anc ts cs) a b
exact (IPBind an lr rhs) = do
lr' <- markAnnotated lr
@@ -2409,7 +2612,7 @@ instance ExactPrint (IPBind GhcPs) where
instance ExactPrint HsIPName where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact i@(HsIPName fs) = printStringAdvance ("?" ++ (unpackFS fs)) >> return i
@@ -2457,16 +2660,16 @@ instance ExactPrint (Sig GhcPs) where
getAnnotationEntry (SCCFunSig (a, _) _ _) = fromAnn a
getAnnotationEntry (CompleteMatchSig (a, _) _ _) = fromAnn a
- setAnnotationAnchor (TypeSig a x y) anc cs = (TypeSig (setAnchorEpa a anc cs) x y)
- setAnnotationAnchor (PatSynSig a x y) anc cs = (PatSynSig (setAnchorEpa a anc cs) x y)
- setAnnotationAnchor (ClassOpSig a x y z) anc cs = (ClassOpSig (setAnchorEpa a anc cs) x y z)
- setAnnotationAnchor (FixSig a x) anc cs = (FixSig (setAnchorEpa a anc cs) x)
- setAnnotationAnchor (InlineSig a x y) anc cs = (InlineSig (setAnchorEpa a anc cs) x y)
- setAnnotationAnchor (SpecSig a x y z) anc cs = (SpecSig (setAnchorEpa a anc cs) x y z)
- setAnnotationAnchor (SpecInstSig (a,x) y) anc cs = (SpecInstSig ((setAnchorEpa a anc cs),x) y)
- setAnnotationAnchor (MinimalSig (a,x) y) anc cs = (MinimalSig ((setAnchorEpa a anc cs),x) y)
- setAnnotationAnchor (SCCFunSig (a,x) y z) anc cs = (SCCFunSig ((setAnchorEpa a anc cs),x) y z)
- setAnnotationAnchor (CompleteMatchSig (a,x) y z) anc cs = (CompleteMatchSig ((setAnchorEpa a anc cs),x) y z)
+ setAnnotationAnchor (TypeSig a x y) anc ts cs = (TypeSig (setAnchorEpa a anc ts cs) x y)
+ setAnnotationAnchor (PatSynSig a x y) anc ts cs = (PatSynSig (setAnchorEpa a anc ts cs) x y)
+ setAnnotationAnchor (ClassOpSig a x y z) anc ts cs = (ClassOpSig (setAnchorEpa a anc ts cs) x y z)
+ setAnnotationAnchor (FixSig a x) anc ts cs = (FixSig (setAnchorEpa a anc ts cs) x)
+ setAnnotationAnchor (InlineSig a x y) anc ts cs = (InlineSig (setAnchorEpa a anc ts cs) x y)
+ setAnnotationAnchor (SpecSig a x y z) anc ts cs = (SpecSig (setAnchorEpa a anc ts cs) x y z)
+ setAnnotationAnchor (SpecInstSig (a,x) y) anc ts cs = (SpecInstSig ((setAnchorEpa a anc ts cs),x) y)
+ setAnnotationAnchor (MinimalSig (a,x) y) anc ts cs = (MinimalSig ((setAnchorEpa a anc ts cs),x) y)
+ setAnnotationAnchor (SCCFunSig (a,x) y z) anc ts cs = (SCCFunSig ((setAnchorEpa a anc ts cs),x) y z)
+ setAnnotationAnchor (CompleteMatchSig (a,x) y z) anc ts cs = (CompleteMatchSig ((setAnchorEpa a anc ts cs),x) y z)
exact (TypeSig an vars ty) = do
(an', vars', ty') <- exactVarSig an vars ty
@@ -2565,7 +2768,7 @@ exactVarSig an vars ty = do
instance ExactPrint (StandaloneKindSig GhcPs) where
getAnnotationEntry (StandaloneKindSig an _ _) = fromAnn an
- setAnnotationAnchor (StandaloneKindSig an a b) anc cs = StandaloneKindSig (setAnchorEpa an anc cs) a b
+ setAnnotationAnchor (StandaloneKindSig an a b) anc ts cs = StandaloneKindSig (setAnchorEpa an anc ts cs) a b
exact (StandaloneKindSig an vars sig) = do
an0 <- markEpAnnL an lidl AnnType
@@ -2578,7 +2781,7 @@ instance ExactPrint (StandaloneKindSig GhcPs) where
instance ExactPrint (DefaultDecl GhcPs) where
getAnnotationEntry (DefaultDecl an _) = fromAnn an
- setAnnotationAnchor (DefaultDecl an a) anc cs = DefaultDecl (setAnchorEpa an anc cs) a
+ setAnnotationAnchor (DefaultDecl an a) anc ts cs = DefaultDecl (setAnchorEpa an anc ts cs) a
exact (DefaultDecl an tys) = do
an0 <- markEpAnnL an lidl AnnDefault
@@ -2591,7 +2794,7 @@ instance ExactPrint (DefaultDecl GhcPs) where
instance ExactPrint (AnnDecl GhcPs) where
getAnnotationEntry (HsAnnotation (an, _) _ _) = fromAnn an
- setAnnotationAnchor (HsAnnotation (an,a) b c) anc cs = HsAnnotation ((setAnchorEpa an anc cs),a) b c
+ setAnnotationAnchor (HsAnnotation (an,a) b c) anc ts cs = HsAnnotation ((setAnchorEpa an anc ts cs),a) b c
exact (HsAnnotation (an, src) prov e) = do
an0 <- markAnnOpenP an src "{-# ANN"
@@ -2616,7 +2819,7 @@ instance ExactPrint (AnnDecl GhcPs) where
instance ExactPrint (BF.BooleanFormula (LocatedN RdrName)) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (BF.Var x) = do
x' <- markAnnotated x
@@ -2635,7 +2838,7 @@ instance ExactPrint (BF.BooleanFormula (LocatedN RdrName)) where
instance (ExactPrint body) => ExactPrint (HsWildCardBndrs GhcPs body) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _= a
exact (HsWC x ty) = do
ty' <- markAnnotated ty
return (HsWC x ty')
@@ -2644,7 +2847,7 @@ instance (ExactPrint body) => ExactPrint (HsWildCardBndrs GhcPs body) where
instance ExactPrint (GRHS GhcPs (LocatedA (HsExpr GhcPs))) where
getAnnotationEntry (GRHS an _ _) = fromAnn an
- setAnnotationAnchor (GRHS an a b) anc cs = GRHS (setAnchorEpa an anc cs) a b
+ setAnnotationAnchor (GRHS an a b) anc ts cs = GRHS (setAnchorEpa an anc ts cs) a b
exact (GRHS an guards expr) = do
debugM $ "GRHS comments:" ++ showGhc (comments an)
@@ -2660,7 +2863,7 @@ instance ExactPrint (GRHS GhcPs (LocatedA (HsExpr GhcPs))) where
instance ExactPrint (GRHS GhcPs (LocatedA (HsCmd GhcPs))) where
getAnnotationEntry (GRHS ann _ _) = fromAnn ann
- setAnnotationAnchor (GRHS an a b) anc cs = GRHS (setAnchorEpa an anc cs) a b
+ setAnnotationAnchor (GRHS an a b) anc ts cs = GRHS (setAnchorEpa an anc ts cs) a b
exact (GRHS an guards expr) = do
an0 <- markLensKwM an lga_vbar AnnVbar
@@ -2710,46 +2913,51 @@ instance ExactPrint (HsExpr GhcPs) where
getAnnotationEntry (HsPragE{}) = NoEntryVal
getAnnotationEntry (HsEmbTy{}) = NoEntryVal
- setAnnotationAnchor a@(HsVar{}) _ _s = a
- setAnnotationAnchor (HsUnboundVar an a) anc cs = (HsUnboundVar (setAnchorEpa an anc cs) a)
- setAnnotationAnchor a@(HsRecSel{}) _ _s = a
- setAnnotationAnchor (HsOverLabel an s a) anc cs = (HsOverLabel (setAnchorEpa an anc cs) s a)
- setAnnotationAnchor (HsIPVar an a) anc cs = (HsIPVar (setAnchorEpa an anc cs) a)
- setAnnotationAnchor (HsOverLit an a) anc cs = (HsOverLit (setAnchorEpa an anc cs) a)
- setAnnotationAnchor (HsLit an a) anc cs = (HsLit (setAnchorEpa an anc cs) a)
- setAnnotationAnchor (HsLam an a b) anc cs = (HsLam (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor (HsApp an a b) anc cs = (HsApp (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor a@(HsAppType {}) _ _s = a
- setAnnotationAnchor (OpApp an a b c) anc cs = (OpApp (setAnchorEpa an anc cs) a b c)
- setAnnotationAnchor (NegApp an a b) anc cs = (NegApp (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor (HsPar an a b c) anc cs = (HsPar (setAnchorEpa an anc cs) a b c)
- setAnnotationAnchor (SectionL an a b) anc cs = (SectionL (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor (SectionR an a b) anc cs = (SectionR (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor (ExplicitTuple an a b) anc cs = (ExplicitTuple (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor (ExplicitSum an a b c) anc cs = (ExplicitSum (setAnchorEpa an anc cs) a b c)
- setAnnotationAnchor (HsCase an a b) anc cs = (HsCase (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor (HsIf an a b c) anc cs = (HsIf (setAnchorEpa an anc cs) a b c)
- setAnnotationAnchor (HsMultiIf an a) anc cs = (HsMultiIf (setAnchorEpa an anc cs) a)
- setAnnotationAnchor (HsLet an a b c d) anc cs = (HsLet (setAnchorEpa an anc cs) a b c d)
- setAnnotationAnchor (HsDo an a b) anc cs = (HsDo (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor (ExplicitList an a) anc cs = (ExplicitList (setAnchorEpa an anc cs) a)
- setAnnotationAnchor (RecordCon an a b) anc cs = (RecordCon (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor (RecordUpd an a b) anc cs = (RecordUpd (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor (HsGetField an a b) anc cs = (HsGetField (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor (HsProjection an a) anc cs = (HsProjection (setAnchorEpa an anc cs) a)
- setAnnotationAnchor (ExprWithTySig an a b) anc cs = (ExprWithTySig (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor (ArithSeq an a b) anc cs = (ArithSeq (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor (HsTypedBracket an a) anc cs = (HsTypedBracket (setAnchorEpa an anc cs) a)
- setAnnotationAnchor (HsUntypedBracket an a) anc cs = (HsUntypedBracket (setAnchorEpa an anc cs) a)
- setAnnotationAnchor (HsTypedSplice (x,an) e) anc cs = (HsTypedSplice (x,(setAnchorEpa an anc cs)) e)
- setAnnotationAnchor (HsUntypedSplice an e) anc cs = (HsUntypedSplice (setAnchorEpa an anc cs) e)
- setAnnotationAnchor (HsProc an a b) anc cs = (HsProc (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor (HsStatic an a) anc cs = (HsStatic (setAnchorEpa an anc cs) a)
- setAnnotationAnchor a@(HsPragE{}) _ _s = a
- setAnnotationAnchor a@(HsEmbTy{}) _ _s = a
+ setAnnotationAnchor a@(HsVar{}) _ _ _s = a
+ setAnnotationAnchor (HsUnboundVar an a) anc ts cs = (HsUnboundVar (setAnchorEpa an anc ts cs) a)
+ setAnnotationAnchor a@(HsRecSel{}) _ _ _s = a
+ setAnnotationAnchor (HsOverLabel an s a) anc ts cs = (HsOverLabel (setAnchorEpa an anc ts cs) s a)
+ setAnnotationAnchor (HsIPVar an a) anc ts cs = (HsIPVar (setAnchorEpa an anc ts cs) a)
+ setAnnotationAnchor (HsOverLit an a) anc ts cs = (HsOverLit (setAnchorEpa an anc ts cs) a)
+ setAnnotationAnchor (HsLit an a) anc ts cs = (HsLit (setAnchorEpa an anc ts cs) a)
+ setAnnotationAnchor (HsLam an a b) anc ts cs = (HsLam (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor (HsApp an a b) anc ts cs = (HsApp (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor a@(HsAppType {}) _ _ _s = a
+ setAnnotationAnchor (OpApp an a b c) anc ts cs = (OpApp (setAnchorEpa an anc ts cs) a b c)
+ setAnnotationAnchor (NegApp an a b) anc ts cs = (NegApp (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor (HsPar an a b c) anc ts cs = (HsPar (setAnchorEpa an anc ts cs) a b c)
+ setAnnotationAnchor (SectionL an a b) anc ts cs = (SectionL (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor (SectionR an a b) anc ts cs = (SectionR (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor (ExplicitTuple an a b) anc ts cs = (ExplicitTuple (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor (ExplicitSum an a b c) anc ts cs = (ExplicitSum (setAnchorEpa an anc ts cs) a b c)
+ setAnnotationAnchor (HsCase an a b) anc ts cs = (HsCase (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor (HsIf an a b c) anc ts cs = (HsIf (setAnchorEpa an anc ts cs) a b c)
+ setAnnotationAnchor (HsMultiIf an a) anc ts cs = (HsMultiIf (setAnchorEpa an anc ts cs) a)
+ setAnnotationAnchor (HsLet an a b c d) anc ts cs = (HsLet (setAnchorEpa an anc ts cs) a b c d)
+ setAnnotationAnchor (HsDo an a b) anc ts cs = (HsDo (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor (ExplicitList an a) anc ts cs = (ExplicitList (setAnchorEpa an anc ts cs) a)
+ setAnnotationAnchor (RecordCon an a b) anc ts cs = (RecordCon (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor (RecordUpd an a b) anc ts cs = (RecordUpd (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor (HsGetField an a b) anc ts cs = (HsGetField (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor (HsProjection an a) anc ts cs = (HsProjection (setAnchorEpa an anc ts cs) a)
+ setAnnotationAnchor (ExprWithTySig an a b) anc ts cs = (ExprWithTySig (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor (ArithSeq an a b) anc ts cs = (ArithSeq (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor (HsTypedBracket an a) anc ts cs = (HsTypedBracket (setAnchorEpa an anc ts cs) a)
+ setAnnotationAnchor (HsUntypedBracket an a) anc ts cs = (HsUntypedBracket (setAnchorEpa an anc ts cs) a)
+ setAnnotationAnchor (HsTypedSplice (x,an) e) anc ts cs = (HsTypedSplice (x,(setAnchorEpa an anc ts cs)) e)
+ setAnnotationAnchor (HsUntypedSplice an e) anc ts cs = (HsUntypedSplice (setAnchorEpa an anc ts cs) e)
+ setAnnotationAnchor (HsProc an a b) anc ts cs = (HsProc (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor (HsStatic an a) anc ts cs = (HsStatic (setAnchorEpa an anc ts cs) a)
+ setAnnotationAnchor a@(HsPragE{}) _ _ _s = a
+ setAnnotationAnchor a@(HsEmbTy{}) _ _ _s = a
exact (HsVar x n) = do
- n' <- markAnnotated n
+ -- The parser inserts a placeholder value for a record pun rhs. This must be
+ -- filtered.
+ let pun_RDR = "pun-right-hand-side"
+ n' <- if (showPprUnsafe n /= pun_RDR)
+ then markAnnotated n
+ else return n
return (HsVar x n')
exact x@(HsUnboundVar an _) = do
case an of
@@ -3062,7 +3270,7 @@ markMaybeDodgyStmts an stmts =
-- ---------------------------------------------------------------------
instance ExactPrint (HsPragE GhcPs) where
getAnnotationEntry HsPragSCC{} = NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (HsPragSCC (an,st) sl) = do
an0 <- markAnnOpenP an st "{-# SCC"
@@ -3079,8 +3287,8 @@ instance ExactPrint (HsUntypedSplice GhcPs) where
getAnnotationEntry (HsUntypedSpliceExpr an _) = fromAnn an
getAnnotationEntry (HsQuasiQuote _ _ _) = NoEntryVal
- setAnnotationAnchor (HsUntypedSpliceExpr an e) anc cs = HsUntypedSpliceExpr (setAnchorEpa an anc cs) e
- setAnnotationAnchor a@HsQuasiQuote {} _ _ = a
+ setAnnotationAnchor (HsUntypedSpliceExpr an e) anc ts cs = HsUntypedSpliceExpr (setAnchorEpa an anc ts cs) e
+ setAnnotationAnchor a@HsQuasiQuote {} _ _ _= a
exact (HsUntypedSpliceExpr an e) = do
an0 <- markEpAnnL an lidl AnnDollar
@@ -3105,7 +3313,7 @@ instance ExactPrint (HsUntypedSplice GhcPs) where
-- TODO:AZ: combine these instances
instance ExactPrint (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (MG x matches) = do
-- TODO:AZ use SortKey, in MG ann.
matches' <- if isGoodSrcSpan (getLocA matches)
@@ -3115,7 +3323,7 @@ instance ExactPrint (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where
instance ExactPrint (MatchGroup GhcPs (LocatedA (HsCmd GhcPs))) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (MG x matches) = do
-- TODO:AZ use SortKey, in MG ann.
matches' <- if isGoodSrcSpan (getLocA matches)
@@ -3127,7 +3335,7 @@ instance ExactPrint (MatchGroup GhcPs (LocatedA (HsCmd GhcPs))) where
instance (ExactPrint body) => ExactPrint (HsRecFields GhcPs body) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (HsRecFields fields mdot) = do
fields' <- markAnnotated fields
case mdot of
@@ -3140,17 +3348,17 @@ instance (ExactPrint body) => ExactPrint (HsRecFields GhcPs body) where
-- ---------------------------------------------------------------------
instance (ExactPrint body)
- => ExactPrint (HsFieldBind (LocatedAn NoEpAnns (FieldOcc GhcPs)) body) where
+ => ExactPrint (HsFieldBind (LocatedA (FieldOcc GhcPs)) body) where
getAnnotationEntry x = fromAnn (hfbAnn x)
- setAnnotationAnchor (HsFieldBind an f arg isPun) anc cs = (HsFieldBind (setAnchorEpa an anc cs) f arg isPun)
+ setAnnotationAnchor (HsFieldBind an f arg isPun) anc ts cs = (HsFieldBind (setAnchorEpa an anc ts cs) f arg isPun)
exact (HsFieldBind an f arg isPun) = do
debugM $ "HsFieldBind"
f' <- markAnnotated f
(an0, arg') <- if isPun then return (an, arg)
else do
- an0 <- markEpAnnL an lidl AnnEqual
- arg' <- markAnnotated arg
- return (an0, arg')
+ an0 <- markEpAnnL an lidl AnnEqual
+ arg' <- markAnnotated arg
+ return (an0, arg')
return (HsFieldBind an0 f' arg' isPun)
-- ---------------------------------------------------------------------
@@ -3158,30 +3366,30 @@ instance (ExactPrint body)
instance (ExactPrint body)
=> ExactPrint (HsFieldBind (LocatedAn NoEpAnns (FieldLabelStrings GhcPs)) body) where
getAnnotationEntry x = fromAnn (hfbAnn x)
- setAnnotationAnchor (HsFieldBind an f arg isPun) anc cs = (HsFieldBind (setAnchorEpa an anc cs) f arg isPun)
+ setAnnotationAnchor (HsFieldBind an f arg isPun) anc ts cs = (HsFieldBind (setAnchorEpa an anc ts cs) f arg isPun)
exact (HsFieldBind an f arg isPun) = do
debugM $ "HsFieldBind FieldLabelStrings"
f' <- markAnnotated f
(an0, arg') <- if isPun then return (an, arg)
else do
- an0 <- markEpAnnL an lidl AnnEqual
- arg' <- markAnnotated arg
- return (an0, arg')
+ an0 <- markEpAnnL an lidl AnnEqual
+ arg' <- markAnnotated arg
+ return (an0, arg')
return (HsFieldBind an0 f' arg' isPun)
-- ---------------------------------------------------------------------
instance (ExactPrint (LocatedA body))
- => ExactPrint (HsFieldBind (LocatedAn NoEpAnns (AmbiguousFieldOcc GhcPs)) (LocatedA body)) where
+ => ExactPrint (HsFieldBind (LocatedA (AmbiguousFieldOcc GhcPs)) (LocatedA body)) where
getAnnotationEntry x = fromAnn (hfbAnn x)
- setAnnotationAnchor (HsFieldBind an f arg isPun) anc cs = (HsFieldBind (setAnchorEpa an anc cs) f arg isPun)
+ setAnnotationAnchor (HsFieldBind an f arg isPun) anc ts cs = (HsFieldBind (setAnchorEpa an anc ts cs) f arg isPun)
exact (HsFieldBind an f arg isPun) = do
debugM $ "HsRecUpdField"
f' <- markAnnotated f
an0 <- if isPun then return an
else markEpAnnL an lidl AnnEqual
- arg' <- if ((locA $ getLoc arg) == noSrcSpan )
+ arg' <- if isPun
then return arg
else markAnnotated arg
return (HsFieldBind an0 f' arg' isPun)
@@ -3189,7 +3397,7 @@ instance (ExactPrint (LocatedA body))
-- ---------------------------------------------------------------------
instance ExactPrint (LHsRecUpdFields GhcPs) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact flds@(RegularRecUpdFields { recUpdFields = rbinds }) = do
debugM $ "RegularRecUpdFields"
@@ -3204,7 +3412,7 @@ instance ExactPrint (LHsRecUpdFields GhcPs) where
instance ExactPrint (FieldLabelStrings GhcPs) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (FieldLabelStrings fs) = FieldLabelStrings <$> markAnnotated fs
-- ---------------------------------------------------------------------
@@ -3212,7 +3420,7 @@ instance ExactPrint (FieldLabelStrings GhcPs) where
instance ExactPrint (DotFieldOcc GhcPs) where
getAnnotationEntry (DotFieldOcc an _) = fromAnn an
- setAnnotationAnchor (DotFieldOcc an a) anc cs = DotFieldOcc (setAnchorEpa an anc cs) a
+ setAnnotationAnchor (DotFieldOcc an a) anc ts cs = DotFieldOcc (setAnchorEpa an anc ts cs) a
exact (DotFieldOcc an (L loc (FieldLabelString fs))) = do
an0 <- markLensKwM an lafDot AnnDot
@@ -3227,8 +3435,8 @@ instance ExactPrint (HsTupArg GhcPs) where
getAnnotationEntry (Present an _) = fromAnn an
getAnnotationEntry (Missing an) = fromAnn an
- setAnnotationAnchor (Present an a) anc cs = Present (setAnchorEpa an anc cs) a
- setAnnotationAnchor (Missing an) anc cs = Missing (setAnchorEpa an anc cs)
+ setAnnotationAnchor (Present an a) anc ts cs = Present (setAnchorEpa an anc ts cs) a
+ setAnnotationAnchor (Missing an) anc ts cs = Missing (setAnchorEpa an anc ts cs)
exact (Present a e) = Present a <$> markAnnotated e
@@ -3239,7 +3447,7 @@ instance ExactPrint (HsTupArg GhcPs) where
instance ExactPrint (HsCmdTop GhcPs) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (HsCmdTop a cmd) = HsCmdTop a <$> markAnnotated cmd
-- ---------------------------------------------------------------------
@@ -3255,19 +3463,15 @@ instance ExactPrint (HsCmd GhcPs) where
getAnnotationEntry (HsCmdLet an _ _ _ _) = fromAnn an
getAnnotationEntry (HsCmdDo an _) = fromAnn an
- setAnnotationAnchor (HsCmdArrApp an a b c d) anc cs = (HsCmdArrApp (setAnchorEpa an anc cs) a b c d)
- setAnnotationAnchor (HsCmdArrForm an a b c d ) anc cs = (HsCmdArrForm (setAnchorEpa an anc cs) a b c d )
- setAnnotationAnchor (HsCmdApp an a b ) anc cs = (HsCmdApp (setAnchorEpa an anc cs) a b )
-
- -- ToDo: why is LamSingle treated differently?
- setAnnotationAnchor a@(HsCmdLam _ LamSingle _) _ _s = a
- setAnnotationAnchor (HsCmdLam an a b) anc cs = (HsCmdLam (setAnchorEpa an anc cs) a b)
-
- setAnnotationAnchor (HsCmdPar an a b c) anc cs = (HsCmdPar (setAnchorEpa an anc cs) a b c)
- setAnnotationAnchor (HsCmdCase an a b) anc cs = (HsCmdCase (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor (HsCmdIf an a b c d) anc cs = (HsCmdIf (setAnchorEpa an anc cs) a b c d)
- setAnnotationAnchor (HsCmdLet an a b c d) anc cs = (HsCmdLet (setAnchorEpa an anc cs) a b c d)
- setAnnotationAnchor (HsCmdDo an a) anc cs = (HsCmdDo (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor (HsCmdArrApp an a b c d) anc ts cs = (HsCmdArrApp (setAnchorEpa an anc ts cs) a b c d)
+ setAnnotationAnchor (HsCmdArrForm an a b c d ) anc ts cs = (HsCmdArrForm (setAnchorEpa an anc ts cs) a b c d )
+ setAnnotationAnchor (HsCmdApp an a b ) anc ts cs = (HsCmdApp (setAnchorEpa an anc ts cs) a b )
+ setAnnotationAnchor (HsCmdLam an a b) anc ts cs = (HsCmdLam (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor (HsCmdPar an a b c) anc ts cs = (HsCmdPar (setAnchorEpa an anc ts cs) a b c)
+ setAnnotationAnchor (HsCmdCase an a b) anc ts cs = (HsCmdCase (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor (HsCmdIf an a b c d) anc ts cs = (HsCmdIf (setAnchorEpa an anc ts cs) a b c d)
+ setAnnotationAnchor (HsCmdLet an a b c d) anc ts cs = (HsCmdLet (setAnchorEpa an anc ts cs) a b c d)
+ setAnnotationAnchor (HsCmdDo an a) anc ts cs = (HsCmdDo (setAnchorEpa an anc ts cs) a)
exact (HsCmdArrApp an arr arg o isRightToLeft) = do
if isRightToLeft
@@ -3374,14 +3578,14 @@ instance (
-----------------------------------------------------------------
- setAnnotationAnchor a@(LastStmt _ _ _ _) _ _s = a
- setAnnotationAnchor (BindStmt an a b) anc cs = (BindStmt (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor a@(ApplicativeStmt _ _ _) _ _s = a
- setAnnotationAnchor a@(BodyStmt _ _ _ _) _ _s = a
- setAnnotationAnchor (LetStmt an a) anc cs = (LetStmt (setAnchorEpa an anc cs) a)
- setAnnotationAnchor a@(ParStmt _ _ _ _) _ _s = a
- setAnnotationAnchor (TransStmt an a b c d e f g h) anc cs = (TransStmt (setAnchorEpa an anc cs) a b c d e f g h)
- setAnnotationAnchor (RecStmt an a b c d e f) anc cs = (RecStmt (setAnchorEpa an anc cs) a b c d e f)
+ setAnnotationAnchor a@(LastStmt _ _ _ _) _ _ _s = a
+ setAnnotationAnchor (BindStmt an a b) anc ts cs = (BindStmt (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor a@(ApplicativeStmt _ _ _) _ _ _s = a
+ setAnnotationAnchor a@(BodyStmt _ _ _ _) _ _ _s = a
+ setAnnotationAnchor (LetStmt an a) anc ts cs = (LetStmt (setAnchorEpa an anc ts cs) a)
+ setAnnotationAnchor a@(ParStmt _ _ _ _) _ _ _s = a
+ setAnnotationAnchor (TransStmt an a b c d e f g h) anc ts cs = (TransStmt (setAnchorEpa an anc ts cs) a b c d e f g h)
+ setAnnotationAnchor (RecStmt an a b c d e f) anc ts cs = (RecStmt (setAnchorEpa an anc ts cs) a b c d e f)
-----------------------------------------------------------------
@@ -3432,7 +3636,7 @@ instance (
instance ExactPrint (ParStmtBlock GhcPs GhcPs) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (ParStmtBlock a stmts b c) = do
stmts' <- markAnnotated stmts
return (ParStmtBlock a stmts' b c)
@@ -3472,10 +3676,10 @@ instance ExactPrint (TyClDecl GhcPs) where
getAnnotationEntry (DataDecl { tcdDExt = an }) = fromAnn an
getAnnotationEntry (ClassDecl { tcdCExt = (an, _) }) = fromAnn an
- setAnnotationAnchor a@FamDecl{} _ _s = a
- setAnnotationAnchor x@SynDecl{} anc cs = x { tcdSExt = setAnchorEpa (tcdSExt x) anc cs }
- setAnnotationAnchor x@DataDecl{} anc cs = x { tcdDExt = setAnchorEpa (tcdDExt x) anc cs }
- setAnnotationAnchor x@ClassDecl{} anc cs = x { tcdCExt = (setAnchorEpa an anc cs, a) }
+ setAnnotationAnchor a@FamDecl{} _ _ _s = a
+ setAnnotationAnchor x@SynDecl{} anc ts cs = x { tcdSExt = setAnchorEpa (tcdSExt x) anc ts cs }
+ setAnnotationAnchor x@DataDecl{} anc ts cs = x { tcdDExt = setAnchorEpa (tcdDExt x) anc ts cs }
+ setAnnotationAnchor x@ClassDecl{} anc ts cs = x { tcdCExt = (setAnchorEpa an anc ts cs, a) }
where
(an,a) = tcdCExt x
@@ -3577,7 +3781,7 @@ instance ExactPrint (TyClDecl GhcPs) where
instance ExactPrint (FunDep GhcPs) where
getAnnotationEntry (FunDep an _ _) = fromAnn an
- setAnnotationAnchor (FunDep an a b) anc cs = FunDep (setAnchorEpa an anc cs) a b
+ setAnnotationAnchor (FunDep an a b) anc ts cs = FunDep (setAnchorEpa an anc ts cs) a b
exact (FunDep an ls rs') = do
ls' <- markAnnotated ls
@@ -3589,7 +3793,7 @@ instance ExactPrint (FunDep GhcPs) where
instance ExactPrint (FamilyDecl GhcPs) where
getAnnotationEntry (FamilyDecl { fdExt = an }) = fromAnn an
- setAnnotationAnchor x anc cs = x { fdExt = setAnchorEpa (fdExt x) anc cs}
+ setAnnotationAnchor x anc ts cs = x { fdExt = setAnchorEpa (fdExt x) anc ts cs}
exact (FamilyDecl { fdExt = an
, fdInfo = info
@@ -3760,7 +3964,7 @@ exactVanillaDeclHead thing tvs@(HsQTvs { hsq_explicit = tyvars }) fixity context
instance ExactPrint (InjectivityAnn GhcPs) where
getAnnotationEntry (InjectivityAnn an _ _) = fromAnn an
- setAnnotationAnchor (InjectivityAnn an a b) anc cs = InjectivityAnn (setAnchorEpa an anc cs) a b
+ setAnnotationAnchor (InjectivityAnn an a b) anc ts cs = InjectivityAnn (setAnchorEpa an anc ts cs) a b
exact (InjectivityAnn an lhs rhs) = do
an0 <- markEpAnnL an lidl AnnVbar
lhs' <- markAnnotated lhs
@@ -3807,8 +4011,8 @@ instance ExactPrintTVFlag flag => ExactPrint (HsTyVarBndr flag GhcPs) where
getAnnotationEntry (UserTyVar an _ _) = fromAnn an
getAnnotationEntry (KindedTyVar an _ _ _) = fromAnn an
- setAnnotationAnchor (UserTyVar an a b) anc cs = UserTyVar (setAnchorEpa an anc cs) a b
- setAnnotationAnchor (KindedTyVar an a b c) anc cs = KindedTyVar (setAnchorEpa an anc cs) a b c
+ setAnnotationAnchor (UserTyVar an a b) anc ts cs = UserTyVar (setAnchorEpa an anc ts cs) a b
+ setAnnotationAnchor (KindedTyVar an a b c) anc ts cs = KindedTyVar (setAnchorEpa an anc ts cs) a b c
exact (UserTyVar an flag n) = do
r <- exactTVDelimiters an flag $ do
@@ -3854,29 +4058,29 @@ instance ExactPrint (HsType GhcPs) where
getAnnotationEntry (HsWildCardTy _) = NoEntryVal
getAnnotationEntry (XHsType _) = NoEntryVal
- setAnnotationAnchor a@(HsForAllTy _ _ _) _ _s = a
- setAnnotationAnchor a@(HsQualTy _ _ _) _ _s = a
- setAnnotationAnchor (HsTyVar an a b) anc cs = (HsTyVar (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor a@(HsAppTy _ _ _) _ _s = a
- setAnnotationAnchor a@(HsAppKindTy _ _ _ _) _ _s = a
- setAnnotationAnchor (HsFunTy an a b c) anc cs = (HsFunTy (setAnchorEpa an anc cs) a b c)
- setAnnotationAnchor (HsListTy an a) anc cs = (HsListTy (setAnchorEpa an anc cs) a)
- setAnnotationAnchor (HsTupleTy an a b) anc cs = (HsTupleTy (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor (HsSumTy an a) anc cs = (HsSumTy (setAnchorEpa an anc cs) a)
- setAnnotationAnchor a@(HsOpTy _ _ _ _ _) _ _s = a
- setAnnotationAnchor (HsParTy an a) anc cs = (HsParTy (setAnchorEpa an anc cs) a)
- setAnnotationAnchor (HsIParamTy an a b) anc cs = (HsIParamTy (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor a@(HsStarTy _ _) _ _s = a
- setAnnotationAnchor (HsKindSig an a b) anc cs = (HsKindSig (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor a@(HsSpliceTy _ _) _ _s = a
- setAnnotationAnchor (HsDocTy an a b) anc cs = (HsDocTy (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor (HsBangTy an a b) anc cs = (HsBangTy (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor (HsRecTy an a) anc cs = (HsRecTy (setAnchorEpa an anc cs) a)
- setAnnotationAnchor (HsExplicitListTy an a b) anc cs = (HsExplicitListTy (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor (HsExplicitTupleTy an a) anc cs = (HsExplicitTupleTy (setAnchorEpa an anc cs) a)
- setAnnotationAnchor a@(HsTyLit _ _) _ _s = a
- setAnnotationAnchor a@(HsWildCardTy _) _ _s = a
- setAnnotationAnchor a@(XHsType _) _ _s = a
+ setAnnotationAnchor a@(HsForAllTy _ _ _) _ _ _s = a
+ setAnnotationAnchor a@(HsQualTy _ _ _) _ _ _s = a
+ setAnnotationAnchor (HsTyVar an a b) anc ts cs = (HsTyVar (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor a@(HsAppTy _ _ _) _ _ _s = a
+ setAnnotationAnchor a@(HsAppKindTy _ _ _ _) _ _ _s = a
+ setAnnotationAnchor (HsFunTy an a b c) anc ts cs = (HsFunTy (setAnchorEpa an anc ts cs) a b c)
+ setAnnotationAnchor (HsListTy an a) anc ts cs = (HsListTy (setAnchorEpa an anc ts cs) a)
+ setAnnotationAnchor (HsTupleTy an a b) anc ts cs = (HsTupleTy (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor (HsSumTy an a) anc ts cs = (HsSumTy (setAnchorEpa an anc ts cs) a)
+ setAnnotationAnchor a@(HsOpTy _ _ _ _ _) _ _ _s = a
+ setAnnotationAnchor (HsParTy an a) anc ts cs = (HsParTy (setAnchorEpa an anc ts cs) a)
+ setAnnotationAnchor (HsIParamTy an a b) anc ts cs = (HsIParamTy (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor a@(HsStarTy _ _) _ _ _s = a
+ setAnnotationAnchor (HsKindSig an a b) anc ts cs = (HsKindSig (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor a@(HsSpliceTy _ _) _ _ _s = a
+ setAnnotationAnchor (HsDocTy an a b) anc ts cs = (HsDocTy (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor (HsBangTy an a b) anc ts cs = (HsBangTy (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor (HsRecTy an a) anc ts cs = (HsRecTy (setAnchorEpa an anc ts cs) a)
+ setAnnotationAnchor (HsExplicitListTy an a b) anc ts cs = (HsExplicitListTy (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor (HsExplicitTupleTy an a) anc ts cs = (HsExplicitTupleTy (setAnchorEpa an anc ts cs) a)
+ setAnnotationAnchor a@(HsTyLit _ _) _ _ _s = a
+ setAnnotationAnchor a@(HsWildCardTy _) _ _ _s = a
+ setAnnotationAnchor a@(XHsType _) _ _ _s = a
exact (HsForAllTy { hst_xforall = an
, hst_tele = tele, hst_body = ty }) = do
@@ -4004,8 +4208,8 @@ instance ExactPrint (HsForAllTelescope GhcPs) where
getAnnotationEntry (HsForAllVis an _) = fromAnn an
getAnnotationEntry (HsForAllInvis an _) = fromAnn an
- setAnnotationAnchor (HsForAllVis an a) anc cs = HsForAllVis (setAnchorEpa an anc cs) a
- setAnnotationAnchor (HsForAllInvis an a) anc cs = HsForAllInvis (setAnchorEpa an anc cs) a
+ setAnnotationAnchor (HsForAllVis an a) anc ts cs = HsForAllVis (setAnchorEpa an anc ts cs) a
+ setAnnotationAnchor (HsForAllInvis an a) anc ts cs = HsForAllInvis (setAnchorEpa an anc ts cs) a
exact (HsForAllVis an bndrs) = do
an0 <- markLensAA an lfst -- AnnForall
@@ -4023,8 +4227,8 @@ instance ExactPrint (HsForAllTelescope GhcPs) where
instance ExactPrint (HsDerivingClause GhcPs) where
getAnnotationEntry d@(HsDerivingClause{}) = fromAnn (deriv_clause_ext d)
- setAnnotationAnchor x anc cs = (x { deriv_clause_ext = setAnchorEpa (deriv_clause_ext x) anc cs})
- `debug` ("setAnnotationAnchor HsDerivingClause: (anc,cs):" ++ showAst (anc,cs))
+ setAnnotationAnchor x anc ts cs = (x { deriv_clause_ext = setAnchorEpa (deriv_clause_ext x) anc ts cs})
+ `debug` ("setAnnotationAnchor HsDerivingClause: (anc,cs):" ++ showAst (anc,cs))
exact (HsDerivingClause { deriv_clause_ext = an
, deriv_clause_strategy = dcs
@@ -4050,10 +4254,10 @@ instance ExactPrint (DerivStrategy GhcPs) where
getAnnotationEntry (NewtypeStrategy an) = fromAnn an
getAnnotationEntry (ViaStrategy (XViaStrategyPs an _)) = fromAnn an
- setAnnotationAnchor (StockStrategy an) anc cs = (StockStrategy (setAnchorEpa an anc cs))
- setAnnotationAnchor (AnyclassStrategy an) anc cs = (AnyclassStrategy (setAnchorEpa an anc cs))
- setAnnotationAnchor (NewtypeStrategy an) anc cs = (NewtypeStrategy (setAnchorEpa an anc cs))
- setAnnotationAnchor (ViaStrategy (XViaStrategyPs an a)) anc cs = (ViaStrategy (XViaStrategyPs (setAnchorEpa an anc cs) a))
+ setAnnotationAnchor (StockStrategy an) anc ts cs = (StockStrategy (setAnchorEpa an anc ts cs))
+ setAnnotationAnchor (AnyclassStrategy an) anc ts cs = (AnyclassStrategy (setAnchorEpa an anc ts cs))
+ setAnnotationAnchor (NewtypeStrategy an) anc ts cs = (NewtypeStrategy (setAnchorEpa an anc ts cs))
+ setAnnotationAnchor (ViaStrategy (XViaStrategyPs an a)) anc ts cs = (ViaStrategy (XViaStrategyPs (setAnchorEpa an anc ts cs) a))
exact (StockStrategy an) = do
an0 <- markEpAnnL an lid AnnStock
@@ -4082,17 +4286,13 @@ instance (ExactPrint a) => ExactPrint (LocatedC a) where
opens' <- mapM (markKwA AnnOpenP) opens
a' <- markAnnotated a
closes' <- mapM (markKwA AnnCloseP) closes
- ma' <- case ma of
- Just (UnicodeSyntax, r) -> Just . (UnicodeSyntax,) <$> markKwA AnnDarrowU r
- Just (NormalSyntax, r) -> Just . (NormalSyntax,) <$> markKwA AnnDarrow r
- Nothing -> pure Nothing
- return (L (SrcSpanAnn (EpAnn anc (AnnContext ma' opens' closes') cs) l) a')
+ return (L (SrcSpanAnn (EpAnn anc (AnnContext ma opens' closes') cs) l) a')
-- ---------------------------------------------------------------------
instance ExactPrint (DerivClauseTys GhcPs) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (DctSingle x ty) = do
ty' <- markAnnotated ty
@@ -4105,7 +4305,7 @@ instance ExactPrint (DerivClauseTys GhcPs) where
instance ExactPrint (HsSigType GhcPs) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (HsSig a bndrs ty) = do
bndrs' <- markAnnotated bndrs
@@ -4128,27 +4328,23 @@ instance ExactPrint (LocatedN RdrName) where
mn <- markName a o (Just (l,n)) c
case mn of
(o', (Just (l',_n)), c') -> do
- t' <- markTrailing t
- return (NameAnn a o' l' c' t')
+ return (NameAnn a o' l' c' t)
_ -> error "ExactPrint (LocatedN RdrName)"
NameAnnCommas a o commas c t -> do
let (kwo,kwc) = adornments a
(AddEpAnn _ o') <- markKwC NoCaptureComments (AddEpAnn kwo o)
commas' <- forM commas (\loc -> locFromAdd <$> markKwC NoCaptureComments (AddEpAnn AnnComma loc))
(AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn kwc c)
- t' <- markTrailing t
- return (NameAnnCommas a o' commas' c' t')
+ return (NameAnnCommas a o' commas' c' t)
NameAnnBars a o bars c t -> do
let (kwo,kwc) = adornments a
(AddEpAnn _ o') <- markKwC NoCaptureComments (AddEpAnn kwo o)
bars' <- forM bars (\loc -> locFromAdd <$> markKwC NoCaptureComments (AddEpAnn AnnVbar loc))
(AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn kwc c)
- t' <- markTrailing t
- return (NameAnnBars a o' bars' c' t')
+ return (NameAnnBars a o' bars' c' t)
NameAnnOnly a o c t -> do
(o',_,c') <- markName a o Nothing c
- t' <- markTrailing t
- return (NameAnnOnly a o' c' t')
+ return (NameAnnOnly a o' c' t)
NameAnnRArrow unicode o nl c t -> do
o' <- case o of
Just o0 -> do
@@ -4164,18 +4360,15 @@ instance ExactPrint (LocatedN RdrName) where
(AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn AnnCloseP c0)
return (Just c')
Nothing -> return Nothing
- t' <- markTrailing t
- return (NameAnnRArrow unicode o' nl' c' t')
+ return (NameAnnRArrow unicode o' nl' c' t)
NameAnnQuote q name t -> do
debugM $ "NameAnnQuote"
(AddEpAnn _ q') <- markKwC NoCaptureComments (AddEpAnn AnnSimpleQuote q)
(L name' _) <- markAnnotated (L name n)
- t' <- markTrailing t
- return (NameAnnQuote q' name' t')
+ return (NameAnnQuote q' name' t)
NameAnnTrailing t -> do
_anc' <- printUnicode anc n
- t' <- markTrailing t
- return (NameAnnTrailing t')
+ return (NameAnnTrailing t)
return (L (SrcSpanAnn (EpAnn anc ann' cs) ll) n)
locFromAdd :: AddEpAnn -> EpaLocation
@@ -4190,7 +4383,7 @@ printUnicode anc n = do
loc <- printStringAtAAC NoCaptureComments (EpaDelta (SameLine 0) []) str
case loc of
EpaSpan _ _ -> return anc
- EpaDelta dp [] -> return anc { anchor_op = MovedAnchor dp }
+ EpaDelta dp [] -> return anc { anchor_op = MovedAnchor dp [] }
EpaDelta _ _cs -> error "printUnicode should not capture comments"
@@ -4215,13 +4408,6 @@ adornments NameParensHash = (AnnOpenPH, AnnClosePH)
adornments NameBackquotes = (AnnBackquote, AnnBackquote)
adornments NameSquare = (AnnOpenS, AnnCloseS)
-
-markTrailingL :: (Monad m, Monoid w) => EpAnn a -> Lens a [TrailingAnn] -> EP w m (EpAnn a)
-markTrailingL EpAnnNotUsed _ = return EpAnnNotUsed
-markTrailingL (EpAnn anc an cs) l = do
- ts <- mapM markKwT (view l an)
- return (EpAnn anc (set l ts an) cs)
-
markTrailing :: (Monad m, Monoid w) => [TrailingAnn] -> EP w m [TrailingAnn]
markTrailing ts = do
p <- getPosP
@@ -4255,8 +4441,8 @@ instance ExactPrint (ConDecl GhcPs) where
getAnnotationEntry x@(ConDeclGADT{}) = fromAnn (con_g_ext x)
getAnnotationEntry x@(ConDeclH98{}) = fromAnn (con_ext x)
- setAnnotationAnchor x@ConDeclGADT{} anc cs = x { con_g_ext = setAnchorEpa (con_g_ext x) anc cs}
- setAnnotationAnchor x@ConDeclH98{} anc cs = x { con_ext = setAnchorEpa (con_ext x) anc cs}
+ setAnnotationAnchor x@ConDeclGADT{} anc ts cs = x { con_g_ext = setAnchorEpa (con_g_ext x) anc ts cs}
+ setAnnotationAnchor x@ConDeclH98{} anc ts cs = x { con_ext = setAnchorEpa (con_ext x) anc ts cs}
-- based on pprConDecl
exact (ConDeclH98 { con_ext = an
@@ -4347,7 +4533,7 @@ instance ExactPrint (ConDecl GhcPs) where
instance ExactPrint Void where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact x = return x
-- ---------------------------------------------------------------------
@@ -4356,8 +4542,8 @@ instance ExactPrintTVFlag flag => ExactPrint (HsOuterTyVarBndrs flag GhcPs) wher
getAnnotationEntry (HsOuterImplicit _) = NoEntryVal
getAnnotationEntry (HsOuterExplicit an _) = fromAnn an
- setAnnotationAnchor (HsOuterImplicit a) _ _ = HsOuterImplicit a
- setAnnotationAnchor (HsOuterExplicit an a) anc cs = HsOuterExplicit (setAnchorEpa an anc cs) a
+ setAnnotationAnchor (HsOuterImplicit a) _ _ _ = HsOuterImplicit a
+ setAnnotationAnchor (HsOuterExplicit an a) anc ts cs = HsOuterExplicit (setAnchorEpa an anc ts cs) a
exact b@(HsOuterImplicit _) = pure b
exact (HsOuterExplicit an bndrs) = do
@@ -4371,7 +4557,7 @@ instance ExactPrintTVFlag flag => ExactPrint (HsOuterTyVarBndrs flag GhcPs) wher
instance ExactPrint (ConDeclField GhcPs) where
getAnnotationEntry f@(ConDeclField{}) = fromAnn (cd_fld_ext f)
- setAnnotationAnchor x anc cs = x { cd_fld_ext = setAnchorEpa (cd_fld_ext x) anc cs}
+ setAnnotationAnchor x anc ts cs = x { cd_fld_ext = setAnchorEpa (cd_fld_ext x) anc ts cs}
exact (ConDeclField an names ftype mdoc) = do
names' <- markAnnotated names
@@ -4384,14 +4570,14 @@ instance ExactPrint (ConDeclField GhcPs) where
instance ExactPrint (FieldOcc GhcPs) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact f@(FieldOcc _ n) = markAnnotated n >> return f
-- ---------------------------------------------------------------------
instance ExactPrint (AmbiguousFieldOcc GhcPs) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact f@(Unambiguous _ n) = markAnnotated n >> return f
exact f@(Ambiguous _ n) = markAnnotated n >> return f
@@ -4399,7 +4585,7 @@ instance ExactPrint (AmbiguousFieldOcc GhcPs) where
instance (ExactPrint a) => ExactPrint (HsScaled GhcPs a) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (HsScaled arr t) = do
t' <- markAnnotated t
arr' <- markArrow arr
@@ -4429,7 +4615,7 @@ instance ExactPrint (LocatedP CType) where
instance ExactPrint (SourceText, RuleName) where
-- We end up at the right place from the Located wrapper
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (st, rn)
= printStringAdvance (toSourceTextWithSuffix st (unpackFS rn) "")
@@ -4490,7 +4676,6 @@ instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr Gh
markAnnotated stmts
return (L (SrcSpanAnn an'' l) stmts')
--- instance ExactPrint (LocatedL [CmdLStmt GhcPs]) where
instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where
getAnnotationEntry = entryFromLocatedA
setAnnotationAnchor = setAnchorAn
@@ -4531,14 +4716,14 @@ instance ExactPrint (IE GhcPs) where
getAnnotationEntry (IEDoc _ _) = NoEntryVal
getAnnotationEntry (IEDocNamed _ _) = NoEntryVal
- setAnnotationAnchor a@(IEVar _ _) _ _s = a
- setAnnotationAnchor (IEThingAbs (depr, an) a) anc cs = (IEThingAbs (depr, setAnchorEpa an anc cs) a)
- setAnnotationAnchor (IEThingAll (depr, an) a) anc cs = (IEThingAll (depr, setAnchorEpa an anc cs) a)
- setAnnotationAnchor (IEThingWith (depr, an) a b c) anc cs = (IEThingWith (depr, setAnchorEpa an anc cs) a b c)
- setAnnotationAnchor (IEModuleContents (depr, an) a) anc cs = (IEModuleContents (depr, setAnchorEpa an anc cs) a)
- setAnnotationAnchor a@(IEGroup _ _ _) _ _s = a
- setAnnotationAnchor a@(IEDoc _ _) _ _s = a
- setAnnotationAnchor a@(IEDocNamed _ _) _ _s = a
+ setAnnotationAnchor a@(IEVar _ _) _ _ _s = a
+ setAnnotationAnchor (IEThingAbs (depr, an) a) anc ts cs = (IEThingAbs (depr, setAnchorEpa an anc ts cs) a)
+ setAnnotationAnchor (IEThingAll (depr, an) a) anc ts cs = (IEThingAll (depr, setAnchorEpa an anc ts cs) a)
+ setAnnotationAnchor (IEThingWith (depr, an) a b c) anc ts cs = (IEThingWith (depr, setAnchorEpa an anc ts cs) a b c)
+ setAnnotationAnchor (IEModuleContents (depr, an) a) anc ts cs = (IEModuleContents (depr, setAnchorEpa an anc ts cs) a)
+ setAnnotationAnchor a@(IEGroup _ _ _) _ _ _s = a
+ setAnnotationAnchor a@(IEDoc _ _) _ _ _s = a
+ setAnnotationAnchor a@(IEDocNamed _ _) _ _ _s = a
exact (IEVar depr ln) = do
depr' <- markAnnotated depr
@@ -4594,7 +4779,7 @@ instance ExactPrint (IE GhcPs) where
instance ExactPrint (IEWrappedName GhcPs) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (IEName x n) = do
n' <- markAnnotated n
@@ -4629,23 +4814,23 @@ instance ExactPrint (Pat GhcPs) where
getAnnotationEntry (SigPat an _ _) = fromAnn an
getAnnotationEntry (EmbTyPat _ _ _) = NoEntryVal
- setAnnotationAnchor a@(WildPat _) _ _s = a
- setAnnotationAnchor a@(VarPat _ _) _ _s = a
- setAnnotationAnchor (LazyPat an a) anc cs = (LazyPat (setAnchorEpa an anc cs) a)
- setAnnotationAnchor (AsPat an a at b) anc cs = (AsPat (setAnchorEpa an anc cs) a at b)
- setAnnotationAnchor (ParPat an a b c) anc cs = (ParPat (setAnchorEpa an anc cs) a b c)
- setAnnotationAnchor (BangPat an a) anc cs = (BangPat (setAnchorEpa an anc cs) a)
- setAnnotationAnchor (ListPat an a) anc cs = (ListPat (setAnchorEpa an anc cs) a)
- setAnnotationAnchor (TuplePat an a b) anc cs = (TuplePat (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor (SumPat an a b c) anc cs = (SumPat (setAnchorEpa an anc cs) a b c)
- setAnnotationAnchor (ConPat an a b) anc cs = (ConPat (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor (ViewPat an a b) anc cs = (ViewPat (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor a@(SplicePat _ _) _ _s = a
- setAnnotationAnchor a@(LitPat _ _) _ _s = a
- setAnnotationAnchor (NPat an a b c) anc cs = (NPat (setAnchorEpa an anc cs) a b c)
- setAnnotationAnchor (NPlusKPat an a b c d e) anc cs = (NPlusKPat (setAnchorEpa an anc cs) a b c d e)
- setAnnotationAnchor (SigPat an a b) anc cs = (SigPat (setAnchorEpa an anc cs) a b)
- setAnnotationAnchor a@(EmbTyPat _ _ _) _ _s = a
+ setAnnotationAnchor a@(WildPat _) _ _ _s = a
+ setAnnotationAnchor a@(VarPat _ _) _ _ _s = a
+ setAnnotationAnchor (LazyPat an a) anc ts cs = (LazyPat (setAnchorEpa an anc ts cs) a)
+ setAnnotationAnchor (AsPat an a at b) anc ts cs = (AsPat (setAnchorEpa an anc ts cs) a at b)
+ setAnnotationAnchor (ParPat an a b c) anc ts cs = (ParPat (setAnchorEpa an anc ts cs) a b c)
+ setAnnotationAnchor (BangPat an a) anc ts cs = (BangPat (setAnchorEpa an anc ts cs) a)
+ setAnnotationAnchor (ListPat an a) anc ts cs = (ListPat (setAnchorEpa an anc ts cs) a)
+ setAnnotationAnchor (TuplePat an a b) anc ts cs = (TuplePat (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor (SumPat an a b c) anc ts cs = (SumPat (setAnchorEpa an anc ts cs) a b c)
+ setAnnotationAnchor (ConPat an a b) anc ts cs = (ConPat (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor (ViewPat an a b) anc ts cs = (ViewPat (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor a@(SplicePat _ _) _ _ _s = a
+ setAnnotationAnchor a@(LitPat _ _) _ _ _s = a
+ setAnnotationAnchor (NPat an a b c) anc ts cs = (NPat (setAnchorEpa an anc ts cs) a b c)
+ setAnnotationAnchor (NPlusKPat an a b c d e) anc ts cs = (NPlusKPat (setAnchorEpa an anc ts cs) a b c d e)
+ setAnnotationAnchor (SigPat an a b) anc ts cs = (SigPat (setAnchorEpa an anc ts cs) a b)
+ setAnnotationAnchor a@(EmbTyPat _ _ _) _ _ _s = a
exact (WildPat w) = do
anchor <- getAnchorU
@@ -4702,7 +4887,6 @@ instance ExactPrint (Pat GhcPs) where
an3 <- markEpAnnL an2 lsumPatParens AnnClosePH
return (SumPat an3 pat' alt arity)
- -- | ConPat an con args)
exact (ConPat an con details) = do
(an', con', details') <- exactUserCon an con details
return (ConPat an' con' details')
@@ -4722,7 +4906,6 @@ instance ExactPrint (Pat GhcPs) where
ol' <- markAnnotated ol
return (NPat an0 ol' mn z)
- -- | NPlusKPat an n lit1 lit2 _ _)
exact (NPlusKPat an n k lit2 a b) = do
n' <- markAnnotated n
an' <- printStringAtAAL an lid "+"
@@ -4744,7 +4927,7 @@ instance ExactPrint (Pat GhcPs) where
instance ExactPrint (HsPatSigType GhcPs) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (HsPS an ty) = do
ty' <- markAnnotated ty
@@ -4752,7 +4935,7 @@ instance ExactPrint (HsPatSigType GhcPs) where
instance ExactPrint (HsTyPat GhcPs) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (HsTP an ty) = do
ty' <- markAnnotated ty
@@ -4762,7 +4945,7 @@ instance ExactPrint (HsTyPat GhcPs) where
instance ExactPrint (HsOverLit GhcPs) where
getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact ol =
let str = case ol_val ol of
@@ -4780,9 +4963,7 @@ hsLit2String :: HsLit GhcPs -> String
hsLit2String lit =
case lit of
HsChar src v -> toSourceTextWithSuffix src v ""
- -- It should be included here
- -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471
- HsCharPrim src p -> toSourceTextWithSuffix src p "#"
+ HsCharPrim src p -> toSourceTextWithSuffix src p ""
HsString src v -> toSourceTextWithSuffix src v ""
HsStringPrim src v -> toSourceTextWithSuffix src v ""
HsInt _ (IL src _ v) -> toSourceTextWithSuffix src v ""
@@ -4828,7 +5009,7 @@ exactUserCon an c details = do
instance ExactPrint (HsConPatTyArg GhcPs) where
getAnnotationEntry _ = NoEntryVal
- setAnnotationAnchor a _ _ = a
+ setAnnotationAnchor a _ _ _ = a
exact (HsConPatTyArg at tyarg) = do
at' <- markToken at
tyarg' <- markAnnotated tyarg
@@ -4850,7 +5031,7 @@ exactConArgs (RecCon rpats) = do
-- ---------------------------------------------------------------------
-entryFromLocatedA :: LocatedAn ann a -> Entry
+entryFromLocatedA :: (HasTrailing ann) => LocatedAn ann a -> Entry
entryFromLocatedA (L la _) = fromAnn la
-- =====================================================================
@@ -4882,8 +5063,8 @@ isGoodDeltaWithOffset dp colOffset = isGoodDelta (deltaPos l c)
-- | Print a comment, using the current layout offset to convert the
-- @DeltaPos@ to an absolute position.
-printQueuedComment :: (Monad m, Monoid w) => RealSrcSpan -> Comment -> DeltaPos -> EP w m ()
-printQueuedComment _loc Comment{commentContents} dp = do
+printQueuedComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m ()
+printQueuedComment Comment{commentContents} dp = do
p <- getPosP
d <- getPriorEndD
colOffset <- getLayoutOffsetP
@@ -4919,7 +5100,7 @@ setLayoutTopLevelP k = do
debugM $ "setLayoutTopLevelP entered"
oldAnchorOffset <- getLayoutOffsetP
modify (\a -> a { pMarkLayout = False
- , pLHS = 1} )
+ , pLHS = 0} )
r <- k
debugM $ "setLayoutTopLevelP:resetting"
setLayoutOffsetP oldAnchorOffset
@@ -4949,6 +5130,13 @@ getPriorEndD = gets dPriorEndPosition
getAnchorU :: (Monad m, Monoid w) => EP w m RealSrcSpan
getAnchorU = gets uAnchorSpan
+getAcceptSpan ::(Monad m, Monoid w) => EP w m Bool
+getAcceptSpan = gets pAcceptSpan
+
+setAcceptSpan ::(Monad m, Monoid w) => Bool -> EP w m ()
+setAcceptSpan f =
+ modify (\s -> s { pAcceptSpan = f })
+
setPriorEndD :: (Monad m, Monoid w) => Pos -> EP w m ()
setPriorEndD pe = do
setPriorEndNoLayoutD pe
diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs
index 6a44d89457c7..be550111cc58 100644
--- a/utils/check-exact/Main.hs
+++ b/utils/check-exact/Main.hs
@@ -79,7 +79,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_b
-- "../../testsuite/tests/ghc-api/exactprint/RmTypeSig2.hs" (Just rmTypeSig2)
-- "../../testsuite/tests/ghc-api/exactprint/AddHiding1.hs" (Just addHiding1)
-- "../../testsuite/tests/ghc-api/exactprint/AddHiding2.hs" (Just addHiding2)
- -- "../../testsuite/tests/printer/Ppr001.hs" Nothing
+ -- "../../testsuite/tests/ghc-api/exactprint/AddClassMethod.hs" (Just addClassMethod)
-- "../../testsuite/tests/ghc-api/annotations/CommentsTest.hs" Nothing
-- "../../testsuite/tests/hiefile/should_compile/Constructors.hs" Nothing
-- "../../testsuite/tests/hiefile/should_compile/Scopes.hs" Nothing
@@ -100,6 +100,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_b
-- "../../testsuite/tests/printer/Ppr008.hs" Nothing
-- "../../testsuite/tests/printer/Ppr009.hs" Nothing
-- "../../testsuite/tests/printer/Ppr011.hs" Nothing
+ -- "../../testsuite/tests/printer/Ppr011a.hs" Nothing
-- "../../testsuite/tests/printer/Ppr012.hs" Nothing
-- "../../testsuite/tests/printer/Ppr013.hs" Nothing
-- "../../testsuite/tests/printer/Ppr014.hs" Nothing
@@ -108,7 +109,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_b
-- "../../testsuite/tests/printer/Ppr017.hs" Nothing
-- "../../testsuite/tests/printer/Ppr018.hs" Nothing
-- "../../testsuite/tests/printer/Ppr019.hs" Nothing
- "../../testsuite/tests/printer/Ppr020.hs" Nothing
+ -- "../../testsuite/tests/printer/Ppr020.hs" Nothing
-- "../../testsuite/tests/printer/Ppr021.hs" Nothing
-- "../../testsuite/tests/printer/Ppr022.hs" Nothing
-- "../../testsuite/tests/printer/Ppr023.hs" Nothing
@@ -148,6 +149,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_b
-- "../../testsuite/tests/printer/PprRecordDotSyntax3.hs" Nothing
-- "../../testsuite/tests/printer/PprRecordDotSyntax4.hs" Nothing
-- "../../testsuite/tests/printer/PprRecordDotSyntaxA.hs" Nothing
+ -- "../../testsuite/tests/printer/PprUnicodeSyntax.hs" Nothing
-- "../../testsuite/tests/printer/StarBinderAnns.hs" Nothing
-- "../../testsuite/tests/printer/T13050p.hs" Nothing
-- "../../testsuite/tests/printer/T13199.hs" Nothing
@@ -203,7 +205,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_b
-- "../../testsuite/tests/ghc-api/exactprint/Test20239.hs" Nothing
-- "../../testsuite/tests/printer/PprArrowLambdaCase.hs" Nothing
-- "../../testsuite/tests/printer/Test16279.hs" Nothing
- -- "../../testsuite/tests/printer/HsDocTy.hs" Nothing
+ "../../testsuite/tests/printer/HsDocTy.hs" Nothing
-- "../../testsuite/tests/printer/Test22765.hs" Nothing
-- "../../testsuite/tests/printer/Test22771.hs" Nothing
-- "../../testsuite/tests/printer/Test23465.hs" Nothing
@@ -292,7 +294,6 @@ writeBinFile fpath x = withBinaryFile fpath WriteMode (\h -> hSetEncoding h utf8
testOneFile :: [(String, Changer)] -> FilePath -> String -> Maybe Changer -> IO ()
testOneFile _ libdir fileName mchanger = do
(p,_toks) <- parseOneFile libdir fileName
- -- putStrLn $ "\n\ngot p" ++ showAst (take 4 $ reverse _toks)
let
origAst = ppAst p
pped = exactPrint p
@@ -381,9 +382,6 @@ type Changer = FilePath -> (ParsedSource -> IO ParsedSource)
noChange :: Changer
noChange _libdir parsed = return parsed
--- changeDeltaAst :: Changer
--- changeDeltaAst _libdir parsed = return (makeDeltaAst parsed)
-
changeRenameCase1 :: Changer
changeRenameCase1 _libdir parsed = return (rename "bazLonger" [((3,15),(3,18))] parsed)
@@ -414,7 +412,7 @@ changeRename2 _libdir parsed = return (rename "joe" [((2,1),(2,5))] parsed)
rename :: (Data a, ExactPrint a) => String -> [(Pos, Pos)] -> a -> a
rename newNameStr spans' a
- = everywhere (mkT replaceRdr) (makeDeltaAst a)
+ = everywhere (mkT replaceRdr) a
where
newName = mkRdrUnqual (mkVarOcc newNameStr)
@@ -430,7 +428,7 @@ rename newNameStr spans' a
changeWhereIn4 :: Changer
changeWhereIn4 _libdir parsed
- = return (everywhere (mkT replace) (makeDeltaAst parsed))
+ = return (everywhere (mkT replace) parsed)
where
replace :: LocatedN RdrName -> LocatedN RdrName
replace (L ln _n)
@@ -450,7 +448,7 @@ changeLetIn1 _libdir parsed
[l2,_l1] = map wrapDecl $ bagToList bagDecls
bagDecls' = listToBag $ concatMap decl2Bind [l2]
(L (SrcSpanAnn _ le) e) = expr
- a = (SrcSpanAnn (EpAnn (Anchor (realSrcSpan le) (MovedAnchor (SameLine 1))) noAnn emptyComments) le)
+ a = (SrcSpanAnn (EpAnn (Anchor (realSrcSpan le) (MovedAnchor (SameLine 1) [])) noAnn emptyComments) le)
expr' = L a e
tkIn' = L (TokenLoc (EpaDelta (DifferentLine 1 0) [])) HsTok
in (HsLet an tkLet
@@ -480,7 +478,7 @@ changeAddDecl2 libdir top = do
let decl' = setEntryDP (makeDeltaAst decl) (DifferentLine 2 0)
let (p',_,_) = runTransform doAddDecl
- doAddDecl = everywhereM (mkM replaceTopLevelDecls) (makeDeltaAst top)
+ doAddDecl = everywhereM (mkM replaceTopLevelDecls) top
replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource
replaceTopLevelDecls m = insertAtEnd m decl'
return p'
@@ -524,11 +522,12 @@ changeLocalDecls libdir (L l p) = do
os' = setEntryDP os (DifferentLine 2 0)
let sortKey = captureOrderBinds decls
let (EpAnn anc (AnnList (Just (Anchor anc2 _)) a b c dd) cs) = van
- let van' = (EpAnn anc (AnnList (Just (Anchor anc2 (MovedAnchor (DifferentLine 1 4)))) a b c dd) cs)
+ let van' = (EpAnn anc (AnnList (Just (Anchor anc2 (MovedAnchor (DifferentLine 1 5) []))) a b c dd) cs)
let binds' = (HsValBinds van'
(ValBinds sortKey (listToBag $ decl':oldBinds)
(sig':os':oldSigs)))
return (L lm (Match an mln pats (GRHSs emptyComments rhs binds')))
+ `debug` ("oldDecls=" ++ showAst oldDecls)
replaceLocalBinds x = return x
return (L l p')
@@ -548,8 +547,8 @@ changeLocalDecls2 libdir (L l p) = do
-> Transform (LMatch GhcPs (LHsExpr GhcPs))
replaceLocalBinds (L lm (Match ma mln pats (GRHSs _ rhs EmptyLocalBinds{}))) = do
newSpan <- uniqueSrcSpanT
- let anc = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 2)))
- let anc2 = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 4)))
+ let anc = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 3) []))
+ let anc2 = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 5) []))
let an = EpAnn anc
(AnnList (Just anc2) Nothing Nothing
[AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])] [])
@@ -596,7 +595,7 @@ addLocaLDecl1 libdir top = do
Right (L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
let decl' = setEntryDP (L ld decl) (DifferentLine 1 5)
doAddLocal = do
- let lp = makeDeltaAst top
+ let lp = top
(de1:d2:d3:_) <- hsDecls lp
(de1'',d2') <- balanceComments de1 d2
(de1',_) <- modifyValD (getLocA de1'') de1'' $ \_m d -> do
@@ -635,7 +634,7 @@ addLocaLDecl3 libdir top = do
Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
let
doAddLocal = do
- let lp = makeDeltaAst top
+ let lp = top
(de1:d2:_) <- hsDecls lp
(de1'',d2') <- balanceComments de1 d2
@@ -720,9 +719,10 @@ addLocaLDecl6 libdir lp = do
rmDecl1 :: Changer
rmDecl1 _libdir top = do
let doRmDecl = do
- let lp = makeDeltaAst top
+ let lp = top
tlDecs0 <- hsDecls lp
- tlDecs <- balanceCommentsList $ captureLineSpacing tlDecs0
+ tlDecs' <- balanceCommentsList tlDecs0
+ let tlDecs = captureLineSpacing tlDecs'
let (de1:_s1:_d2:d3:ds) = tlDecs
let d3' = setEntryDP d3 (DifferentLine 2 0)
@@ -823,7 +823,8 @@ rmDecl6 _libdir lp = do
[de1] <- hsDecls lp
(de1',_) <- modifyValD (getLocA de1) de1 $ \_m subDecs -> do
- let (ss1:_sd1:sd2:sds) = subDecs
+ let subDecs' = captureLineSpacing subDecs
+ let (ss1:_sd1:sd2:sds) = subDecs'
sd2' <- transferEntryDP' ss1 sd2
return (sd2':sds,Nothing)
@@ -840,7 +841,7 @@ rmDecl7 :: Changer
rmDecl7 _libdir top = do
let
doRmDecl = do
- let lp = makeDeltaAst top
+ let lp = top
tlDecs <- hsDecls lp
[s1,de1,d2,d3] <- balanceCommentsList tlDecs
@@ -861,8 +862,8 @@ rmTypeSig1 _libdir lp = do
let (s0:de1:d2) = tlDecs
s1 = captureTypeSigSpacing s0
(L l (SigD x1 (TypeSig x2 [n1,n2] typ))) = s1
- n2' <- transferEntryDP n1 n2
- let s1' = (L l (SigD x1 (TypeSig x2 [n2'] typ)))
+ L ln n2' <- transferEntryDP n1 n2
+ let s1' = (L l (SigD x1 (TypeSig x2 [L (noTrailingN ln) n2'] typ)))
replaceDecls lp (s1':de1:d2)
let (lp',_,_w) = runTransform doRmDecl
@@ -878,8 +879,9 @@ rmTypeSig2 _libdir lp = do
let [de1] = tlDecs
(de1',_) <- modifyValD (getLocA de1) de1 $ \_m [s,d] -> do
- d' <- transferEntryDP s d
- return ([d'],Nothing)
+ d' <- transferEntryDP' s d
+ return $ ([d'],Nothing)
+ `debug` ("rmTypeSig2:(d,d')" ++ showAst (d,d'))
replaceDecls lp [de1']
let (lp',_,_w) = runTransform doRmDecl
@@ -908,7 +910,8 @@ addHiding1 _libdir (L l p) = do
[])
emptyComments) l0) [v1,v2]
imp1' = imp1 { ideclImportList = Just (EverythingBut,impHiding)}
- p' = p { hsmodImports = [L li imp1',imp2]}
+ imp2' = setEntryDP imp2 (DifferentLine 2 0)
+ p' = p { hsmodImports = [L li imp1',imp2']}
return (L l p')
let (lp',_,_w) = runTransform doTransform
@@ -920,7 +923,7 @@ addHiding1 _libdir (L l p) = do
addHiding2 :: Changer
addHiding2 _libdir top = do
let doTransform = do
- let (L l p) = makeDeltaAst top
+ let (L l p) = top
l1 <- uniqueSrcSpanT
l2 <- uniqueSrcSpanT
let
@@ -953,12 +956,12 @@ addClassMethod :: Changer
addClassMethod libdir lp = do
Right sig <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int")
Right decl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
- let decl' = setEntryDP decl (DifferentLine 1 2)
- let sig' = setEntryDP sig (DifferentLine 2 2)
+ let decl' = setEntryDP decl (DifferentLine 1 3)
+ let sig' = setEntryDP sig (DifferentLine 2 3)
let doAddMethod = do
[cd] <- hsDecls lp
(f1:f2s:f2d:_) <- hsDecls cd
- let f2s' = setEntryDP f2s (DifferentLine 2 2)
+ let f2s' = setEntryDP f2s (DifferentLine 2 3)
cd' <- replaceDecls cd [f1, sig', decl', f2s', f2d]
replaceDecls lp [cd']
diff --git a/utils/check-exact/Preprocess.hs b/utils/check-exact/Preprocess.hs
index 87df87b1c2ca..6f1dd37f57cd 100644
--- a/utils/check-exact/Preprocess.hs
+++ b/utils/check-exact/Preprocess.hs
@@ -77,7 +77,6 @@ checkLine line s
ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (size+1))
in (res, Just $ mkLEpaComment pragma (GHC.spanAsAnchor ss) (GHC.realSrcSpan ss))
-- Deal with shebang/cpp directives too
- -- x | "#" `isPrefixOf` s = ("",Just $ Comment ((line, 1), (line, length s)) s)
| "#!" `isPrefixOf` s =
let mSrcLoc = mkSrcLoc (mkFastString "SHEBANG")
ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (length s))
@@ -129,7 +128,6 @@ goodComment c = isGoodComment (tokComment c)
isGoodComment [Comment "" _ _ _] = False
isGoodComment _ = True
-
toRealLocated :: GHC.Located a -> GHC.RealLocated a
toRealLocated (GHC.L (GHC.RealSrcSpan s _) x) = GHC.L s x
toRealLocated (GHC.L _ x) = GHC.L badRealSrcSpan x
@@ -281,12 +279,7 @@ makeBufSpan ss = pspan
-- ---------------------------------------------------------------------
parseError :: (GHC.MonadIO m) => GHC.PState -> m b
-parseError pst = do
- let
- -- (warns,errs) = GHC.getMessages pst dflags
- -- throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err)
- -- GHC.throwErrors (fmap GHC.mkParserErr (GHC.getErrorMessages pst))
- GHC.throwErrors (fmap GHC.GhcPsMessage (GHC.getPsErrorMessages pst))
+parseError pst = GHC.throwErrors (fmap GHC.GhcPsMessage (GHC.getPsErrorMessages pst))
-- ---------------------------------------------------------------------
diff --git a/utils/check-exact/Transform.hs b/utils/check-exact/Transform.hs
index b877d1eda2e8..045b585763fd 100644
--- a/utils/check-exact/Transform.hs
+++ b/utils/check-exact/Transform.hs
@@ -77,7 +77,7 @@ module Transform
, isUniqueSrcSpan
-- * Pure functions
- , setEntryDP
+ , setEntryDP, setEntryDPDecl
, getEntryDP
, transferEntryDP
, transferEntryDP'
@@ -191,15 +191,23 @@ captureMatchLineSpacing (L l (ValD x (FunBind a b (MG c (L d ms )))))
ms' = captureLineSpacing ms
captureMatchLineSpacing d = d
-captureLineSpacing :: NoAnn t
- => [LocatedAn t e] -> [LocatedAn t e]
+captureLineSpacing :: [LocatedA e] -> [LocatedA e]
captureLineSpacing [] = []
captureLineSpacing [d] = [d]
-captureLineSpacing (de1:d2:ds) = de1:captureLineSpacing (d2':ds)
+captureLineSpacing ds = map (\(_,_,x) -> x) $ go (map to ds)
where
- (l1,_) = ss2pos $ rs $ getLocA de1
- (l2,_) = ss2pos $ rs $ getLocA d2
- d2' = setEntryDP d2 (deltaPos (l2-l1) 0)
+ to :: LocatedA e -> (Int, Int, LocatedA e)
+ to d = (fst $ ss2pos rss, fst $ ss2posEnd rss,d)
+ where
+ rss = rs $ getHasLoc d
+
+ go :: [(Int, Int, LocatedA e)] -> [(Int, Int, LocatedA e)]
+ go [] = []
+ go [d] = [d]
+ go ((ls1,le1,de1):(ls2,le2,d2):ds0) = (ls1,le1,de1):go ((ls2,le2,d2'):ds0)
+ `debug` ("captureLineSpacing: (le1,ls2,getLoc d2,getLoc d2')=" ++ showAst (le1,ls2,getLoc d2,getLoc d2'))
+ where
+ d2' = setEntryDP d2 (deltaPos (ls2-le1) 0)
-- ---------------------------------------------------------------------
@@ -224,16 +232,16 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc rs') cs) ns (H
(L (SrcSpanAnn EpAnnNotUsed ll) b)
-> let
op = case dca of
- EpaSpan r _ -> MovedAnchor (ss2delta (ss2posEnd r) (realSrcSpan ll))
- EpaDelta _ _ -> MovedAnchor (SameLine 1)
+ EpaSpan r _ -> MovedAnchor (ss2delta (ss2posEnd r) (realSrcSpan ll)) []
+ EpaDelta _ cs0 -> MovedAnchor (SameLine 1) cs0
in (L (SrcSpanAnn (EpAnn (Anchor (realSrcSpan ll) op) noAnn emptyComments) ll) b)
(L (SrcSpanAnn (EpAnn (Anchor r op) a c) ll) b)
-> let
op' = case op of
- MovedAnchor _ -> op
+ MovedAnchor _ _ -> op
_ -> case dca of
- EpaSpan dcr _ -> MovedAnchor (ss2delta (ss2posEnd dcr) r)
- EpaDelta _ _ -> MovedAnchor (SameLine 1)
+ EpaSpan _ _ -> MovedAnchor (SameLine 1) []
+ EpaDelta _ cs0 -> MovedAnchor (SameLine 1) cs0
in (L (SrcSpanAnn (EpAnn (Anchor r op') a c) ll) b)
captureTypeSigSpacing s = s
@@ -258,45 +266,59 @@ setEntryDPDecl d dp = setEntryDP d dp
setEntryDP :: NoAnn t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP (L (SrcSpanAnn EpAnnNotUsed l) a) dp
= L (SrcSpanAnn
- (EpAnn (Anchor (realSrcSpan l) (MovedAnchor dp)) noAnn emptyComments)
+ (EpAnn (Anchor (realSrcSpan l) (MovedAnchor dp [])) noAnn emptyComments)
l) a
-setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r _) an (EpaComments [])) l) a) dp
+setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r UnchangedAnchor) an (EpaComments [])) l) a) dp
= L (SrcSpanAnn
- (EpAnn (Anchor r (MovedAnchor dp)) an (EpaComments []))
+ (EpAnn (Anchor r (MovedAnchor dp [])) an (EpaComments []))
l) a
-setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r (MovedAnchor d)) an cs) l) a) dp
+setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r (MovedAnchor d csd)) an cs) l) a) dp
= L (SrcSpanAnn
- (EpAnn (Anchor r (MovedAnchor d')) an cs')
+ (EpAnn (Anchor r (MovedAnchor d' csd')) an cs')
l) a
where
- (d',cs') = case cs of
+ (d', csd', cs') = case cs of
EpaComments (h:t) ->
let
(dp0,c') = go h
in
- (dp0, EpaComments (c':t))
+ (dp0, c':t++csd, EpaComments [])
+ EpaComments [] ->
+ (dp, csd, cs)
EpaCommentsBalanced (h:t) ts ->
let
(dp0,c') = go h
in
- (dp0, EpaCommentsBalanced (c':t) ts)
- _ -> (dp, cs)
- go (L (Anchor rr (MovedAnchor ma)) c) = (d, L (Anchor rr (MovedAnchor ma)) c)
- go (L (Anchor rr _) c) = (d, L (Anchor rr (MovedAnchor dp)) c)
-setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r _) an cs) l) a) dp
+ (dp0, c':t++csd, EpaCommentsBalanced [] ts)
+ EpaCommentsBalanced [] ts ->
+ case csd of
+ [] -> (d, csd, EpaCommentsBalanced [] ts)
+ (h:t) ->
+ let
+ (dp0,c') = go h
+ in
+ (dp0, c':t, EpaCommentsBalanced [] ts)
+ go (L (Anchor rr (MovedAnchor _ c0)) c) = (d, L (Anchor rr (MovedAnchor dp c0)) c)
+ go (L (Anchor rr _) c) = (d, L (Anchor rr (MovedAnchor dp [])) c)
+setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r UnchangedAnchor) an cs) l) a) dp
= case sortEpaComments (priorComments cs) of
[] ->
L (SrcSpanAnn
- (EpAnn (Anchor r (MovedAnchor dp)) an cs)
+ (EpAnn (Anchor r (MovedAnchor dp [])) an cs)
l) a
(L ca c:cs') ->
L (SrcSpanAnn
- (EpAnn (Anchor r (MovedAnchor edp)) an cs'')
+ (EpAnn (Anchor r (MovedAnchor edp csd)) an cs'')
l) a
where
- cs'' = setPriorComments cs (L (Anchor (anchor ca) (MovedAnchor dp)) c:cs')
- lc = last $ (L ca c:cs')
- delta = tweakDelta $ ss2delta (ss2pos $ anchor $ getLoc lc) r
+ cs'' = setPriorComments cs []
+ csd = L (Anchor (anchor ca) (MovedAnchor dp [])) c:cs'
+ lc = case reverse $ (L ca c:cs') of
+ ll:_ -> ll
+ _ -> error "setEntryDP"
+ delta = case getLoc lc of
+ Anchor rr UnchangedAnchor -> ss2delta (ss2pos rr) r
+ Anchor _ (MovedAnchor _dp _) -> DifferentLine 1 0
line = getDeltaLine delta
col = deltaColumn delta
edp' = if line == 0 then SameLine col
@@ -307,7 +329,7 @@ setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r _) an cs) l) a) dp
-- ---------------------------------------------------------------------
getEntryDP :: LocatedAn t a -> DeltaPos
-getEntryDP (L (SrcSpanAnn (EpAnn (Anchor _ (MovedAnchor dp)) _ _) _) _) = dp
+getEntryDP (L (SrcSpanAnn (EpAnn (Anchor _ (MovedAnchor dp _)) _ _) _) _) = dp
getEntryDP _ = SameLine 1
-- ---------------------------------------------------------------------
@@ -322,10 +344,10 @@ setEntryDPFromAnchor :: LayoutStartCol -> EpaLocation -> LocatedA t -> LocatedA
setEntryDPFromAnchor _off (EpaDelta _ _) (L la a) = L la a
setEntryDPFromAnchor off (EpaSpan anc _) ll@(L la _) = setEntryDP ll dp'
where
- r = case la of
- (SrcSpanAnn EpAnnNotUsed l) -> realSrcSpan l
- (SrcSpanAnn (EpAnn (Anchor r' _) _ _) _) -> r'
- dp' = adjustDeltaForOffset off (ss2deltaEnd anc r)
+ dp' = case la of
+ (SrcSpanAnn EpAnnNotUsed l) -> adjustDeltaForOffset off (ss2deltaEnd anc (realSrcSpan l))
+ (SrcSpanAnn (EpAnn (Anchor r' UnchangedAnchor) _ _) _) -> adjustDeltaForOffset off (ss2deltaEnd anc r')
+ (SrcSpanAnn (EpAnn (Anchor _ (MovedAnchor dp _)) _ _) _) -> adjustDeltaForOffset off dp
-- ---------------------------------------------------------------------
@@ -354,7 +376,8 @@ transferEntryDP (L (SrcSpanAnn EpAnnNotUsed _l1) _) (L (SrcSpanAnn (EpAnn anc2 a
return (L (SrcSpanAnn (EpAnn anc2' an2 cs2) l2) b)
where
anc2' = case anc2 of
- Anchor _a op -> Anchor (realSrcSpan l2) op
+ Anchor _ (MovedAnchor _ _) -> anc2
+ Anchor _a UnchangedAnchor -> Anchor (realSrcSpan l2) UnchangedAnchor
-- |If a and b are the same type return first arg, else return second
@@ -384,14 +407,11 @@ pushDeclDP d _dp = d
-- ---------------------------------------------------------------------
balanceCommentsList :: (Monad m) => [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
-balanceCommentsList ds = balanceCommentsList'' ds
-
-balanceCommentsList'' :: (Monad m) => [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
-balanceCommentsList'' [] = return []
-balanceCommentsList'' [x] = return [x]
-balanceCommentsList'' (a:b:ls) = do
+balanceCommentsList [] = return []
+balanceCommentsList [x] = return [x]
+balanceCommentsList (a:b:ls) = do
(a',b') <- balanceComments a b
- r <- balanceCommentsList'' (b':ls)
+ r <- balanceCommentsList (b':ls)
return (a':r)
-- |The GHC parser puts all comments appearing between the end of one AST
@@ -416,22 +436,33 @@ balanceComments first second = do
balanceCommentsFB :: (Monad m)
=> LHsBind GhcPs -> LocatedA b -> TransformT m (LHsBind GhcPs, LocatedA b)
balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)))) second = do
- logTr $ "balanceCommentsFB entered: " ++ showGhc (ss2range $ locA lf)
+ debugM $ "balanceCommentsFB entered: " ++ showGhc (ss2range $ locA lf)
-- There are comments on lf. We need to
-- + Keep the prior ones here
-- + move the interior ones to the first match,
-- + move the trailing ones to the last match.
let
- split = splitCommentsEnd (realSrcSpan $ locA lf) (epAnnComments $ ann lf)
- split2 = splitCommentsStart (realSrcSpan $ locA lf) (EpaComments (sortEpaComments $ priorComments split))
-
- before = sortEpaComments $ priorComments split2
- middle = sortEpaComments $ getFollowingComments split2
- after = sortEpaComments $ getFollowingComments split
-
+ (before,middle,after) = case s_entry lf of
+ EpaSpan ss _ ->
+ let
+ split = splitCommentsEnd ss (s_comments lf)
+ split2 = splitCommentsStart ss (EpaComments (sortEpaComments $ priorComments split))
+
+ before0 = sortEpaComments $ priorComments split2
+ middle0 = sortEpaComments $ getFollowingComments split2
+ after0 = sortEpaComments $ getFollowingComments split
+ in (before0,middle0,after0)
+ _ -> (priorComments $ s_comments lf,
+ [],
+ getFollowingComments $ s_comments lf)
+
+ -- lf' = setCommentsEpAnnS lf (EpaComments before)
lf' = setCommentsSrcAnn lf (EpaComments before)
- logTr $ "balanceCommentsFB (before, after): " ++ showAst (before, after)
- let matches' = case matches of
+ debugM $ "balanceCommentsFB (before, after): " ++ showAst (before, after)
+ debugM $ "balanceCommentsFB lf': " ++ showAst lf'
+ -- let matches' = case matches of
+ let matches' :: [LocatedA (Match GhcPs (LHsExpr GhcPs))]
+ matches' = case matches of
(L lm' m':ms') ->
(L (addCommentsToSrcAnn lm' (EpaComments middle )) m':ms')
_ -> error "balanceCommentsFB"
@@ -439,14 +470,18 @@ balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)))) second = do
let (m,ms) = case reverse matches'' of
(L lm' m':ms') ->
(L (addCommentsToSrcAnn lm' (EpaCommentsBalanced [] after)) m',ms')
- _ -> error "balanceCommentsFB"
+ _ -> error "balanceCommentsFB4"
+ debugM $ "balanceCommentsFB: (m,ms):" ++ showAst (m,ms)
(m',second') <- balanceComments' m second
m'' <- balanceCommentsMatch m'
let (m''',lf'') = case ms of
[] -> moveLeadingComments m'' lf'
_ -> (m'',lf')
- logTr $ "balanceCommentsMatch done"
- balanceComments' (L lf'' (FunBind x n (MG o (L lm (reverse (m''':ms)))))) second'
+ debugM $ "balanceCommentsFB: (lf'', m'''):" ++ showAst (lf'',m''')
+ debugM $ "balanceCommentsFB done"
+ let bind = L lf'' (FunBind x n (MG o (L lm (reverse (m''':ms)))))
+ debugM $ "balanceCommentsFB returning:" ++ showAst bind
+ balanceComments' (packFunBind bind) second'
balanceCommentsFB f s = balanceComments' f s
-- | Move comments on the same line as the end of the match into the
@@ -458,17 +493,17 @@ balanceCommentsMatch (L l (Match am mctxt pats (GRHSs xg grhss binds))) = do
return (L l'' (Match am mctxt pats (GRHSs xg grhss' binds')))
where
simpleBreak (r,_) = r /= 0
- (SrcSpanAnn an1 _loc1) = l
- anc1 = addCommentOrigDeltas $ epAnnComments an1
+ an1 = l
+ anc1 = s_comments an1
cs1f = getFollowingComments anc1
(move',stay') = break simpleBreak (trailingCommentsDeltas (anchorFromLocatedA (L l ())) cs1f)
move = map snd move'
stay = map snd stay'
(l'', grhss', binds', logInfo)
= case reverse grhss of
- [] -> (l, [], binds, (EpaComments [], SrcSpanAnn EpAnnNotUsed noSrcSpan))
+ [] -> (l, [], binds, (EpaComments [], noSrcSpanA))
(L lg g@(GRHS EpAnnNotUsed _grs _rhs):gs)
- -> (l, reverse (L lg g:gs), binds, (EpaComments [], SrcSpanAnn EpAnnNotUsed noSrcSpan))
+ -> (l, reverse (L lg g:gs), binds, (EpaComments [], noSrcSpanA))
(L lg (GRHS ag grs rhs):gs) ->
let
anc1' = setFollowingComments anc1 stay
@@ -479,11 +514,10 @@ balanceCommentsMatch (L l (Match am mctxt pats (GRHSs xg grhss binds))) = do
-- ---------------------------------
(EpAnn anc an lgc) = ag
- lgc' = splitCommentsEnd (realSrcSpan $ locA lg) $ addCommentOrigDeltas lgc
+ lgc' = splitCommentsEnd (realSrcSpan $ locA lg) lgc
ag' = if moved
then EpAnn anc an lgc'
else EpAnn anc an (lgc' <> (EpaCommentsBalanced [] move))
- -- ag' = EpAnn anc an lgc'
in (an1', (reverse $ (L lg (GRHS ag' grs rhs):gs)), bindsm, (anc1',an1'))
@@ -519,18 +553,17 @@ balanceCommentsList' (a:b:ls) = do
-- Many of these should in fact be following comments for the previous anchor
balanceComments' :: (Monad m) => LocatedA a -> LocatedA b -> TransformT m (LocatedA a, LocatedA b)
balanceComments' la1 la2 = do
- logTr $ "balanceComments': (loc1,loc2)=" ++ showGhc (ss2range loc1,ss2range loc2)
- logTr $ "balanceComments': (anc1)=" ++ showAst (anc1)
- logTr $ "balanceComments': (cs1s)=" ++ showAst (cs1s)
- logTr $ "balanceComments': (cs1stay,cs1move)=" ++ showAst (cs1stay,cs1move)
- logTr $ "balanceComments': (an1',an2')=" ++ showAst (an1',an2')
+ debugM $ "balanceComments': (anc1)=" ++ showAst (anc1)
+ debugM $ "balanceComments': (cs1s)=" ++ showAst (cs1s)
+ debugM $ "balanceComments': (cs1stay,cs1move)=" ++ showAst (cs1stay,cs1move)
+ debugM $ "balanceComments': (an1',an2')=" ++ showAst (an1',an2')
return (la1', la2')
where
simpleBreak n (r,_) = r > n
- L (SrcSpanAnn an1 loc1) f = la1
- L (SrcSpanAnn an2 loc2) s = la2
- anc1 = addCommentOrigDeltas $ epAnnComments an1
- anc2 = addCommentOrigDeltas $ epAnnComments an2
+ L an1 f = la1
+ L an2 s = la2
+ anc1 = s_comments an1
+ anc2 = s_comments an2
cs1s = splitCommentsEnd (anchorFromLocatedA la1) anc1
cs1p = priorCommentsDeltas (anchorFromLocatedA la1) (priorComments cs1s)
@@ -559,27 +592,30 @@ balanceComments' la1 la2 = do
trailingCommentsDeltas :: RealSrcSpan -> [LEpaComment]
-> [(Int, LEpaComment)]
trailingCommentsDeltas _ [] = []
-trailingCommentsDeltas anc (la@(L l _):las)
- = deltaComment anc la : trailingCommentsDeltas (anchor l) las
+trailingCommentsDeltas r (la@(L (Anchor _ (MovedAnchor dp _)) _):las)
+ = (getDeltaLine dp, la): trailingCommentsDeltas r las
+trailingCommentsDeltas r (la@(L l _):las)
+ = deltaComment r la : trailingCommentsDeltas (anchor l) las
where
- deltaComment anc' (L loc c) = (abs(ll - al), L loc c)
+ deltaComment rs' (L loc c) = (abs(ll - al), L loc c)
where
- (al,_) = ss2posEnd anc'
+ (al,_) = ss2posEnd rs'
(ll,_) = ss2pos (anchor loc)
-- AZ:TODO: this is identical to commentsDeltas
priorCommentsDeltas :: RealSrcSpan -> [LEpaComment]
-> [(Int, LEpaComment)]
-priorCommentsDeltas anc cs = go anc (reverse $ sortEpaComments cs)
+priorCommentsDeltas r cs = go r (reverse $ sortEpaComments cs)
where
go :: RealSrcSpan -> [LEpaComment] -> [(Int, LEpaComment)]
go _ [] = []
- go anc' (la@(L l _):las) = deltaComment anc' la : go (anchor l) las
+ go _rs' (la@(L l@(Anchor _ (MovedAnchor dp _)) _):las) = (deltaLine dp, la) : go (anchor l) las
+ go rs' (la@(L l _):las) = deltaComment rs' la : go (anchor l) las
deltaComment :: RealSrcSpan -> LEpaComment -> (Int, LEpaComment)
- deltaComment anc' (L loc c) = (abs(ll - al), L loc c)
+ deltaComment rs' (L loc c) = (abs(ll - al), L loc c)
where
- (al,_) = ss2pos anc'
+ (al,_) = ss2pos rs'
(ll,_) = ss2pos (anchor loc)
@@ -590,14 +626,16 @@ priorCommentsDeltas anc cs = go anc (reverse $ sortEpaComments cs)
splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments
splitCommentsEnd p (EpaComments cs) = cs'
where
- cmp (L (Anchor l _) _) = ss2pos l > ss2posEnd p
+ cmp (L (Anchor l UnchangedAnchor) _) = ss2pos l > ss2posEnd p
+ cmp (L _ _) = True
(before, after) = break cmp cs
cs' = case after of
[] -> EpaComments cs
_ -> EpaCommentsBalanced before after
splitCommentsEnd p (EpaCommentsBalanced cs ts) = EpaCommentsBalanced cs' ts'
where
- cmp (L (Anchor l _) _) = ss2pos l > ss2posEnd p
+ cmp (L (Anchor l UnchangedAnchor) _) = ss2pos l > ss2posEnd p
+ cmp (L _ _) = True
(before, after) = break cmp cs
cs' = before
ts' = after <> ts
@@ -607,14 +645,16 @@ splitCommentsEnd p (EpaCommentsBalanced cs ts) = EpaCommentsBalanced cs' ts'
splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments
splitCommentsStart p (EpaComments cs) = cs'
where
- cmp (L (Anchor l _) _) = ss2pos l > ss2pos p
+ cmp (L (Anchor l UnchangedAnchor) _) = ss2pos l > ss2posEnd p
+ cmp (L _ _) = True
(before, after) = break cmp cs
cs' = case after of
[] -> EpaComments cs
_ -> EpaCommentsBalanced before after
splitCommentsStart p (EpaCommentsBalanced cs ts) = EpaCommentsBalanced cs' ts'
where
- cmp (L (Anchor l _) _) = ss2pos l > ss2pos p
+ cmp (L (Anchor l UnchangedAnchor) _) = ss2pos l > ss2posEnd p
+ cmp (L _ _) = True
(before, after) = break cmp cs
cs' = before
ts' = after <> ts
@@ -625,14 +665,14 @@ moveLeadingComments from@(L (SrcSpanAnn EpAnnNotUsed _) _) to = (from, to)
moveLeadingComments (L la a) lb = (L la' a, lb')
`debug` ("moveLeadingComments: (before, after, la', lb'):" ++ showAst (before, after, la', lb'))
where
- split = splitCommentsEnd (realSrcSpan $ locA la) (epAnnComments $ ann la)
+ split = splitCommentsEnd (realSrcSpan $ locA la) (s_comments la)
before = sortEpaComments $ priorComments split
after = sortEpaComments $ getFollowingComments split
-- TODO: need to set an entry delta on lb' to zero, and move the
-- original spacing to the first comment.
- la' = setCommentsSrcAnn la (EpaComments after)
+ la' = setCommentsSrcAnn la (EpaCommentsBalanced [] after)
lb' = addCommentsToSrcAnn lb (EpaCommentsBalanced before [])
-- | A GHC comment includes the span of the preceding (non-comment)
@@ -660,26 +700,6 @@ anchorFromLocatedA (L (SrcSpanAnn an loc) _)
EpAnnNotUsed -> realSrcSpan loc
(EpAnn anc _ _) -> anchor anc
--- | A GHC comment includes the span of the preceding token. Take an
--- original comment, and convert the 'Anchor to have a have a
--- `MovedAnchor` operation based on the original location, only if it
--- does not already have one.
-commentOrigDelta :: LEpaComment -> LEpaComment
-commentOrigDelta (L (GHC.Anchor la _) (GHC.EpaComment t pp))
- = (L (GHC.Anchor la op) (GHC.EpaComment t pp))
- `debug` ("commentOrigDelta: (la, pp, r,c, op)=" ++ showAst (la, pp, r,c, op))
- where
- (r,c) = ss2posEnd pp
-
- op' = if r == 0
- then MovedAnchor (ss2delta (r,c+1) la)
- -- then MovedAnchor (ss2delta (r,c+0) la)
- -- else MovedAnchor (ss2delta (r,c) la)
- else MovedAnchor (tweakDelta $ ss2delta (r,c) la)
- op = if t == EpaEofComment && op' == MovedAnchor (SameLine 0)
- then MovedAnchor (DifferentLine 1 0)
- else op'
-
-- ---------------------------------------------------------------------
balanceSameLineComments :: (Monad m)
@@ -695,8 +715,8 @@ balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) = do
(L lg g@(GRHS EpAnnNotUsed _gs _rhs):grs) -> (la,reverse $ (L lg g):grs,[])
(L lg (GRHS ga gs rhs):grs) -> (la'',reverse $ (L lg (GRHS ga' gs rhs)):grs,[(gac,(csp,csf))])
where
- (SrcSpanAnn an1 _loc1) = la
- anc1 = addCommentOrigDeltas $ epAnnComments an1
+ an1 = la
+ anc1 = s_comments an1
(EpAnn anc an _) = ga :: EpAnn GrhsAnn
(csp,csf) = case anc1 of
EpaComments cs -> ([],cs)
@@ -706,13 +726,12 @@ balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) = do
stay = map snd stay'
cs1 = EpaCommentsBalanced csp stay
- gac = addCommentOrigDeltas $ epAnnComments ga
+ gac = epAnnComments ga
gfc = getFollowingComments gac
gac' = setFollowingComments gac (sortEpaComments $ gfc ++ move)
ga' = (EpAnn anc an gac')
- an1' = setCommentsSrcAnn la cs1
- la'' = an1'
+ la'' = setCommentsSrcAnn la cs1
-- ---------------------------------------------------------------------
@@ -723,18 +742,11 @@ anchorEof (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l
-- ---------------------------------------------------------------------
-commentsOrigDeltasDecl :: LHsDecl GhcPs -> LHsDecl GhcPs
-commentsOrigDeltasDecl (L (SrcSpanAnn an l) d) = L (SrcSpanAnn an' l) d
- where
- an' = addCommentOrigDeltasAnn an
-
--- ---------------------------------------------------------------------
-
-- | Create a @SrcSpanAnn@ with a @MovedAnchor@ operation using the
-- given @DeltaPos@.
noAnnSrcSpanDP :: (NoAnn ann) => SrcSpan -> DeltaPos -> SrcSpanAnn' (EpAnn ann)
noAnnSrcSpanDP l dp
- = SrcSpanAnn (EpAnn (Anchor (realSrcSpan l) (MovedAnchor dp)) noAnn emptyComments) l
+ = SrcSpanAnn (EpAnn (Anchor (realSrcSpan l) (MovedAnchor dp [])) noAnn emptyComments) l
noAnnSrcSpanDP0 :: (NoAnn ann) => SrcSpan -> SrcSpanAnn' (EpAnn ann)
noAnnSrcSpanDP0 l = noAnnSrcSpanDP l (SameLine 0)
@@ -755,13 +767,13 @@ dn :: Int -> EpaLocation
dn n = EpaDelta (SameLine n) []
m0 :: AnchorOperation
-m0 = MovedAnchor $ SameLine 0
+m0 = MovedAnchor (SameLine 0) []
m1 :: AnchorOperation
-m1 = MovedAnchor $ SameLine 1
+m1 = MovedAnchor (SameLine 1) []
mn :: Int -> AnchorOperation
-mn n = MovedAnchor $ SameLine n
+mn n = MovedAnchor (SameLine n) []
addComma :: SrcSpanAnnA -> SrcSpanAnnA
addComma (SrcSpanAnn EpAnnNotUsed l)
@@ -783,7 +795,7 @@ insertAt :: (HasDecls ast)
insertAt f t decl = do
oldDecls <- hsDecls t
oldDeclsb <- balanceCommentsList oldDecls
- let oldDecls' = map commentsOrigDeltasDecl oldDeclsb
+ let oldDecls' = oldDeclsb
replaceDecls t (f decl oldDecls')
-- |Insert a declaration at the beginning or end of the subdecls of the given
@@ -793,9 +805,17 @@ insertAtStart, insertAtEnd :: (HasDecls ast)
-> LHsDecl GhcPs
-> Transform ast
-insertAtStart = insertAt (:)
insertAtEnd = insertAt (\x xs -> xs ++ [x])
+insertAtStart = insertAt insertFirst
+ where
+ insertFirst x xs =
+ case xs of
+ [] -> [x]
+ (h:t) -> x:setEntryDP h (DifferentLine 2 0):t
+ `debug` ("insertAtStart:h=" ++ showAst h)
+
+
-- |Insert a declaration at a specific location in the subdecls of the given
-- AST item
insertAfter, insertBefore :: (HasDecls (LocatedA ast))
@@ -810,8 +830,6 @@ insertAfter (getLocA -> k) = insertAt findAfter
([],[]) -> [x]
(fs,[]) -> fs++[x]
(fs, b:bs) -> fs ++ (b : x : bs)
- -- let (fs, b:bs) = span (\(L l _) -> locA l /= k) xs
- -- in fs ++ (b : x : bs)
insertBefore (getLocA -> k) = insertAt findBefore
where
findBefore x xs =
@@ -858,6 +876,7 @@ class (Data t) => HasDecls t where
instance HasDecls ParsedSource where
hsDecls (L _ (HsModule (XModulePs _ _lo _ _) _mn _exps _imps decls)) = return decls
+
replaceDecls (L l (HsModule (XModulePs a lo deps haddocks) mname exps imps _decls)) decls
= do
logTr "replaceDecls LHsModule"
@@ -926,7 +945,6 @@ instance HasDecls (LocatedA (HsExpr GhcPs)) where
newDecls'' = case newDecls of
[] -> newDecls
(d:ds) -> setEntryDPDecl d (SameLine 0) : ds
- -- in ( EpAnn a (AnnsLet l (addEpaLocationDelta off lastAnc i)) cs
in ( L (TokenLoc l) ls
, L (TokenLoc (addEpaLocationDelta off lastAnc i)) is
, ex''
@@ -1019,6 +1037,74 @@ instance HasDecls (LocatedA (Stmt GhcPs (LocatedA (HsExpr GhcPs)))) where
-- end of HasDecls instances
-- =====================================================================
+-- ---------------------------------------------------------------------
+-- A @FunBind@ is a container for @[LMatch GhcPs]@
+--
+-- When being used as a Bind (or Decl), the surrounding context
+-- annotations must appear at the FunBind level, so it can be
+-- manipulated in the context of other Binds or Decls.
+--
+-- Surrounding context annotations are specifically prior comments,
+-- following comments and trailing annotations.
+--
+-- But when we unpack the container, by calling @hsDecls@ on a
+-- @FunBind@, we must make sure that the component parts fully
+-- represent the relationship between them and the surrounding
+-- declarations.
+--
+-- This means pushing the prior context annotations into the first
+-- match, and the following ones into the last match when returning
+-- @hsDecls@, and undoing this for @replaceDecls@.
+
+-- |Push leading and trailing top level annotations into the @[LMatch GhcPs]@
+unpackFunBind :: LHsBind GhcPs -> LHsBind GhcPs
+unpackFunBind (L loc (FunBind x1 fid (MG x2 (L lg (L lm m:matches)))))
+ = (L loc'' (FunBind x1 fid (MG x2 (L lg (reverse (L llm' lmtch:ms))))))
+ -- `debug` ("unpackFunBind: ="
+ -- ++ showAst (("loc",loc), ("loc'",loc'), ("loc''",loc''),
+ -- ("lm'",lm'), ("llm",llm), ("llm'", llm')))
+ where
+ (loc', lm') = transferPriorCommentsA loc lm
+ matches' = reverse $ L lm' m:matches
+ (L llm lmtch, ms) = case matches' of
+ mm:ms0 -> (mm,ms0)
+ _ -> error "unpackFunBind"
+
+ (loc'', llm') = transferFollowingA loc' llm
+
+unpackFunBind d = d
+
+-- |Pull leading and trailing annotations from the @[LMatch GhcPs]@ to
+-- the top level.
+packFunBind :: LHsBind GhcPs -> LHsBind GhcPs
+packFunBind (L loc (FunBind x1 fid (MG x2 (L lg (L lm m:matches)))))
+ = (L loc'' (FunBind x1 fid (MG x2 (L lg (reverse (L llm' lmtch:ms))))))
+ -- `debug` ("packFunBind: ="
+ -- ++ showAst (("loc",loc), ("loc'",loc'), ("loc''",loc''),
+ -- ("lm'",lm'), ("llm",llm), ("llm'", llm')))
+ where
+ (lm', loc') = transferPriorCommentsA lm loc
+ matches' = reverse $ L lm' m:matches
+ (L llm lmtch, ms) = case matches' of
+ mm:ms0 -> (mm,ms0)
+ _ -> error "packFunBind"
+ (llm', loc'') = transferFollowingA llm loc'
+packFunBind d = d
+
+packFunDecl :: LHsDecl GhcPs -> LHsDecl GhcPs
+packFunDecl (L l (ValD x b)) = L l' (ValD x b')
+ where
+ L l' b' = packFunBind (L l b)
+packFunDecl x = x
+
+unpackFunDecl :: LHsDecl GhcPs -> LHsDecl GhcPs
+unpackFunDecl (L l (ValD x b)) = L l' (ValD x b')
+ where
+ L l' b' = unpackFunBind (L l b)
+unpackFunDecl x = x
+
+-- ---------------------------------------------------------------------
+
data WithWhere = WithWhere
| WithoutWhere
deriving (Eq,Show)
@@ -1061,10 +1147,10 @@ oldWhereAnnotation EpAnnNotUsed ww _oldSpan = do
let w = case ww of
WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])]
WithoutWhere -> []
- let anc2' = Anchor (rs newSpan) (MovedAnchor (SameLine 1))
+ let anc2' = Anchor (rs newSpan) (MovedAnchor (SameLine 1) [])
(anc, anc2) <- do
newSpan' <- uniqueSrcSpanT
- return ( Anchor (rs newSpan') (MovedAnchor (DifferentLine 1 2))
+ return ( Anchor (rs newSpan') (MovedAnchor (DifferentLine 1 2) [])
, anc2')
let an = EpAnn anc
(AnnList (Just anc2) Nothing Nothing w [])
@@ -1088,8 +1174,8 @@ oldWhereAnnotation (EpAnn anc an cs) ww _oldSpan = do
newWhereAnnotation :: (Monad m) => WithWhere -> TransformT m (EpAnn AnnList)
newWhereAnnotation ww = do
newSpan <- uniqueSrcSpanT
- let anc = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 2))
- let anc2 = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 4))
+ let anc = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 3) [])
+ let anc2 = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 5) [])
let w = case ww of
WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])]
WithoutWhere -> []
@@ -1120,15 +1206,16 @@ modifyValD p pb@(L ss (ValD _ (PatBind {} ))) f =
pb' <- liftT $ replaceDeclsPatBindD pb ds'
return (pb',r)
else return (pb,Nothing)
-modifyValD p ast f = do
- (ast',r) <- runStateT (everywhereM (mkM doModLocal) ast) Nothing
- return (ast',r)
+modifyValD p decl f = do
+ (decl',r) <- runStateT (everywhereM (mkM doModLocal) (unpackFunDecl decl)) Nothing
+ return (packFunDecl decl',r)
where
doModLocal :: PMatch -> StateT (Maybe t) m PMatch
doModLocal (match@(L ss _) :: PMatch) = do
if (locA ss) == p
then do
ds <- lift $ liftT $ hsDecls match
+ `debug` ("modifyValD: match=" ++ showAst match)
(ds',r) <- lift $ f match ds
put r
match' <- lift $ liftT $ replaceDecls match ds'
diff --git a/utils/check-exact/Utils.hs b/utils/check-exact/Utils.hs
index 6c22a939d7e8..5b868d71136a 100644
--- a/utils/check-exact/Utils.hs
+++ b/utils/check-exact/Utils.hs
@@ -110,6 +110,7 @@ pos2delta (refl,refc) (l,c) = deltaPos lo co
lo = l - refl
co = if lo == 0 then c - refc
else c
+ -- else c - 1
-- | Apply the delta to the current position, taking into account the
-- current column offset if advancing to a new line
@@ -166,6 +167,12 @@ badRealSrcSpan = mkRealSrcSpan bad bad
spanLength :: RealSrcSpan -> Int
spanLength = (-) <$> srcSpanEndCol <*> srcSpanStartCol
+
+-- | Useful for debug dumps
+eloc2str :: EpaLocation -> String
+eloc2str (EpaSpan r _) = "EpaSpan " ++ show (rs2range r)
+eloc2str epaLoc = show epaLoc
+
-- ---------------------------------------------------------------------
-- | Checks whether a SrcSpan has zero length.
isPointSrcSpan :: RealSrcSpan -> Bool
@@ -174,22 +181,23 @@ isPointSrcSpan ss = spanLength ss == 0
-- ---------------------------------------------------------------------
-origDelta :: RealSrcSpan -> RealSrcSpan -> DeltaPos
-origDelta pos pp = op
+-- | A GHC comment includes the span of the preceding token. Take an
+-- original comment, and convert the 'Anchor to have a have a
+-- `MovedAnchor` operation based on the original location, only if it
+-- does not already have one.
+commentOrigDelta :: LEpaComment -> LEpaComment
+commentOrigDelta (L (GHC.Anchor la _) (GHC.EpaComment t pp))
+ = (L (GHC.Anchor la op) (GHC.EpaComment t pp))
+ `debug` ("commentOrigDelta: (la, pp, r,c, op)=" ++ showAst (la, pp, r,c, op))
where
- (r,c) = ss2posEnd pp
+ (r,c) = ss2posEnd pp
- op = if r == 0
- then ( ss2delta (r,c+1) pos)
- else (tweakDelta $ ss2delta (r,c ) pos)
+ op = if r == 0
+ then MovedAnchor (ss2delta (r,c+1) la) []
+ else MovedAnchor (ss2delta (r,c) la) []
--- ---------------------------------------------------------------------
-
--- | For comment-related deltas starting on a new line we have an
--- off-by-one problem. Adjust
-tweakDelta :: DeltaPos -> DeltaPos
-tweakDelta (SameLine d) = SameLine d
-tweakDelta (DifferentLine l d) = DifferentLine l (d-1)
+origDelta :: RealSrcSpan -> RealSrcSpan -> DeltaPos
+origDelta pos pp = ss2delta (ss2posEnd pp) pos
-- ---------------------------------------------------------------------
@@ -222,9 +230,16 @@ insertCppComments :: ParsedSource -> [LEpaComment] -> ParsedSource
insertCppComments (L l p) cs = L l p'
where
an' = case GHC.hsmodAnn $ GHC.hsmodExt p of
- (EpAnn a an ocs) -> EpAnn a an (EpaComments cs')
+ (EpAnn a an ocs) -> EpAnn a an cs'
where
- cs' = sortEpaComments $ priorComments ocs ++ getFollowingComments ocs ++ cs
+ pc = priorComments ocs
+ fc = getFollowingComments ocs
+ cs' = case fc of
+ [] -> EpaComments $ sortEpaComments $ pc ++ fc ++ cs
+ (L ac _:_) -> EpaCommentsBalanced (sortEpaComments $ pc ++ cs_before)
+ (sortEpaComments $ fc ++ cs_after)
+ where
+ (cs_before,cs_after) = break (\(L l0 _) -> (ss2pos $ anchor l0) < (ss2pos $ anchor ac) ) cs
unused -> unused
p' = p { GHC.hsmodExt = (GHC.hsmodExt p) { GHC.hsmodAnn = an' } }
@@ -235,7 +250,6 @@ ghcCommentText (L _ (GHC.EpaComment (EpaDocComment s) _)) = exactPrintHsDoc
ghcCommentText (L _ (GHC.EpaComment (EpaDocOptions s) _)) = s
ghcCommentText (L _ (GHC.EpaComment (EpaLineComment s) _)) = s
ghcCommentText (L _ (GHC.EpaComment (EpaBlockComment s) _)) = s
-ghcCommentText (L _ (GHC.EpaComment (EpaEofComment) _)) = ""
tokComment :: LEpaComment -> [Comment]
tokComment t@(L lt c) =
@@ -289,7 +303,6 @@ comment2LEpaComment :: Comment -> LEpaComment
comment2LEpaComment (Comment s anc r _mk) = mkLEpaComment s anc r
mkLEpaComment :: String -> Anchor -> RealSrcSpan -> LEpaComment
-mkLEpaComment "" anc r = (L anc (GHC.EpaComment (EpaEofComment) r))
mkLEpaComment s anc r = (L anc (GHC.EpaComment (EpaLineComment s) r))
mkComment :: String -> Anchor -> RealSrcSpan -> Comment
@@ -319,8 +332,8 @@ sortEpaComments cs = sortBy cmp cs
mkKWComment :: AnnKeywordId -> EpaLocation -> Comment
mkKWComment kw (EpaSpan ss _)
= Comment (keywordToString kw) (Anchor ss UnchangedAnchor) ss (Just kw)
-mkKWComment kw (EpaDelta dp _)
- = Comment (keywordToString kw) (Anchor placeholderRealSpan (MovedAnchor dp)) placeholderRealSpan (Just kw)
+mkKWComment kw (EpaDelta dp cs)
+ = Comment (keywordToString kw) (Anchor placeholderRealSpan (MovedAnchor dp cs)) placeholderRealSpan (Just kw)
-- | Detects a comment which originates from a specific keyword.
isKWComment :: Comment -> Bool
@@ -366,49 +379,12 @@ name2String = showPprUnsafe
-- ---------------------------------------------------------------------
--- occAttributes :: OccName.OccName -> String
--- occAttributes o = "(" ++ ns ++ vo ++ tv ++ tc ++ d ++ ds ++ s ++ v ++ ")"
--- where
--- -- ns = (showSDocUnsafe $ OccName.pprNameSpaceBrief $ occNameSpace o) ++ ", "
--- ns = (showSDocUnsafe $ OccName.pprNameSpaceBrief $ occNameSpace o) ++ ", "
--- vo = if isVarOcc o then "Var " else ""
--- tv = if isTvOcc o then "Tv " else ""
--- tc = if isTcOcc o then "Tc " else ""
--- d = if isDataOcc o then "Data " else ""
--- ds = if isDataSymOcc o then "DataSym " else ""
--- s = if isSymOcc o then "Sym " else ""
--- v = if isValOcc o then "Val " else ""
-
- -- ---------------------------------------------------------------------
-
locatedAnAnchor :: LocatedAn a t -> RealSrcSpan
locatedAnAnchor (L (SrcSpanAnn EpAnnNotUsed l) _) = realSrcSpan l
locatedAnAnchor (L (SrcSpanAnn (EpAnn a _ _) _) _) = anchor a
-- ---------------------------------------------------------------------
-setAnchorAn :: (NoAnn an) => LocatedAn an a -> Anchor -> EpAnnComments -> LocatedAn an a
-setAnchorAn (L (SrcSpanAnn EpAnnNotUsed l) a) anc cs
- = (L (SrcSpanAnn (EpAnn anc noAnn cs) l) a)
- -- `debug` ("setAnchorAn: anc=" ++ showAst anc)
-setAnchorAn (L (SrcSpanAnn (EpAnn _ an _) l) a) anc cs
- = (L (SrcSpanAnn (EpAnn anc an cs) l) a)
- -- `debug` ("setAnchorAn: anc=" ++ showAst anc)
-
-setAnchorEpa :: (NoAnn an) => EpAnn an -> Anchor -> EpAnnComments -> EpAnn an
-setAnchorEpa EpAnnNotUsed anc cs = EpAnn anc noAnn cs
-setAnchorEpa (EpAnn _ an _) anc cs = EpAnn anc an cs
-
-setAnchorEpaL :: EpAnn AnnList -> Anchor -> EpAnnComments -> EpAnn AnnList
-setAnchorEpaL EpAnnNotUsed anc cs = EpAnn anc noAnn cs
-setAnchorEpaL (EpAnn _ an _) anc cs = EpAnn anc (an {al_anchor = Nothing}) cs
-
-setAnchorHsModule :: HsModule GhcPs -> Anchor -> EpAnnComments -> HsModule GhcPs
-setAnchorHsModule hsmod anc cs = hsmod { hsmodExt = (hsmodExt hsmod) {hsmodAnn = an'} }
- where
- anc' = anc { anchor_op = UnchangedAnchor }
- an' = setAnchorEpa (hsmodAnn $ hsmodExt hsmod) anc' cs
-
-- |Version of l2l that preserves the anchor, immportant if it has an
-- updated AnchorOperation
moveAnchor :: NoAnn b => SrcAnn a -> SrcAnn b
@@ -421,11 +397,15 @@ trailingAnnLoc :: TrailingAnn -> EpaLocation
trailingAnnLoc (AddSemiAnn ss) = ss
trailingAnnLoc (AddCommaAnn ss) = ss
trailingAnnLoc (AddVbarAnn ss) = ss
+trailingAnnLoc (AddDarrowAnn ss) = ss
+trailingAnnLoc (AddDarrowUAnn ss) = ss
setTrailingAnnLoc :: TrailingAnn -> EpaLocation -> TrailingAnn
setTrailingAnnLoc (AddSemiAnn _) ss = (AddSemiAnn ss)
setTrailingAnnLoc (AddCommaAnn _) ss = (AddCommaAnn ss)
setTrailingAnnLoc (AddVbarAnn _) ss = (AddVbarAnn ss)
+setTrailingAnnLoc (AddDarrowAnn _) ss = (AddDarrowAnn ss)
+setTrailingAnnLoc (AddDarrowUAnn _) ss = (AddDarrowUAnn ss)
addEpAnnLoc :: AddEpAnn -> EpaLocation
addEpAnnLoc (AddEpAnn _ l) = l
@@ -435,7 +415,7 @@ addEpAnnLoc (AddEpAnn _ l) = l
-- TODO: move this to GHC
anchorToEpaLocation :: Anchor -> EpaLocation
anchorToEpaLocation (Anchor r UnchangedAnchor) = EpaSpan r Strict.Nothing
-anchorToEpaLocation (Anchor _ (MovedAnchor dp)) = EpaDelta dp []
+anchorToEpaLocation (Anchor _ (MovedAnchor dp cs)) = EpaDelta dp cs
-- ---------------------------------------------------------------------
-- Horrible hack for dealing with some things still having a SrcSpan,
@@ -467,13 +447,13 @@ hackSrcSpanToAnchor (UnhelpfulSpan s) = error $ "hackSrcSpanToAnchor : Unhelpful
hackSrcSpanToAnchor (RealSrcSpan r Strict.Nothing) = Anchor r UnchangedAnchor
hackSrcSpanToAnchor (RealSrcSpan r (Strict.Just (BufSpan (BufPos s) (BufPos e))))
= if s <= 0 && e <= 0
- then Anchor r (MovedAnchor (deltaPos (-s) (-e)))
+ then Anchor r (MovedAnchor (deltaPos (-s) (-e)) [])
`debug` ("hackSrcSpanToAnchor: (r,s,e)=" ++ showAst (r,s,e) )
else Anchor r UnchangedAnchor
hackAnchorToSrcSpan :: Anchor -> SrcSpan
hackAnchorToSrcSpan (Anchor r UnchangedAnchor) = RealSrcSpan r Strict.Nothing
-hackAnchorToSrcSpan (Anchor r (MovedAnchor dp))
+hackAnchorToSrcSpan (Anchor r (MovedAnchor dp _cs))
= RealSrcSpan r (Strict.Just (BufSpan (BufPos s) (BufPos e)))
`debug` ("hackAnchorToSrcSpan: (r,dp,s,e)=" ++ showAst (r,dp,s,e) )
where
diff --git a/utils/haddock b/utils/haddock
index 7e97eb212291..b75ff8a88bbd 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit 7e97eb212291fca97b67466d4f603eafc5b7caa7
+Subproject commit b75ff8a88bbdd0d60032a4e304d37ec65526c06b
--
GitLab