diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index 3bbf6d82dddfae2c2ae9513c5106c41fd59357a6..d158f967847ba1df2cc970e974048635622c12ae 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 6f1d0d71a85d2ca914b85435a4ec0b61541933f4..efb5ffff7b9479c9bd4f3745355458715137ee5c 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 317daa36c5cdeb349bfb456c06d876113145e0a4..26a7ea1127fb83c8963f17ad35cfb7459664f8e5 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 d73dd07923b1fc6805f2671535f42405c8b3cb20..c082c493e459217d76110cdaa364ca38db48d700 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 f15bbec30c481e847258dc3340281a1f770fabfa..65ccdfff07fd66ea71cf233da8f43b7bf5715981 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 92aa77c0f547b004a677985b430c0073c82d0d3b..4abbec3647659ed2e5d8cc1765d1dac2caea02f7 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 01c41cd9d08ac84d70b50ad8f6a0af9242dbf891..f9f1e871cb8c6343ff915357c8812e0d7d463202 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 88ef0fdd7def14a4833f6886c02227cd8a9b10fb..5e2e71b874e84a4be079fa3e65a6fc6310b3bb00 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 bb84374f1e3217965c4ef578e51f44974ac3c895..877552eeac7ac61e1e724132f3c217cc911dbee8 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 869c7609ff001c1f8a7ef7153da4c91f2c637602..2b0581e55bf53750aa56168d1b6d4864748aefe9 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 6d8d524ef17e1b3ea2d330b2514afb62d211b957..76a25034163039bcb0d480b4e1adf83347daaee0 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 6389ffcc91bfb77d63c242b803c202cd685ec758..be08561529bcc29e84a7925dc09cce16e5395631 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 7b65432466d85a8b064342d9d32dc276e8561aaf..ea2a4172182da2ce6663f6b7e142c7d19aafa278 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 6ead4e3dceae94d9b01a98939da781aaafb908b0..2497f5ab94c54451599a997af1d146a5040b28d9 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 40dc650b73f37251c0efdb35445daad7833760d3..d047f37c72d5ce616285c591db83a4b691a8cedc 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 5fd2724f165014f6cb34b2704703e3857bcaeba1..431ae3845ae1a44d3ab1e20637674d2f24a1428e 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 9ec7d7748d940af5c2722145af25b5be67d26fc6..1da3125d2a3027d004e3dba85286ed57bbf1ce5b 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 a3bb2e7781723d85afb7a261e039fb972d77ffb1..77a5dff85ebf7b27b26394b3b72657c33f9227e3 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 4a1981b6e10a6b7308b7e8bce6c8c39200049cd1..a19f42be17a80e1d6945a3577cf25785d3862382 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 1cc94f80b84a3c926e0a7886f7e2890f8689cfae..4a4f2637d9bb8d8771c8e28eedc0dad3b025781c 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 d16f17af347bcedefdaed8ff6b8739ca90969a5e..add9eaf4fbd437ee78b214f62fe2adefd995f84b 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 6a44d89457c738dcafe2866e8a00c8e28c7a61cf..be550111cc5849be2674565165832975754d3c67 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 87df87b1c2caac897712eac96e2d949c1d0a18a5..6f1dd37f57cde8463f5f1f924d94f718610a701a 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 b877d1eda2e81f7aa2d55107f34718686fd0634c..045b585763fdeba3ce363ffe6e3795dc0442fbc7 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 6c22a939d7e861027ebab10fb8dfe6e9951a5d86..5b868d71136a25119357c6a4c5457a32d9e24e78 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 7e97eb212291fca97b67466d4f603eafc5b7caa7..b75ff8a88bbdd0d60032a4e304d37ec65526c06b 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit 7e97eb212291fca97b67466d4f603eafc5b7caa7
+Subproject commit b75ff8a88bbdd0d60032a4e304d37ec65526c06b