[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Speed up stimes in instance Semigroup Endo
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Nov 20 21:23:29 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
407daed0 by David Feuer at 2023-11-20T16:23:08-05:00
Speed up stimes in instance Semigroup Endo
As discussed at
https://github.com/haskell/core-libraries-committee/issues/4
- - - - -
1f7256d7 by Andrew Lelechenko at 2023-11-20T16:23:08-05:00
base: reflect latest changes in the changelog
- - - - -
eb8bcaee by Alan Zimmerman at 2023-11-20T16:23:08-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.
- - - - -
cee9bb14 by Sebastian Graf at 2023-11-20T16:23:09-05:00
Add regression test for #6070
Fixes #6070.
- - - - -
20 changed files:
- 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
- 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:
=====================================
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"
=====================================
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/7b4d8ba6b2d05fe10fc29b13cd377f01f6985458...cee9bb14e6c76c27b702f8b50084435f7e20cf84
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7b4d8ba6b2d05fe10fc29b13cd377f01f6985458...cee9bb14e6c76c27b702f8b50084435f7e20cf84
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/20231120/1d67b363/attachment-0001.html>
More information about the ghc-commits
mailing list