[Git][ghc/ghc][wip/az/epa-split-header-comments] 3 commits: Add heqT, a kind-heterogeneous variant of heq
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Mon Dec 12 19:40:48 UTC 2022
Alan Zimmerman pushed to branch wip/az/epa-split-header-comments at Glasgow Haskell Compiler / GHC
Commits:
b3e98a92 by Oleg Grenrus at 2022-12-11T12:26:17-05:00
Add heqT, a kind-heterogeneous variant of heq
CLC proposal https://github.com/haskell/core-libraries-committee/issues/99
- - - - -
bfd7c1e6 by Bodigrim at 2022-12-11T12:26:55-05:00
Document that Bifunctor instances for tuples are lawful only up to laziness
- - - - -
25724dca by Alan Zimmerman at 2022-12-12T19:40:08+00:00
EPA: When splitting out header comments, keep ones for first decl
Any comments immediately preceding the first declaration are no longer
kept as header comments, but attach to the first declaration instead.
- - - - -
8 changed files:
- compiler/GHC/Parser/Lexer.x
- libraries/base/Data/Bifunctor.hs
- libraries/base/Data/Typeable.hs
- libraries/base/changelog.md
- testsuite/tests/ghc-api/exactprint/Test20239.stderr
- testsuite/tests/parser/should_compile/DumpParsedAstComments.hs
- testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
- testsuite/tests/printer/Ppr031.hs
Changes:
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -3676,6 +3676,25 @@ allocateComments ss comment_q =
in
(comment_q', reverse newAnns)
+-- Comments appearing without a line-break before the first
+-- declaration are associated with the declaration
+splitPriorComments
+ :: RealSrcSpan
+ -> [LEpaComment]
+ -> ([LEpaComment], [LEpaComment])
+splitPriorComments ss prior_comments =
+ let
+ -- True if there is only one line between the earlier and later span
+ cmp later earlier
+ = srcSpanStartLine later - srcSpanEndLine earlier == 1
+
+ go decl _ [] = ([],decl)
+ go decl r (c@(L l _):cs) = if cmp r (anchor l)
+ then go (c:decl) (anchor l) cs
+ else (reverse (c:cs), decl)
+ in
+ go [] ss prior_comments
+
allocatePriorComments
:: RealSrcSpan
-> [LEpaComment]
@@ -3684,12 +3703,13 @@ allocatePriorComments
allocatePriorComments ss comment_q mheader_comments =
let
cmp (L l _) = anchor l <= ss
- (before,after) = partition cmp comment_q
- newAnns = before
+ (newAnns,after) = partition cmp comment_q
comment_q'= after
+ (prior_comments, decl_comments) = splitPriorComments ss newAnns
in
case mheader_comments of
- Strict.Nothing -> (Strict.Just (reverse newAnns), comment_q', [])
+ Strict.Nothing -> (Strict.Just prior_comments, comment_q', decl_comments)
+ -- Strict.Nothing -> (Strict.Just [], comment_q', newAnns)
Strict.Just _ -> (mheader_comments, comment_q', reverse newAnns)
allocateFinalComments
=====================================
libraries/base/Data/Bifunctor.hs
=====================================
@@ -120,8 +120,17 @@ class (forall a. Functor (p a)) => Bifunctor p where
second = bimap id
-
--- | @since 4.8.0.0
+-- | Class laws for tuples hold only up to laziness. Both
+-- 'first' 'id' and 'second' 'id' are lazier than 'id' (and 'fmap' 'id'):
+--
+-- >>> first id (undefined :: (Int, Word)) `seq` ()
+-- ()
+-- >>> second id (undefined :: (Int, Word)) `seq` ()
+-- ()
+-- >>> id (undefined :: (Int, Word)) `seq` ()
+-- *** Exception: Prelude.undefined
+--
+-- @since 4.8.0.0
instance Bifunctor (,) where
bimap f g ~(a, b) = (f a, g b)
=====================================
libraries/base/Data/Typeable.hs
=====================================
@@ -4,6 +4,7 @@
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
-----------------------------------------------------------------------------
@@ -56,6 +57,7 @@ module Data.Typeable
-- * Type-safe cast
, cast
, eqT
+ , heqT
, gcast -- a generalisation of cast
-- * Generalized casts for higher-order kinds
@@ -135,8 +137,14 @@ cast x
-- @since 4.7.0.0
eqT :: forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT
- | Just HRefl <- ta `I.eqTypeRep` tb = Just Refl
- | otherwise = Nothing
+ | Just HRefl <- heqT @a @b = Just Refl
+ | otherwise = Nothing
+
+-- | Extract a witness of heterogeneous equality of two types
+--
+-- @since 4.18.0.0
+heqT :: forall a b. (Typeable a, Typeable b) => Maybe (a :~~: b)
+heqT = ta `I.eqTypeRep` tb
where
ta = I.typeRep :: I.TypeRep a
tb = I.typeRep :: I.TypeRep b
=====================================
libraries/base/changelog.md
=====================================
@@ -57,6 +57,7 @@
of individually allocated pointers as well as freeing each one of them when
freeing a `Pool`. (#14762) (#18338)
* `Type.Reflection.Unsafe` is now marked as unsafe.
+ * Add `Data.Typeable.heqT`, a kind-heterogeneous version of `Data.Typeable.eqT`.
## 4.17.0.0 *August 2022*
=====================================
testsuite/tests/ghc-api/exactprint/Test20239.stderr
=====================================
@@ -19,14 +19,7 @@
[]
[]))
(EpaCommentsBalanced
- [(L
- (Anchor
- { Test20239.hs:3:1-28 }
- (UnchangedAnchor))
- (EpaComment
- (EpaLineComment
- "-- | Leading Haddock Comment")
- { Test20239.hs:1:18-22 }))]
+ []
[(L
(Anchor
{ Test20239.hs:8:1 }
@@ -53,6 +46,14 @@
[])
(EpaComments
[(L
+ (Anchor
+ { Test20239.hs:3:1-28 }
+ (UnchangedAnchor))
+ (EpaComment
+ (EpaLineComment
+ "-- | Leading Haddock Comment")
+ { Test20239.hs:1:18-22 }))
+ ,(L
(Anchor
{ Test20239.hs:7:34-63 }
(UnchangedAnchor))
=====================================
testsuite/tests/parser/should_compile/DumpParsedAstComments.hs
=====================================
@@ -4,6 +4,10 @@
-}
module DumpParsedAstComments where
+-- Other comment
+
+-- comment 1 for foo
+-- comment 2 for foo
foo = do
-- normal comment
1
=====================================
testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
=====================================
@@ -34,15 +34,23 @@
(UnchangedAnchor))
(EpaComment
(EpaBlockComment
- "{-\n Block comment at the beginning\n -}")
- { DumpParsedAstComments.hs:1:1-28 }))]
+ "{-/n Block comment at the beginning/n -}")
+ { DumpParsedAstComments.hs:1:1-28 }))
+ ,(L
+ (Anchor
+ { DumpParsedAstComments.hs:7:1-16 }
+ (UnchangedAnchor))
+ (EpaComment
+ (EpaLineComment
+ "-- Other comment")
+ { DumpParsedAstComments.hs:5:30-34 }))]
[(L
(Anchor
- { DumpParsedAstComments.hs:13:1 }
+ { DumpParsedAstComments.hs:17:1 }
(UnchangedAnchor))
(EpaComment
(EpaEofComment)
- { DumpParsedAstComments.hs:13:1 }))]))
+ { DumpParsedAstComments.hs:17:1 }))]))
(VirtualBraces
(1))
(Nothing)
@@ -56,47 +64,63 @@
[(L
(SrcSpanAnn (EpAnn
(Anchor
- { DumpParsedAstComments.hs:(7,1)-(9,3) }
+ { DumpParsedAstComments.hs:(11,1)-(13,3) }
(UnchangedAnchor))
(AnnListItem
[])
(EpaComments
[(L
(Anchor
- { DumpParsedAstComments.hs:11:1-20 }
+ { DumpParsedAstComments.hs:9:1-20 }
+ (UnchangedAnchor))
+ (EpaComment
+ (EpaLineComment
+ "-- comment 1 for foo")
+ { DumpParsedAstComments.hs:7:1-16 }))
+ ,(L
+ (Anchor
+ { DumpParsedAstComments.hs:10:1-20 }
+ (UnchangedAnchor))
+ (EpaComment
+ (EpaLineComment
+ "-- comment 2 for foo")
+ { DumpParsedAstComments.hs:9:1-20 }))
+ ,(L
+ (Anchor
+ { DumpParsedAstComments.hs:15:1-20 }
(UnchangedAnchor))
(EpaComment
(EpaLineComment
"-- | Haddock comment")
- { DumpParsedAstComments.hs:9:3
- }))])) { DumpParsedAstComments.hs:(7,1)-(9,3) })
+ { DumpParsedAstComments.hs:13:3
+ }))])) { DumpParsedAstComments.hs:(11,1)-(13,3) })
(ValD
(NoExtField)
(FunBind
(NoExtField)
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:7:1-3 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:11:1-3 })
(Unqual
{OccName: foo}))
(MG
(FromSource)
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(7,1)-(9,3)
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(11,1)-(13,3)
})
[(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(7,1)-(9,3)
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(11,1)-(13,3)
})
(Match
(EpAnn
(Anchor
- { DumpParsedAstComments.hs:(7,1)-(9,3) }
+ { DumpParsedAstComments.hs:(11,1)-(13,3) }
(UnchangedAnchor))
[]
(EpaComments
[]))
(FunRhs
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:7:1-3 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:11:1-3 })
(Unqual
{OccName: foo}))
(Prefix)
@@ -108,72 +132,72 @@
[(L
(SrcSpanAnn
(EpAnnNotUsed)
- { DumpParsedAstComments.hs:(7,5)-(9,3) })
+ { DumpParsedAstComments.hs:(11,5)-(13,3) })
(GRHS
(EpAnn
(Anchor
- { DumpParsedAstComments.hs:(7,5)-(9,3) }
+ { DumpParsedAstComments.hs:(11,5)-(13,3) }
(UnchangedAnchor))
(GrhsAnn
(Nothing)
- (AddEpAnn AnnEqual (EpaSpan { DumpParsedAstComments.hs:7:5 })))
+ (AddEpAnn AnnEqual (EpaSpan { DumpParsedAstComments.hs:11:5 })))
(EpaComments
[]))
[]
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(7,7)-(9,3)
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(11,7)-(13,3)
})
(HsDo
(EpAnn
(Anchor
- { DumpParsedAstComments.hs:(7,7)-(9,3) }
+ { DumpParsedAstComments.hs:(11,7)-(13,3) }
(UnchangedAnchor))
(AnnList
(Just
(Anchor
- { DumpParsedAstComments.hs:9:3 }
+ { DumpParsedAstComments.hs:13:3 }
(UnchangedAnchor)))
(Nothing)
(Nothing)
- [(AddEpAnn AnnDo (EpaSpan { DumpParsedAstComments.hs:7:7-8 }))]
+ [(AddEpAnn AnnDo (EpaSpan { DumpParsedAstComments.hs:11:7-8 }))]
[])
(EpaComments
[(L
(Anchor
- { DumpParsedAstComments.hs:8:3-19 }
+ { DumpParsedAstComments.hs:12:3-19 }
(UnchangedAnchor))
(EpaComment
(EpaLineComment
"-- normal comment")
- { DumpParsedAstComments.hs:7:7-8 }))]))
+ { DumpParsedAstComments.hs:11:7-8 }))]))
(DoExpr
(Nothing))
(L
(SrcSpanAnn (EpAnn
(Anchor
- { DumpParsedAstComments.hs:9:3 }
+ { DumpParsedAstComments.hs:13:3 }
(UnchangedAnchor))
(AnnList
(Just
(Anchor
- { DumpParsedAstComments.hs:9:3 }
+ { DumpParsedAstComments.hs:13:3 }
(UnchangedAnchor)))
(Nothing)
(Nothing)
[]
[])
(EpaComments
- [])) { DumpParsedAstComments.hs:9:3 })
+ [])) { DumpParsedAstComments.hs:13:3 })
[(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:9:3 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:13:3 })
(BodyStmt
(NoExtField)
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:9:3 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:13:3 })
(HsOverLit
(EpAnn
(Anchor
- { DumpParsedAstComments.hs:9:3 }
+ { DumpParsedAstComments.hs:13:3 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -192,37 +216,37 @@
,(L
(SrcSpanAnn (EpAnn
(Anchor
- { DumpParsedAstComments.hs:12:1-23 }
+ { DumpParsedAstComments.hs:16:1-23 }
(UnchangedAnchor))
(AnnListItem
[])
(EpaComments
- [])) { DumpParsedAstComments.hs:12:1-23 })
+ [])) { DumpParsedAstComments.hs:16:1-23 })
(ValD
(NoExtField)
(FunBind
(NoExtField)
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:1-4 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:1-4 })
(Unqual
{OccName: main}))
(MG
(FromSource)
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:1-23 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:1-23 })
[(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:1-23 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:1-23 })
(Match
(EpAnn
(Anchor
- { DumpParsedAstComments.hs:12:1-23 }
+ { DumpParsedAstComments.hs:16:1-23 }
(UnchangedAnchor))
[]
(EpaComments
[]))
(FunRhs
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:1-4 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:1-4 })
(Unqual
{OccName: main}))
(Prefix)
@@ -234,42 +258,42 @@
[(L
(SrcSpanAnn
(EpAnnNotUsed)
- { DumpParsedAstComments.hs:12:6-23 })
+ { DumpParsedAstComments.hs:16:6-23 })
(GRHS
(EpAnn
(Anchor
- { DumpParsedAstComments.hs:12:6-23 }
+ { DumpParsedAstComments.hs:16:6-23 }
(UnchangedAnchor))
(GrhsAnn
(Nothing)
- (AddEpAnn AnnEqual (EpaSpan { DumpParsedAstComments.hs:12:6 })))
+ (AddEpAnn AnnEqual (EpaSpan { DumpParsedAstComments.hs:16:6 })))
(EpaComments
[]))
[]
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:8-23 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:8-23 })
(HsApp
(EpAnn
(Anchor
- { DumpParsedAstComments.hs:12:8-23 }
+ { DumpParsedAstComments.hs:16:8-23 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
[]))
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:8-15 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:8-15 })
(HsVar
(NoExtField)
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:8-15 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:8-15 })
(Unqual
{OccName: putStrLn}))))
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:17-23 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:17-23 })
(HsLit
(EpAnn
(Anchor
- { DumpParsedAstComments.hs:12:17-23 }
+ { DumpParsedAstComments.hs:16:17-23 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
=====================================
testsuite/tests/printer/Ppr031.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE ImplicitParams, NamedFieldPuns, ParallelListComp, PatternGuards #-}
+
spec :: Spec
spec = do
describe "split4'8" $ do
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1775cef810d20917eda7eeca1e7c5f50eca2c95e...25724dcaa5c3d38e72912c83f0d86a4b07f39b4d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1775cef810d20917eda7eeca1e7c5f50eca2c95e...25724dcaa5c3d38e72912c83f0d86a4b07f39b4d
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/20221212/526c57de/attachment-0001.html>
More information about the ghc-commits
mailing list