diff --git a/compiler/GHC/Hs/Dump.hs b/compiler/GHC/Hs/Dump.hs index 245a1cd43e41be8bd2d0395ce42652044a54255a..28b784e175253c30a26a570cd91518566f4254ae 100644 --- a/compiler/GHC/Hs/Dump.hs +++ b/compiler/GHC/Hs/Dump.hs @@ -144,7 +144,7 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 _ -> parens $ text "SourceText" <+> text "blanked" epaAnchor :: EpaLocation -> SDoc - epaAnchor (EpaSpan r _) = parens $ text "EpaSpan" <+> realSrcSpan r + epaAnchor (EpaSpan s) = parens $ text "EpaSpan" <+> srcSpan s epaAnchor (EpaDelta d cs) = case ba of NoBlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> showAstData' cs BlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> text "blanked" diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs index 7e61998048e5837589d1302532823e49ed969246..616fabd454361d5d07dfc59ccf883f208203a241 100644 --- a/compiler/GHC/Hs/ImpExp.hs +++ b/compiler/GHC/Hs/ImpExp.hs @@ -42,6 +42,7 @@ import GHC.Unit.Module.Warnings import Data.Data import Data.Maybe +import qualified Data.Semigroup as Semigroup {- @@ -119,6 +120,13 @@ data EpAnnImportDecl = EpAnnImportDecl , importDeclAnnAs :: Maybe EpaLocation } deriving (Data) +instance Semigroup EpAnnImportDecl where + EpAnnImportDecl a1 b1 c1 d1 e1 f1 <> EpAnnImportDecl a2 b2 c2 d2 e2 f2 + = EpAnnImportDecl (a1 Semigroup.<> a2) (b1 Semigroup.<> b2) (c1 Semigroup.<> c2) + (d1 Semigroup.<> d2) (e1 Semigroup.<> e2) (f1 Semigroup.<> f2) +instance Monoid EpAnnImportDecl where + mempty = EpAnnImportDecl noSpanAnchor Nothing Nothing Nothing Nothing Nothing + -- --------------------------------------------------------------------- simpleImportDecl :: ModuleName -> ImportDecl GhcPs diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index 6bcbb2a5b959cb72a1ed9cbc7a180adb6fb69f88..10de6a12d499cc6e5b78828e4baded1c63b6a23f 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -4308,7 +4308,7 @@ glRR :: Located a -> RealSrcSpan glRR = realSrcSpan . getLoc glR :: HasLoc a => a -> Anchor -glR la = EpaSpan (realSrcSpan $ getHasLoc la) Strict.Nothing +glR la = EpaSpan (getHasLoc la) glMR :: Maybe (Located a) -> Located b -> Anchor glMR (Just la) _ = glR la @@ -4318,7 +4318,7 @@ glEE :: (HasLoc a, HasLoc b) => a -> b -> Anchor glEE x y = spanAsAnchor $ comb2 x y anc :: RealSrcSpan -> Anchor -anc r = EpaSpan r Strict.Nothing +anc r = EpaSpan (RealSrcSpan r Strict.Nothing) glRM :: Located a -> Maybe Anchor glRM (L l _) = Just $ spanAsAnchor l @@ -4442,7 +4442,7 @@ parseSignature :: P (Located (HsModule GhcPs)) parseSignature = parseSignatureNoHaddock >>= addHaddockToModule commentsA :: (NoAnn ann) => SrcSpan -> EpAnnComments -> SrcSpanAnn' (EpAnn ann) -commentsA loc cs = SrcSpanAnn (EpAnn (EpaSpan (rs loc) Strict.Nothing) noAnn cs) loc +commentsA loc cs = SrcSpanAnn (EpAnn (EpaSpan loc) noAnn cs) loc -- | Instead of getting the *enclosed* comments, this includes the -- *preceding* ones. It is used at the top level to get comments diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs index 2728a7d4c11adbb798583f04abd154ffc43d4580..270d387f0f73769b14ce1d1259654843d861a4b9 100644 --- a/compiler/GHC/Parser/Annotation.hs +++ b/compiler/GHC/Parser/Annotation.hs @@ -406,7 +406,7 @@ data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Eq) -- in the @'EpaDelta'@ variant captures any comments between the prior -- output and the thing being marked here, since we cannot otherwise -- sort the relative order. -data EpaLocation = EpaSpan !RealSrcSpan !(Strict.Maybe BufSpan) +data EpaLocation = EpaSpan !SrcSpan | EpaDelta !DeltaPos ![LEpaComment] deriving (Data,Eq,Show) @@ -418,7 +418,7 @@ data TokenLocation = NoTokenLoc | TokenLoc !EpaLocation getTokenSrcSpan :: TokenLocation -> SrcSpan getTokenSrcSpan NoTokenLoc = noSrcSpan getTokenSrcSpan (TokenLoc EpaDelta{}) = noSrcSpan -getTokenSrcSpan (TokenLoc (EpaSpan rspan mbufpos)) = RealSrcSpan rspan mbufpos +getTokenSrcSpan (TokenLoc (EpaSpan span)) = span instance Outputable a => Outputable (GenLocated TokenLocation a) where ppr (L _ x) = ppr x @@ -455,15 +455,15 @@ getDeltaLine (DifferentLine r _) = r -- 'EpaLocation'. The parser will never insert a 'DeltaPos', so the -- partial function is safe. epaLocationRealSrcSpan :: EpaLocation -> RealSrcSpan -epaLocationRealSrcSpan (EpaSpan r _) = r -epaLocationRealSrcSpan (EpaDelta _ _) = panic "epaLocationRealSrcSpan" +epaLocationRealSrcSpan (EpaSpan (RealSrcSpan r _)) = r +epaLocationRealSrcSpan _ = panic "epaLocationRealSrcSpan" epaLocationFromSrcAnn :: SrcAnn ann -> EpaLocation -epaLocationFromSrcAnn (SrcSpanAnn EpAnnNotUsed l) = EpaSpan (realSrcSpan l) Strict.Nothing -epaLocationFromSrcAnn (SrcSpanAnn (EpAnn anc _ _) _) = EpaSpan (anchor anc) Strict.Nothing +epaLocationFromSrcAnn (SrcSpanAnn EpAnnNotUsed l) = EpaSpan l +epaLocationFromSrcAnn (SrcSpanAnn (EpAnn anc _ _) _) = anc instance Outputable EpaLocation where - ppr (EpaSpan r _) = text "EpaSpan" <+> ppr r + ppr (EpaSpan r) = text "EpaSpan" <+> ppr r ppr (EpaDelta d cs) = text "EpaDelta" <+> ppr d <+> ppr cs instance Outputable AddEpAnn where @@ -527,18 +527,17 @@ data EpAnn ann type Anchor = EpaLocation -- Transitional anchor :: Anchor -> RealSrcSpan -anchor (EpaSpan r _) = r +anchor (EpaSpan (RealSrcSpan r _)) = r anchor _ = panic "anchor" spanAsAnchor :: SrcSpan -> Anchor -spanAsAnchor (RealSrcSpan r mb) = EpaSpan r mb -spanAsAnchor s = EpaSpan (realSrcSpan s) Strict.Nothing +spanAsAnchor ss = EpaSpan ss realSpanAsAnchor :: RealSrcSpan -> Anchor -realSpanAsAnchor r = EpaSpan r Strict.Nothing +realSpanAsAnchor s = EpaSpan (RealSrcSpan s Strict.Nothing) spanFromAnchor :: Anchor -> SrcSpan -spanFromAnchor (EpaSpan r mb) = RealSrcSpan r mb +spanFromAnchor (EpaSpan ss) = ss spanFromAnchor (EpaDelta _ _) = UnhelpfulSpan (UnhelpfulOther (fsLit "spanFromAnchor")) noSpanAnchor :: Anchor @@ -1062,8 +1061,8 @@ realSrcSpan _ = mkRealSrcSpan l l -- AZ temporary l = mkRealSrcLoc (fsLit "realSrcSpan") (-1) (-1) srcSpan2e :: SrcSpan -> EpaLocation -srcSpan2e (RealSrcSpan s mb) = EpaSpan s mb -srcSpan2e span = EpaSpan (realSrcSpan span) Strict.Nothing +srcSpan2e ss@(RealSrcSpan _ _) = EpaSpan ss +srcSpan2e span = EpaSpan (RealSrcSpan (realSrcSpan span) Strict.Nothing) la2e :: SrcSpanAnn' a -> EpaLocation la2e = srcSpan2e . locA @@ -1081,7 +1080,7 @@ reAnnL :: ann -> EpAnnComments -> Located e -> GenLocated (SrcAnn ann) e reAnnL anns cs (L l a) = L (SrcSpanAnn (EpAnn (spanAsAnchor l) anns cs) l) a getLocAnn :: Located a -> SrcSpanAnnA -getLocAnn (L l _) = SrcSpanAnn EpAnnNotUsed l +getLocAnn (L l _) = SrcSpanAnn noAnn l instance NoAnn (EpAnn a) where -- Short form for 'EpAnnNotUsed' @@ -1111,7 +1110,8 @@ widenSpan :: SrcSpan -> [AddEpAnn] -> SrcSpan widenSpan s as = foldl combineSrcSpans s (go as) where go [] = [] - go (AddEpAnn _ (EpaSpan s mb):rest) = RealSrcSpan s mb : go rest + go (AddEpAnn _ (EpaSpan (RealSrcSpan s mb)):rest) = RealSrcSpan s mb : go rest + go (AddEpAnn _ (EpaSpan _):rest) = go rest go (AddEpAnn _ (EpaDelta _ _):rest) = go rest -- | The annotations need to all come after the anchor. Make sure @@ -1120,8 +1120,8 @@ widenRealSpan :: RealSrcSpan -> [AddEpAnn] -> RealSrcSpan widenRealSpan s as = foldl combineRealSrcSpans s (go as) where go [] = [] - go (AddEpAnn _ (EpaSpan s _):rest) = s : go rest - go (AddEpAnn _ (EpaDelta _ _):rest) = go rest + go (AddEpAnn _ (EpaSpan (RealSrcSpan s _)):rest) = s : go rest + go (AddEpAnn _ _:rest) = go rest realSpanFromAnns :: [AddEpAnn] -> Strict.Maybe RealSrcSpan realSpanFromAnns as = go Strict.Nothing as @@ -1130,7 +1130,7 @@ realSpanFromAnns as = go Strict.Nothing as combine (Strict.Just l) r = Strict.Just $ combineRealSrcSpans l r go acc [] = acc - go acc (AddEpAnn _ (EpaSpan s _b):rest) = go (combine acc s) rest + go acc (AddEpAnn _ (EpaSpan (RealSrcSpan s _b)):rest) = go (combine acc s) rest go acc (AddEpAnn _ _ :rest) = go acc rest bufSpanFromAnns :: [AddEpAnn] -> Strict.Maybe BufSpan @@ -1140,28 +1140,27 @@ bufSpanFromAnns as = go Strict.Nothing as combine (Strict.Just l) r = Strict.Just $ combineBufSpans l r go acc [] = acc - go acc (AddEpAnn _ (EpaSpan _ (Strict.Just mb)):rest) = go (combine acc mb) rest + go acc (AddEpAnn _ (EpaSpan (RealSrcSpan _ (Strict.Just mb))):rest) = go (combine acc mb) rest go acc (AddEpAnn _ _:rest) = go acc rest --- widenAnchor :: Anchor -> [AddEpAnn] -> Anchor --- widenAnchor (Anchor s op) as = Anchor (widenRealSpan s as) op widenAnchor :: Anchor -> [AddEpAnn] -> Anchor -widenAnchor (EpaSpan s mb) as - = EpaSpan (widenRealSpan s as) (liftA2 combineBufSpans mb (bufSpanFromAnns as)) --- widenAnchor (EpaSpan r mb) _ = EpaSpan r mb +widenAnchor (EpaSpan (RealSrcSpan s mb)) as + = EpaSpan (RealSrcSpan (widenRealSpan s as) (liftA2 combineBufSpans mb (bufSpanFromAnns as))) +widenAnchor (EpaSpan us) _ = EpaSpan us widenAnchor a@(EpaDelta _ _) as = case (realSpanFromAnns as) of Strict.Nothing -> a - Strict.Just r -> EpaSpan r Strict.Nothing + Strict.Just r -> EpaSpan (RealSrcSpan r Strict.Nothing) widenAnchorR :: Anchor -> RealSrcSpan -> Anchor -widenAnchorR (EpaSpan s _) r = EpaSpan (combineRealSrcSpans s r) Strict.Nothing -widenAnchorR (EpaDelta _ _) r = EpaSpan r Strict.Nothing +widenAnchorR (EpaSpan (RealSrcSpan s _)) r = EpaSpan (RealSrcSpan (combineRealSrcSpans s r) Strict.Nothing) +widenAnchorR (EpaSpan _) r = EpaSpan (RealSrcSpan r Strict.Nothing) +widenAnchorR (EpaDelta _ _) r = EpaSpan (RealSrcSpan r Strict.Nothing) widenAnchorS :: Anchor -> SrcSpan -> Anchor -widenAnchorS (EpaSpan s mbe) (RealSrcSpan r mbr) - = EpaSpan (combineRealSrcSpans s r) (liftA2 combineBufSpans mbe mbr) -widenAnchorS (EpaSpan us mb) _ = EpaSpan us mb -widenAnchorS (EpaDelta _ _) (RealSrcSpan r mb) = EpaSpan r mb +widenAnchorS (EpaSpan (RealSrcSpan s mbe)) (RealSrcSpan r mbr) + = EpaSpan (RealSrcSpan (combineRealSrcSpans s r) (liftA2 combineBufSpans mbe mbr)) +widenAnchorS (EpaSpan us) _ = EpaSpan us +widenAnchorS (EpaDelta _ _) (RealSrcSpan r mb) = EpaSpan (RealSrcSpan r mb) widenAnchorS anc _ = anc widenLocatedAn :: SrcSpanAnn' an -> [AddEpAnn] -> SrcSpanAnn' an @@ -1251,7 +1250,7 @@ placeholderRealSpan :: RealSrcSpan placeholderRealSpan = realSrcLocSpan (mkRealSrcLoc (mkFastString "placeholder") (-1) (-1)) comment :: RealSrcSpan -> EpAnnComments -> EpAnnCO -comment loc cs = EpAnn (EpaSpan loc Strict.Nothing) NoEpAnns cs +comment loc cs = EpAnn (EpaSpan (RealSrcSpan loc Strict.Nothing)) NoEpAnns cs -- --------------------------------------------------------------------- -- Utilities for managing comments in an `EpAnn a` structure. @@ -1394,9 +1393,9 @@ instance (Semigroup a) => Semigroup (EpAnn a) where -- largest span instance Semigroup EpaLocation where - EpaSpan s1 m1 <> EpaSpan s2 m2 = EpaSpan (combineRealSrcSpans s1 s2) (liftA2 combineBufSpans m1 m2) - EpaSpan s1 m1 <> _ = EpaSpan s1 m1 - _ <> EpaSpan s2 m2 = EpaSpan s2 m2 + EpaSpan s1 <> EpaSpan s2 = EpaSpan (combineSrcSpans s1 s2) + EpaSpan s1 <> _ = EpaSpan s1 + _ <> EpaSpan s2 = EpaSpan s2 EpaDelta dp1 cs1 <> EpaDelta _dp2 cs2 = EpaDelta dp1 (cs1<>cs2) instance Semigroup EpAnnComments where diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index 20f16f47fd9ca9aa2d8ff4e62dad1f4dcf50a193..c68ca76537184274611c832b07fa6efd6f32b20c 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -3780,7 +3780,8 @@ warn_unknown_prag prags span buf len buf2 = do -- 'AddEpAnn' values for the opening and closing bordering on the start -- and end of the span mkParensEpAnn :: RealSrcSpan -> (AddEpAnn, AddEpAnn) -mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan lo Strict.Nothing),AddEpAnn AnnCloseP (EpaSpan lc Strict.Nothing)) +mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan (RealSrcSpan lo Strict.Nothing)), + AddEpAnn AnnCloseP (EpaSpan (RealSrcSpan lc Strict.Nothing))) where f = srcSpanFile ss sl = srcSpanStartLine ss diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 4faf076e61c769d859b252ecf5748cf76b81fb41..75d63e70447cca0d75af4294eb4b59b2a16b589d 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -472,29 +472,30 @@ annBinds a cs (HsIPBinds an bs) = (HsIPBinds (add_where a an cs) bs, Nothing) annBinds _ cs (EmptyLocalBinds x) = (EmptyLocalBinds x, Just cs) add_where :: AddEpAnn -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList -add_where an@(AddEpAnn _ (EpaSpan rs _)) (EpAnn a (AnnList anc o c r t) cs) cs2 - | valid_anchor (anchor a) +add_where an@(AddEpAnn _ (EpaSpan (RealSrcSpan rs _))) (EpAnn a (AnnList anc o c r t) cs) cs2 + | valid_anchor a = EpAnn (widenAnchor a [an]) (AnnList anc o c (an:r) t) (cs Semi.<> cs2) | otherwise = EpAnn (patch_anchor rs a) (AnnList (fmap (patch_anchor rs) anc) o c (an:r) t) (cs Semi.<> cs2) -add_where an@(AddEpAnn _ (EpaSpan rs mb)) EpAnnNotUsed cs - = EpAnn (EpaSpan rs mb) - (AnnList (Just $ EpaSpan rs mb) Nothing Nothing [an] []) cs +add_where an@(AddEpAnn _ (EpaSpan (RealSrcSpan rs mb))) EpAnnNotUsed cs + = EpAnn (EpaSpan (RealSrcSpan rs mb)) + (AnnList (Just $ EpaSpan (RealSrcSpan rs mb)) Nothing Nothing [an] []) cs add_where (AddEpAnn _ _) _ _ = panic "add_where" -- EpaDelta should only be used for transformations -valid_anchor :: RealSrcSpan -> Bool -valid_anchor r = srcSpanStartLine r >= 0 +valid_anchor :: Anchor -> Bool +valid_anchor (EpaSpan (RealSrcSpan r _)) = srcSpanStartLine r >= 0 +valid_anchor _ = False -- If the decl list for where binds is empty, the anchor ends up -- invalid. In this case, use the parent one patch_anchor :: RealSrcSpan -> Anchor -> Anchor -patch_anchor r (EpaDelta _ _) = EpaSpan r Strict.Nothing -patch_anchor r1 (EpaSpan r0 mb) = EpaSpan r mb +patch_anchor r (EpaDelta _ _) = EpaSpan (RealSrcSpan r Strict.Nothing) +patch_anchor r1 (EpaSpan (RealSrcSpan r0 mb)) = EpaSpan (RealSrcSpan r mb) where r = if srcSpanStartLine r0 < 0 then r1 else r0 --- patch_anchor _ (EpaSpan ss mb) = EpaSpan ss mb +patch_anchor _ (EpaSpan ss) = EpaSpan ss fixValbindsAnn :: EpAnn AnnList -> EpAnn AnnList fixValbindsAnn EpAnnNotUsed = EpAnnNotUsed @@ -504,9 +505,9 @@ fixValbindsAnn (EpAnn anchor (AnnList ma o c r t) cs) -- | The 'Anchor' for a stmtlist is based on either the location or -- the first semicolon annotion. stmtsAnchor :: Located (OrdList AddEpAnn,a) -> Maybe Anchor -stmtsAnchor (L (RealSrcSpan l mb) ((ConsOL (AddEpAnn _ (EpaSpan r rb)) _), _)) - = Just $ widenAnchorS (EpaSpan l mb) (RealSrcSpan r rb) -stmtsAnchor (L (RealSrcSpan l mb) _) = Just $ EpaSpan l mb +stmtsAnchor (L (RealSrcSpan l mb) ((ConsOL (AddEpAnn _ (EpaSpan (RealSrcSpan r rb))) _), _)) + = Just $ widenAnchorS (EpaSpan (RealSrcSpan l mb)) (RealSrcSpan r rb) +stmtsAnchor (L (RealSrcSpan l mb) _) = Just $ EpaSpan (RealSrcSpan l mb) stmtsAnchor _ = Nothing stmtsLoc :: Located (OrdList AddEpAnn,a) -> SrcSpan @@ -994,7 +995,7 @@ checkTyVars pp_what equals_or_where tc tparms for_widening _ = AddEpAnn AnnAnyclass (EpaDelta (SameLine 0) []) for_widening_ann :: HsBndrVis GhcPs -> EpAnn [AddEpAnn] - for_widening_ann (HsBndrInvisible (L (TokenLoc (EpaSpan r _mb)) _)) = EpAnn (realSpanAsAnchor r) [] emptyComments + for_widening_ann (HsBndrInvisible (L (TokenLoc (EpaSpan (RealSrcSpan r _mb))) _)) = EpAnn (realSpanAsAnchor r) [] emptyComments for_widening_ann _ = EpAnnNotUsed @@ -1111,14 +1112,14 @@ checkTyClHdr is_cls ty newAnns (SrcSpanAnn EpAnnNotUsed l) (EpAnn as (AnnParen _ o c) cs) = let lr = combineRealSrcSpans (realSrcSpan l) (anchor as) - an = (EpAnn (EpaSpan lr Strict.Nothing) (NameAnn NameParens o (srcSpan2e l) c []) cs) + an = EpAnn (EpaSpan (RealSrcSpan lr Strict.Nothing)) (NameAnn NameParens o (srcSpan2e l) c []) cs in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing) newAnns _ EpAnnNotUsed = panic "missing AnnParen" newAnns (SrcSpanAnn (EpAnn ap (AnnListItem ta) csp) l) (EpAnn as (AnnParen _ o c) cs) = let - lr = combineRealSrcSpans (anchor ap) (anchor as) - an = (EpAnn (EpaSpan lr Strict.Nothing) (NameAnn NameParens o (srcSpan2e l) c ta) (csp Semi.<> cs)) - in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing) + lr = RealSrcSpan (combineRealSrcSpans (anchor ap) (anchor as)) Strict.Nothing + an = EpAnn (EpaSpan lr) (NameAnn NameParens o (srcSpan2e l) c ta) (csp Semi.<> cs) + in SrcSpanAnn an lr -- | Yield a parse error if we have a function applied directly to a do block -- etc. and BlockArguments is not enabled. @@ -3210,14 +3211,14 @@ mkMultTy pct t arr = HsExplicitMult pct t arr mkTokenLocation :: SrcSpan -> TokenLocation mkTokenLocation (UnhelpfulSpan _) = NoTokenLoc -mkTokenLocation (RealSrcSpan r mb) = TokenLoc (EpaSpan r mb) +mkTokenLocation (RealSrcSpan r mb) = TokenLoc (EpaSpan (RealSrcSpan r mb)) -- Precondition: the TokenLocation has EpaSpan, never EpaDelta. token_location_widenR :: TokenLocation -> SrcSpan -> TokenLocation token_location_widenR NoTokenLoc _ = NoTokenLoc token_location_widenR tl (UnhelpfulSpan _) = tl -token_location_widenR (TokenLoc (EpaSpan r1 mb1)) (RealSrcSpan r2 mb2) = - (TokenLoc (EpaSpan (combineRealSrcSpans r1 r2) (liftA2 combineBufSpans mb1 mb2))) +token_location_widenR (TokenLoc (EpaSpan s1)) s2 = + (TokenLoc (EpaSpan (combineSrcSpans s1 s2))) token_location_widenR (TokenLoc (EpaDelta _ _)) _ = -- Never happens because the parser does not produce EpaDelta. panic "token_location_widenR: EpaDelta" diff --git a/testsuite/tests/printer/Test20297.stdout b/testsuite/tests/printer/Test20297.stdout index a5cc5788a83fae844ede18a04e2417a5f584e245..6f35afb9634c23d0cbe5e3c5e1f9cc2d1cd3095d 100644 --- a/testsuite/tests/printer/Test20297.stdout +++ b/testsuite/tests/printer/Test20297.stdout @@ -99,10 +99,10 @@ {OccName: x}))))))] (HsValBinds (EpAnn - (EpaSpan { Test20297.hs:7:3-7 }) + (EpaSpan { <no location info> }) (AnnList (Just - (EpaSpan { Test20297.hs:7:3-7 })) + (EpaSpan { <no location info> })) (Nothing) (Nothing) [(AddEpAnn AnnWhere (EpaSpan { Test20297.hs:7:3-7 }))] @@ -390,10 +390,10 @@ {OccName: x}))))))] (HsValBinds (EpAnn - (EpaSpan { Test20297.ppr.hs:5:3-7 }) + (EpaSpan { <no location info> }) (AnnList (Just - (EpaSpan { Test20297.ppr.hs:5:3-7 })) + (EpaSpan { <no location info> })) (Nothing) (Nothing) [(AddEpAnn AnnWhere (EpaSpan { Test20297.ppr.hs:5:3-7 }))] diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index f5bf1bf598ffee1f0ce7564a67adc8b92f782db3..cfcd1a5773a3c81c690731afa828c2abffe751aa 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -422,7 +422,7 @@ enterAnn (Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do debugM $ "enterAnn:starting:(p,pe,anchor',a) =" ++ show (p, pe0, showAst anchor', astId a) prevAnchor <- getAnchorU let curAnchor = case anchor' of - EpaSpan r _ -> r + EpaSpan (RealSrcSpan r _) -> r _ -> prevAnchor debugM $ "enterAnn:(curAnchor):=" ++ show (rs2range curAnchor) case canUpdateAnchor of @@ -495,10 +495,11 @@ enterAnn (Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do Just (EpaDelta dp _) -> dp -- Replace original with desired one. Allows all -- list entry values to be DP (1,0) - Just (EpaSpan r _) -> dp + Just (EpaSpan (RealSrcSpan r _)) -> dp where dp = adjustDeltaForOffset off (ss2delta priorEndAfterComments r) + Just (EpaSpan (UnhelpfulSpan r)) -> panic $ "enterAnn: UnhelpfulSpan:" ++ show r -- --------------------------------------------- -- Preparation complete, perform the action when (priorEndAfterComments < spanStart) (do @@ -543,9 +544,10 @@ enterAnn (Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do case anchor' of EpaDelta _ _ -> return () - EpaSpan rss _ -> do + EpaSpan (RealSrcSpan rss _) -> do setAcceptSpan False setPriorEndD (snd $ rs2range rss) + EpaSpan _ -> return () -- Outside the anchor, mark any trailing postCs <- cua canUpdateAnchor takeAppliedCommentsPop @@ -723,7 +725,8 @@ printStringAtAAL (EpAnn anc an cs) l str = do printStringAtAAC :: (Monad m, Monoid w) => CaptureComments -> EpaLocation -> String -> EP w m EpaLocation -printStringAtAAC capture (EpaSpan r _) s = printStringAtRsC capture r s +printStringAtAAC capture (EpaSpan (RealSrcSpan r _)) s = printStringAtRsC capture r s +printStringAtAAC capture (EpaSpan (UnhelpfulSpan _)) s = printStringAtAAC capture (EpaDelta (SameLine 0) []) s printStringAtAAC capture (EpaDelta d cs) s = do mapM_ printOneComment $ concatMap tokComment cs pe1 <- getPriorEndD @@ -798,10 +801,10 @@ markEpAnnLMS' (EpAnn anc a cs) l kw (Just str) = do markLToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) => Located (HsToken tok) -> EP w m (Located (HsToken tok)) markLToken (L (RealSrcSpan aa mb) t) = do - epaLoc'<- printStringAtAA (EpaSpan aa mb) (symbolVal (Proxy @tok)) + epaLoc'<- printStringAtAA (EpaSpan (RealSrcSpan aa mb)) (symbolVal (Proxy @tok)) case epaLoc' of - EpaSpan aa' mb' -> return (L (RealSrcSpan aa' mb') t) - _ -> return (L (RealSrcSpan aa mb ) t) + EpaSpan (RealSrcSpan aa' mb') -> return (L (RealSrcSpan aa' mb') t) + _ -> return (L (RealSrcSpan aa mb ) t) markLToken (L lt t) = return (L lt t) markToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) @@ -1403,12 +1406,13 @@ printOneComment c@(Comment _str loc _r _mo) = do debugM $ "printOneComment:c=" ++ showGhc c dp <-case loc of EpaDelta dp _ -> return dp - EpaSpan r _ -> do + EpaSpan (RealSrcSpan r _) -> do pe <- getPriorEndD debugM $ "printOneComment:pe=" ++ showGhc pe let dp = ss2delta pe r debugM $ "printOneComment:(dp,pe,loc)=" ++ showGhc (dp,pe,loc) adjustDeltaForOffsetM dp + EpaSpan (UnhelpfulSpan _) -> return (SameLine 0) mep <- getExtraDP dp' <- case mep of Just (EpaDelta edp _) -> do @@ -1429,12 +1433,13 @@ updateAndApplyComment (Comment str anc pp mo) dp = do (r,c) = ss2posEnd pp dp'' = case anc of EpaDelta dp1 _ -> dp1 - EpaSpan la _ -> + EpaSpan (RealSrcSpan la _) -> if r == 0 then (ss2delta (r,c+0) la) else (ss2delta (r,c) la) + EpaSpan (UnhelpfulSpan _) -> SameLine 0 dp' = case anc of - EpaSpan r1 _ -> + EpaSpan (RealSrcSpan r1 _) -> if pp == r1 then dp else dp'' @@ -1459,7 +1464,7 @@ commentAllocationBefore ss = do -- TODO: this is inefficient, use Pos all the way through let (earlier,later) = partition (\(Comment _str loc _r _mo) -> case loc of - EpaSpan r _ -> (ss2pos r) <= (ss2pos ss) + EpaSpan (RealSrcSpan r _) -> (ss2pos r) <= (ss2pos ss) _ -> True -- Choose one ) cs putUnallocatedComments later @@ -1475,7 +1480,7 @@ commentAllocationIn ss = do -- TODO: this is inefficient, use Pos all the way through let (earlier,later) = partition (\(Comment _str loc _r _mo) -> case loc of - EpaSpan r _ -> (ss2posEnd r) <= (ss2posEnd ss) + EpaSpan (RealSrcSpan r _) -> (ss2posEnd r) <= (ss2posEnd ss) _ -> True -- Choose one ) cs putUnallocatedComments later @@ -4376,7 +4381,7 @@ printUnicode anc n = do s -> s loc <- printStringAtAAC NoCaptureComments (EpaDelta (SameLine 0) []) str case loc of - EpaSpan _ _ -> return anc + EpaSpan _ -> return anc EpaDelta dp [] -> return $ EpaDelta dp [] EpaDelta _ _cs -> error "printUnicode should not capture comments" diff --git a/utils/check-exact/Parsers.hs b/utils/check-exact/Parsers.hs index 2eadcacab96ca2023a4f8828638e4ec08d3acee9..54e33b37cf2b5ec51ad9c378d6a3fc7a0c2101d4 100644 --- a/utils/check-exact/Parsers.hs +++ b/utils/check-exact/Parsers.hs @@ -284,7 +284,7 @@ fixModuleTrailingComments (GHC.L l p) = GHC.L l p' rebalance cs = cs' where cs' = case GHC.hsmodLayout $ GHC.hsmodExt p of - GHC.ExplicitBraces _ (GHC.L (GHC.TokenLoc (GHC.EpaSpan ss _)) _) -> + GHC.ExplicitBraces _ (GHC.L (GHC.TokenLoc (GHC.EpaSpan (GHC.RealSrcSpan ss _))) _) -> let pc = GHC.priorComments cs fc = GHC.getFollowingComments cs diff --git a/utils/check-exact/Transform.hs b/utils/check-exact/Transform.hs index 6897e459199e9662dd17f43b038d402ac8f8040c..2385e593cd8e2d2e9df9534471335625719d2bcf 100644 --- a/utils/check-exact/Transform.hs +++ b/utils/check-exact/Transform.hs @@ -222,8 +222,8 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc rs') cs) ns (H L (SrcSpanAnn EpAnnNotUsed ll) _ -> realSrcSpan ll L (SrcSpanAnn (EpAnn anc' _ _) _) _ -> anchor anc' -- TODO MovedAnchor? dc' = case dca of - EpaSpan r _ -> AddEpAnn kw (EpaDelta (ss2delta (ss2posEnd rd) r) []) - EpaDelta _ _ -> AddEpAnn kw dca + EpaSpan (RealSrcSpan r _) -> AddEpAnn kw (EpaDelta (ss2delta (ss2posEnd rd) r) []) + _ -> AddEpAnn kw dca -- --------------------------------- @@ -232,7 +232,8 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc rs') cs) ns (H (L (SrcSpanAnn EpAnnNotUsed ll) b) -> let anc0 = case dca of - EpaSpan r _ -> EpaDelta (ss2delta (ss2posEnd r) (realSrcSpan ll)) [] + EpaSpan (RealSrcSpan r _) -> EpaDelta (ss2delta (ss2posEnd r) (realSrcSpan ll)) [] + EpaSpan (UnhelpfulSpan _) -> EpaDelta (SameLine 1) [] EpaDelta _ cs0 -> EpaDelta (SameLine 1) cs0 in (L (SrcSpanAnn (EpAnn anc0 noAnn emptyComments) ll) b) (L (SrcSpanAnn (EpAnn anc0 a c) ll) b) @@ -240,7 +241,7 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc rs') cs) ns (H anc' = case anc0 of EpaDelta _ _ -> anc0 _ -> case dca of - EpaSpan _ _ -> EpaDelta (SameLine 1) [] + EpaSpan _ -> EpaDelta (SameLine 1) [] EpaDelta _ cs0 -> EpaDelta (SameLine 1) cs0 in (L (SrcSpanAnn (EpAnn anc' a c) ll) b) @@ -268,7 +269,11 @@ setEntryDP (L (SrcSpanAnn EpAnnNotUsed l) a) dp = L (SrcSpanAnn (EpAnn (EpaDelta dp []) noAnn emptyComments) l) a -setEntryDP (L (SrcSpanAnn (EpAnn (EpaSpan _ _) an (EpaComments [])) l) a) dp +setEntryDP (L (SrcSpanAnn (EpAnn (EpaSpan (UnhelpfulSpan _)) an cs) l) a) dp + = L (SrcSpanAnn + (EpAnn (EpaDelta dp []) an cs) + l) a +setEntryDP (L (SrcSpanAnn (EpAnn (EpaSpan _) an (EpaComments [])) l) a) dp = L (SrcSpanAnn (EpAnn (EpaDelta dp []) an (EpaComments [])) l) a @@ -299,8 +304,8 @@ setEntryDP (L (SrcSpanAnn (EpAnn (EpaDelta d csd) an cs) l) a) dp in (dp0, c':t, EpaCommentsBalanced [] ts) go (L (EpaDelta _ c0) c) = (d, L (EpaDelta dp c0) c) - go (L (EpaSpan _ _) c) = (d, L (EpaDelta dp []) c) -setEntryDP (L (SrcSpanAnn (EpAnn (EpaSpan r _) an cs) l) a) dp + go (L (EpaSpan _) c) = (d, L (EpaDelta dp []) c) +setEntryDP (L (SrcSpanAnn (EpAnn (EpaSpan (RealSrcSpan r _)) an cs) l) a) dp = case sortEpaComments (priorComments cs) of [] -> L (SrcSpanAnn @@ -315,8 +320,9 @@ setEntryDP (L (SrcSpanAnn (EpAnn (EpaSpan r _) an cs) l) a) dp csd = L (EpaDelta dp []) c:cs' lc = last $ (L ca c:cs') delta = case getLoc lc of - EpaSpan rr _ -> ss2delta (ss2pos rr) r - EpaDelta _dp _ -> DifferentLine 1 0 + EpaSpan (RealSrcSpan rr _) -> ss2delta (ss2pos rr) r + EpaSpan _ -> (SameLine 0) + EpaDelta _ _ -> DifferentLine 1 0 -- cs'' = setPriorComments cs (L (EpaDelta dp []) c:cs') -- lc = head $ reverse $ (L ca c:cs') -- delta = case getLoc lc of @@ -340,17 +346,20 @@ getEntryDP _ = SameLine 1 addEpaLocationDelta :: LayoutStartCol -> RealSrcSpan -> EpaLocation -> EpaLocation addEpaLocationDelta _off _anc (EpaDelta d cs) = EpaDelta d cs -addEpaLocationDelta off anc (EpaSpan r _) +addEpaLocationDelta _off _anc s@(EpaSpan (UnhelpfulSpan _)) = s +addEpaLocationDelta off anc (EpaSpan (RealSrcSpan r _)) = EpaDelta (adjustDeltaForOffset off (ss2deltaEnd anc r)) [] -- Set the entry DP for an element coming after an existing keyword annotation setEntryDPFromAnchor :: LayoutStartCol -> EpaLocation -> LocatedA t -> LocatedA t setEntryDPFromAnchor _off (EpaDelta _ _) (L la a) = L la a -setEntryDPFromAnchor off (EpaSpan anc _) ll@(L la _) = setEntryDP ll dp' +setEntryDPFromAnchor _off (EpaSpan (UnhelpfulSpan _)) (L la a) = L la a +setEntryDPFromAnchor off (EpaSpan (RealSrcSpan anc _)) ll@(L la _) = setEntryDP ll dp' where dp' = case la of (SrcSpanAnn EpAnnNotUsed l) -> adjustDeltaForOffset off (ss2deltaEnd anc (realSrcSpan l)) - (SrcSpanAnn (EpAnn (EpaSpan r' _) _ _) _) -> adjustDeltaForOffset off (ss2deltaEnd anc r') + (SrcSpanAnn (EpAnn (EpaSpan (RealSrcSpan r' _)) _ _) _) -> adjustDeltaForOffset off (ss2deltaEnd anc r') + (SrcSpanAnn (EpAnn (EpaSpan _) _ _) _) -> adjustDeltaForOffset off (SameLine 0) (SrcSpanAnn (EpAnn (EpaDelta dp _) _ _) _) -> adjustDeltaForOffset off dp -- --------------------------------------------------------------------- @@ -381,7 +390,7 @@ transferEntryDP (L (SrcSpanAnn EpAnnNotUsed _l1) _) (L (SrcSpanAnn (EpAnn anc2 a where anc2' = case anc2 of EpaDelta _ _ -> anc2 - EpaSpan _ _ -> EpaSpan (realSrcSpan l2) Strict.Nothing + EpaSpan _ -> EpaSpan (RealSrcSpan (realSrcSpan l2) Strict.Nothing) -- |If a and b are the same type return first arg, else return second @@ -447,7 +456,7 @@ balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)))) second = do -- + move the trailing ones to the last match. let (before,middle,after) = case s_entry lf of - EpaSpan ss _ -> + EpaSpan (RealSrcSpan ss _) -> let split = splitCommentsEnd ss (s_comments lf) split2 = splitCommentsStart ss (EpaComments (sortEpaComments $ priorComments split)) @@ -630,7 +639,7 @@ priorCommentsDeltas r cs = go r (reverse $ sortEpaComments cs) splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments splitCommentsEnd p (EpaComments cs) = cs' where - cmp (L (EpaSpan l _) _) = ss2pos l > ss2posEnd p + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p cmp (L _ _) = True (before, after) = break cmp cs cs' = case after of @@ -638,7 +647,7 @@ splitCommentsEnd p (EpaComments cs) = cs' _ -> EpaCommentsBalanced before after splitCommentsEnd p (EpaCommentsBalanced cs ts) = EpaCommentsBalanced cs' ts' where - cmp (L (EpaSpan l _) _) = ss2pos l > ss2posEnd p + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p cmp (L _ _) = True (before, after) = break cmp cs cs' = before @@ -649,7 +658,7 @@ splitCommentsEnd p (EpaCommentsBalanced cs ts) = EpaCommentsBalanced cs' ts' splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments splitCommentsStart p (EpaComments cs) = cs' where - cmp (L (EpaSpan l _) _) = ss2pos l > ss2posEnd p + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p cmp (L _ _) = True (before, after) = break cmp cs cs' = case after of @@ -657,7 +666,7 @@ splitCommentsStart p (EpaComments cs) = cs' _ -> EpaCommentsBalanced before after splitCommentsStart p (EpaCommentsBalanced cs ts) = EpaCommentsBalanced cs' ts' where - cmp (L (EpaSpan l _) _) = ss2pos l > ss2posEnd p + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p cmp (L _ _) = True (before, after) = break cmp cs cs' = before @@ -933,7 +942,8 @@ instance HasDecls (LocatedA (HsExpr GhcPs)) where (L (TokenLoc l) ls, L (TokenLoc i) is) -> let off = case l of - (EpaSpan r _) -> LayoutStartCol $ snd $ ss2pos r + (EpaSpan (RealSrcSpan r _)) -> LayoutStartCol $ snd $ ss2pos r + (EpaSpan (UnhelpfulSpan _)) -> LayoutStartCol 0 (EpaDelta (SameLine _) _) -> LayoutStartCol 0 (EpaDelta (DifferentLine _ c) _) -> LayoutStartCol c ex'' = setEntryDPFromAnchor off i ex diff --git a/utils/check-exact/Utils.hs b/utils/check-exact/Utils.hs index 0abe8b0ca845ad9e00f3c468545368e108c68bc4..ed7c6febdb2ba714107ec18cbbe400282f72147b 100644 --- a/utils/check-exact/Utils.hs +++ b/utils/check-exact/Utils.hs @@ -123,7 +123,7 @@ undelta (l,_) (DifferentLine dl dc) (LayoutStartCol co) = (fl,fc) fc = co + dc undeltaSpan :: RealSrcSpan -> AnnKeywordId -> DeltaPos -> AddEpAnn -undeltaSpan anc kw dp = AddEpAnn kw (EpaSpan sp Strict.Nothing) +undeltaSpan anc kw dp = AddEpAnn kw (EpaSpan (RealSrcSpan sp Strict.Nothing)) where (l,c) = undelta (ss2pos anc) dp (LayoutStartCol 0) len = length (keywordToString kw) @@ -170,7 +170,7 @@ spanLength = (-) <$> srcSpanEndCol <*> srcSpanStartCol -- | Useful for debug dumps eloc2str :: EpaLocation -> String -eloc2str (EpaSpan r _) = "EpaSpan " ++ show (rs2range r) +eloc2str (EpaSpan r) = "EpaSpan " ++ show (ss2range r) eloc2str epaLoc = show epaLoc -- --------------------------------------------------------------------- @@ -186,7 +186,7 @@ isPointSrcSpan ss = spanLength ss == 0 -- `MovedAnchor` operation based on the original location, only if it -- does not already have one. commentOrigDelta :: LEpaComment -> LEpaComment -commentOrigDelta (L (EpaSpan la _) (GHC.EpaComment t pp)) +commentOrigDelta (L (EpaSpan (RealSrcSpan la _)) (GHC.EpaComment t pp)) = (L (EpaDelta dp []) (GHC.EpaComment t pp)) `debug` ("commentOrigDelta: (la, pp, r,c, dp)=" ++ showAst (la, pp, r,c, dp)) where @@ -331,8 +331,10 @@ sortEpaComments cs = sortBy cmp cs -- | Makes a comment which originates from a specific keyword. mkKWComment :: AnnKeywordId -> EpaLocation -> Comment -mkKWComment kw (EpaSpan ss mb) - = Comment (keywordToString kw) (EpaSpan ss mb) ss (Just kw) +mkKWComment kw (EpaSpan (RealSrcSpan ss mb)) + = Comment (keywordToString kw) (EpaSpan (RealSrcSpan ss mb)) ss (Just kw) +mkKWComment kw (EpaSpan (UnhelpfulSpan _)) + = Comment (keywordToString kw) (EpaDelta (SameLine 0) []) placeholderRealSpan (Just kw) mkKWComment kw (EpaDelta dp cs) = Comment (keywordToString kw) (EpaDelta dp cs) placeholderRealSpan (Just kw) @@ -444,15 +446,18 @@ To be absolutely sure, we make the delta versions use -ve values. hackSrcSpanToAnchor :: SrcSpan -> Anchor hackSrcSpanToAnchor (UnhelpfulSpan s) = error $ "hackSrcSpanToAnchor : UnhelpfulSpan:" ++ show s -hackSrcSpanToAnchor (RealSrcSpan r Strict.Nothing) = EpaSpan r Strict.Nothing -hackSrcSpanToAnchor (RealSrcSpan r mb@(Strict.Just (BufSpan (BufPos s) (BufPos e)))) - = if s <= 0 && e <= 0 - then EpaDelta (deltaPos (-s) (-e)) [] - `debug` ("hackSrcSpanToAnchor: (r,s,e)=" ++ showAst (r,s,e) ) - else EpaSpan r mb +hackSrcSpanToAnchor (RealSrcSpan r mb) + = case mb of + (Strict.Just (BufSpan (BufPos s) (BufPos e))) -> + if s <= 0 && e <= 0 + then EpaDelta (deltaPos (-s) (-e)) [] + `debug` ("hackSrcSpanToAnchor: (r,s,e)=" ++ showAst (r,s,e) ) + -- else Anchor r UnchangedAnchor + else EpaSpan (RealSrcSpan r mb) + _ -> EpaSpan (RealSrcSpan r mb) hackAnchorToSrcSpan :: Anchor -> SrcSpan -hackAnchorToSrcSpan (EpaSpan r mb) = RealSrcSpan r mb +hackAnchorToSrcSpan (EpaSpan s) = s hackAnchorToSrcSpan _ = error $ "hackAnchorToSrcSpan" -- --------------------------------------------------------------------- diff --git a/utils/haddock b/utils/haddock index a70ba4918b8a65abd18b16f414b6e2c3c4e38c46..96e713f7768926dab4aeec5175c1854057a833c9 160000 --- a/utils/haddock +++ b/utils/haddock @@ -1 +1 @@ -Subproject commit a70ba4918b8a65abd18b16f414b6e2c3c4e38c46 +Subproject commit 96e713f7768926dab4aeec5175c1854057a833c9