[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: Speed up stimes in instance Semigroup Endo

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Tue Nov 21 17:32:00 UTC 2023



Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


Commits:
5a6c49d4 by David Feuer at 2023-11-20T18:53:18-05:00
Speed up stimes in instance Semigroup Endo

As discussed at
https://github.com/haskell/core-libraries-committee/issues/4

- - - - -
cf9da4b3 by Andrew Lelechenko at 2023-11-20T18:53:18-05:00
base: reflect latest changes in the changelog

- - - - -
48bf364e by Alan Zimmerman at 2023-11-20T18:53:54-05:00
EPA: Use SrcSpan in EpaSpan

This is more natural, since we already need to deal with invalid
RealSrcSpans, and that is exactly what SrcSpan.UnhelpfulSpan is for.

Updates haddock submodule.

- - - - -
97ec37cc by Sebastian Graf at 2023-11-20T18:54:31-05:00
Add regression test for #6070

Fixes #6070.

- - - - -
d9c62d15 by Owen Shepherd at 2023-11-21T12:31:43-05:00
chore: Correct typo in the gitlab MR template

[skip ci]

- - - - -
d9475af8 by Rodrigo Mesquita at 2023-11-21T12:31:44-05:00
Improve error message when reading invalid `.target` files

A `.target` file generated by ghc-toolchain or by configure can become
invalid if the target representation (`Toolchain.Target`) is changed
while the files are not re-generated by calling `./configure` or
`ghc-toolchain` again. There is also the issue of hadrian caching the
dependencies on `.target` files, which makes parsing fail when reading
reading the cached value if the representation has been updated.

This patch provides a better error message in both situations, moving
away from a terrible `Prelude.read: no parse` error that you would get
otherwise.

Fixes #24199

- - - - -


22 changed files:

- .gitlab/merge_request_templates/Default.md
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/Hs/ImpExp.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Parser/PostProcess.hs
- hadrian/src/Hadrian/Oracles/TextFile.hs
- libraries/base/changelog.md
- libraries/base/src/Data/Semigroup/Internal.hs
- libraries/base/tests/all.T
- + libraries/base/tests/stimesEndo.hs
- + libraries/base/tests/stimesEndo.stdout
- testsuite/tests/printer/Test20297.stdout
- + testsuite/tests/stranal/sigs/T6070.hs
- + testsuite/tests/stranal/sigs/T6070.stderr
- testsuite/tests/stranal/sigs/all.T
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Parsers.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
- utils/haddock


Changes:

=====================================
.gitlab/merge_request_templates/Default.md
=====================================
@@ -30,7 +30,7 @@ label can be applied to perform additional validation checks if your MR affects
 unusual configuration.
 
 Once your change is ready please remove the `WIP:` tag and wait for review. If
-no one has offerred review in a few days then please leave a comment mentioning
+no one has offered a review in a few days then please leave a comment mentioning
 @triagers and apply the ~"Blocked on Review" label.
 
 [notes]: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/coding-style#comments-in-the-source-code


=====================================
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"


=====================================
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


=====================================
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


=====================================
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


=====================================
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


=====================================
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"


=====================================
hadrian/src/Hadrian/Oracles/TextFile.hs
=====================================
@@ -163,14 +163,23 @@ textFileOracle = do
         putVerbose $ "| TargetFile oracle: reading " ++ quote file ++ "..."
         mtarget <- readMaybe <$> readFile' file
         case mtarget of
-          Nothing -> error $ "Failed to read a Toolchain.Target from " ++ quote file
+          Nothing -> error $ unlines ["Error parsing a Toolchain.Target from " ++ quote file,
+                                      "Perhaps the `.target` file is out of date.",
+                                      "Try re-running `./configure`."
+                                     ]
+
           Just target -> return (target :: Toolchain.Target)
     void $ addOracleCache $ \(TargetFile file) -> tf file
 
 -- Orphan instances for (ShakeValue Toolchain.Target)
 instance Binary Toolchain.Target where
-  put = put  . show
-  get = read <$> get
+  put = put . show
+  get = fromMaybe (error $ unlines ["Error parsing a toolchain `.target` file from its binary representation in hadrian.",
+                                    "This is likely caused by a stale hadrian/shake cache",
+                                    "which has saved an old `.target` file that can't be parsed",
+                                    "into a more recent `Toolchain.Target`. It is recommended to reset",
+                                    "by running `./hadrian/build clean`."
+                                   ]) . readMaybe <$> get
 
 instance Hashable Toolchain.Target where
   hashWithSalt s = hashWithSalt s . show


=====================================
libraries/base/changelog.md
=====================================
@@ -3,7 +3,9 @@
 ## 4.20.0.0 *TBA*
   * Export `foldl'` from `Prelude` ([CLC proposal #167](https://github.com/haskell/core-libraries-committee/issues/167))
   * Add `permutations` and `permutations1` to `Data.List.NonEmpty` ([CLC proposal #68](https://github.com/haskell/core-libraries-committee/issues/68))
-  * Add a `RULE` to `Prelude.lookup`, allowing it to participate in list fusion ([CLC proposal #174](https://github.com/haskell/core-libraries-committee/issues/175))
+  * Add a `RULE` to `Prelude.lookup`, allowing it to participate in list fusion ([CLC proposal #175](https://github.com/haskell/core-libraries-committee/issues/175))
+  * Implement `stimes` for `instance Semigroup (Endo a)` explicitly ([CLC proposal #4](https://github.com/haskell/core-libraries-committee/issues/4))
+  * Add laws relating between `Foldable` / `Traversable` with `Bifoldable` / `Bitraversable` ([CLC proposal #205](https://github.com/haskell/core-libraries-committee/issues/205))
   * The `Enum Int64` and `Enum Word64` instances now use native operations on 32-bit platforms, increasing performance by up to 1.5x on i386 and up to 5.6x with the JavaScript backend. ([CLC proposal #187](https://github.com/haskell/core-libraries-committee/issues/187))
   * Update to [Unicode 15.1.0](https://www.unicode.org/versions/Unicode15.1.0/).
   * Fix `fdIsNonBlocking` to always be `0` for regular files and block devices on unix, regardless of `O_NONBLOCK`
@@ -29,6 +31,8 @@
     constructors in scope and the levity of `t` is statically known,
     then the constraint `DataToTag t` can always be solved.
 
+    ([CLC proposal #104](https://github.com/haskell/core-libraries-committee/issues/104))
+
 ## 4.19.0.0 *October 2023*
   * Add `{-# WARNING in "x-partial" #-}` to `Data.List.{head,tail}`.
     Use `{-# OPTIONS_GHC -Wno-x-partial #-}` to disable it.


=====================================
libraries/base/src/Data/Semigroup/Internal.hs
=====================================
@@ -1,4 +1,5 @@
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE PolyKinds #-}
@@ -134,8 +135,46 @@ newtype Endo a = Endo { appEndo :: a -> a }
 
 -- | @since 4.9.0.0
 instance Semigroup (Endo a) where
-        (<>) = coerce ((.) :: (a -> a) -> (a -> a) -> (a -> a))
-        stimes = stimesMonoid
+    (<>) = coerce ((.) :: (a -> a) -> (a -> a) -> (a -> a))
+
+    -- See Note [stimes Endo]
+    stimes !n0 (Endo e) = Endo (\a0 ->
+      -- We check separately for 0 and 1 per
+      -- https://github.com/haskell/core-libraries-committee/issues/4#issuecomment-955605592
+      -- We are explicitly strict in the number so strictness is calculated
+      -- correctly even without specialization.
+      case n0 of
+        _ | n0 < 0 -> stimesEndoError
+        0 -> a0
+        1 -> e a0
+        _ -> go n0 a0)
+      where
+        go !0 a = a
+        go n a = e (go (n - 1) a)
+
+{-# NOINLINE stimesEndoError #-}
+-- There's no reason to put this gunk in the unfolding.
+stimesEndoError :: a
+stimesEndoError = errorWithoutStackTrace "stimes (for Endo): negative multiplier"
+
+-- Note [stimes Endo]
+-- ~~~~~~~~~~~~~~~~~~
+--
+-- We used to use
+--
+--   stimes = stimesMonoid
+--
+-- But this is pretty bad! The function it produces is represented in memory as
+-- a balanced tree of compositions. To actually *apply* that function, it's
+-- necessary to walk the tree. It's much better to just construct a function
+-- that counts out applications.
+--
+-- Why do we break open the `Endo` construction rather than just using `mempty`
+-- and `<>`? We want GHC to infer that `stimes` has an arity of 3. Currently,
+-- it does so by default, but there has been some talk in the past of turning
+-- on -fpedantic-bottoms, which would drop the arity to 2. Indeed, if we were
+-- really careless, we could theoretically get GHC to build a *list* of
+-- compositions, which would be awful.
 
 -- | @since 2.01
 instance Monoid (Endo a) where


=====================================
libraries/base/tests/all.T
=====================================
@@ -317,3 +317,4 @@ test('T23697',
   [ when(opsys('mingw32'), skip) # header not found
   , when(opsys('darwin'), skip)  # permission denied
   ], makefile_test, ['T23697'])
+test('stimesEndo', normal, compile_and_run, [''])


=====================================
libraries/base/tests/stimesEndo.hs
=====================================
@@ -0,0 +1,9 @@
+module Main where
+
+import Data.Semigroup
+
+adder :: Int -> Endo Int
+adder n = stimes n (Endo (+ 1))
+
+main :: IO ()
+main = print $ map (\n -> appEndo (adder n) 0) [0 .. 5]


=====================================
libraries/base/tests/stimesEndo.stdout
=====================================
@@ -0,0 +1 @@
+[0,1,2,3,4,5]


=====================================
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 }))]


=====================================
testsuite/tests/stranal/sigs/T6070.hs
=====================================
@@ -0,0 +1,13 @@
+module T6070 where
+
+import qualified Data.Map as M
+
+-- Should unbox `x`, so signature 1!P(..,..)
+h :: (Int, Int) -> Int -> (Int, Int)
+h x y = if y > 10
+         then x
+         else h (case h x 0 of (y1, y2) -> (y2, y1)) (y + 1)
+
+-- Should unbox `(a,b)`, so signature 1!P(..,..)
+c :: M.Map Int Int -> (Int, Int)
+c m = M.foldrWithKey (\k v (a, b) -> if k + v > 2 then (a, b) else (b, a)) (0, 1) m


=====================================
testsuite/tests/stranal/sigs/T6070.stderr
=====================================
@@ -0,0 +1,18 @@
+
+==================== Strictness signatures ====================
+T6070.c: <1L>
+T6070.h: <1!P(L,L)><1!P(L)>
+
+
+
+==================== Cpr signatures ====================
+T6070.c: 1
+T6070.h: 1
+
+
+
+==================== Strictness signatures ====================
+T6070.c: <1L>
+T6070.h: <1!P(L,L)><1!P(L)>
+
+


=====================================
testsuite/tests/stranal/sigs/all.T
=====================================
@@ -18,6 +18,7 @@ test('DmdAnalGADTs', normal, compile, [''])
 test('T12370', normal, compile, [''])
 test('NewtypeArity', normal, compile, [''])
 test('T5075', normal, compile, [''])
+test('T6070', normal, compile, [''])
 test('T17932', normal, compile, [''])
 test('T13380c', expect_broken('!3014'), compile, [''])
 test('T13380f', normal, compile, [''])


=====================================
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"
 


=====================================
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


=====================================
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


=====================================
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"
 
 -- ---------------------------------------------------------------------


=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit a70ba4918b8a65abd18b16f414b6e2c3c4e38c46
+Subproject commit 96e713f7768926dab4aeec5175c1854057a833c9



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cee9bb14e6c76c27b702f8b50084435f7e20cf84...d9475af88d267c7dcb79ec54dff55cb0c6842860

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cee9bb14e6c76c27b702f8b50084435f7e20cf84...d9475af88d267c7dcb79ec54dff55cb0c6842860
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20231121/375b7c26/attachment-0001.html>


More information about the ghc-commits mailing list