[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: EPA: print doc comments as normal comments
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Oct 31 11:42:41 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
723bc352 by Alan Zimmerman at 2023-10-30T20:36:41-04:00
EPA: print doc comments as normal comments
And ignore the ones allocated in haddock processing.
It does not guarantee that every original haddock-like comment appears
in the output, as it discards ones that have no legal attachment point.
closes #23459
- - - - -
21b76843 by Simon Peyton Jones at 2023-10-30T20:37:17-04:00
Fix non-termination bug in equality solver
constraint left-to-right then right to left, forever.
Easily fixed.
- - - - -
270867ac by Sebastian Graf at 2023-10-30T20:37:52-04:00
ghc-toolchain: build with `-package-env=-` (#24131)
Otherwise globally installed libraries (via `cabal install --lib`)
break the build.
Fixes #24131.
- - - - -
5a759e85 by Krzysztof Gogolewski at 2023-10-31T07:42:27-04:00
docs: fix ScopedTypeVariables example (#24101)
The previous example didn't compile.
Furthermore, it wasn't demonstrating the point properly.
I have changed it to an example which shows that 'a' in the signature
must be the same 'a' as in the instance head.
- - - - -
7b06e3b1 by Krzysztof Gogolewski at 2023-10-31T07:42:28-04:00
Fix pretty-printing of type family dependencies
"where" should be after the injectivity annotation.
- - - - -
14 changed files:
- compiler/GHC/Hs/DocString.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Tc/Solver/Equality.hs
- docs/users_guide/exts/scoped_type_variables.rst
- m4/ghc_toolchain.m4
- + testsuite/tests/indexed-types/should_compile/T24134.hs
- testsuite/tests/indexed-types/should_compile/all.T
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Preprocess.hs
- utils/check-exact/Utils.hs
Changes:
=====================================
compiler/GHC/Hs/DocString.hs
=====================================
@@ -21,6 +21,7 @@ module GHC.Hs.DocString
, renderHsDocStrings
, exactPrintHsDocString
, pprWithDocString
+ , printDecorator
) where
import GHC.Prelude
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -1067,8 +1067,9 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon
= vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind)
, hang (text "type family"
<+> pprIfaceDeclHead suppress_bndr_sig [] ss tycon binders
+ <+> pp_inj res_var inj
<+> ppShowRhs ss (pp_where rhs))
- 2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs))
+ 2 (ppShowRhs ss (pp_rhs rhs))
$$
nest 2 (ppShowRhs ss (pp_branches rhs))
]
=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -1721,12 +1721,16 @@ canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco
swap_for_size = typesSize fun_args2 > typesSize fun_args1
-- See Note [Orienting TyFamLHS/TyFamLHS]
- swap_for_rewriting = anyVarSet (isTouchableMetaTyVar tclvl) tvs2 &&
+ meta_tv_lhs = anyVarSet (isTouchableMetaTyVar tclvl) tvs1
+ meta_tv_rhs = anyVarSet (isTouchableMetaTyVar tclvl) tvs2
+ swap_for_rewriting = meta_tv_rhs && not meta_tv_lhs
-- See Note [Put touchable variables on the left]
- not (anyVarSet (isTouchableMetaTyVar tclvl) tvs1)
-- This second check is just to avoid unfruitful swapping
- ; if swap_for_rewriting || swap_for_size
+ -- It's important that we don't flip-flop (#T24134)
+ -- So swap_for_rewriting "wins", and we only try swap_for_size
+ -- if swap_for_rewriting doesn't care either way
+ ; if swap_for_rewriting || (meta_tv_lhs == meta_tv_rhs && swap_for_size)
then finish_with_swapping
else finish_without_swapping } }
where
@@ -1945,7 +1949,9 @@ canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs
-- If we had F a ~ G (F a), which gives an occurs check,
-- then swap it to G (F a) ~ F a, which does not
-- However `swap_for_size` above will orient it with (G (F a)) on
- -- the left anwyway, so the next four lines of code are redundant
+ -- the left anwyway. `swap_for_rewriting` "wins", but that doesn't
+ -- matter: in the occurs check case swap_for_rewriting will be moot.
+ -- TL;DR: the next four lines of code are redundant
-- I'm leaving them here in case they become relevant again
-- | TyFamLHS {} <- lhs
-- , Just can_rhs <- canTyFamEqLHS_maybe rhs
=====================================
docs/users_guide/exts/scoped_type_variables.rst
=====================================
@@ -293,11 +293,11 @@ signatures/ of the methods. For example, the following will be accepted without
explicitly enabling :extension:`ScopedTypeVariables`: ::
class D a where
- m :: [a] -> a
+ m :: a -> a
- instance D [a] where
+ instance Num a => D [a] where
m :: [a] -> [a]
- m = reverse
+ m x = map (*2) x
Note that writing ``m :: [a] -> [a]`` requires the use of the
:extension:`InstanceSigs` extension.
=====================================
m4/ghc_toolchain.m4
=====================================
@@ -148,6 +148,7 @@ AC_DEFUN([FIND_GHC_TOOLCHAIN_BIN],[
-ilibraries/ghc-platform/src -iutils/ghc-toolchain/src \
-XNoImplicitPrelude \
-odir actmp-ghc-toolchain -hidir actmp-ghc-toolchain \
+ -package-env=- \
utils/ghc-toolchain/exe/Main.hs -o acghc-toolchain || AC_MSG_ERROR([Could not compile ghc-toolchain])
GHC_TOOLCHAIN_BIN="./acghc-toolchain"
;;
=====================================
testsuite/tests/indexed-types/should_compile/T24134.hs
=====================================
@@ -0,0 +1,54 @@
+{-# LANGUAGE GHC2021 #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module M where
+import Data.Kind (Type)
+
+type F :: Type -> Type
+type family F
+
+type Prod :: Type -> Type -> Type
+type family Prod (a :: Type) (b :: Type) :: Type
+
+und :: F Int
+und = und
+
+f :: a -> Prod (F Int) a -> Prod a a
+f = f
+
+repMap :: Prod (F Int) (F Int) -> Prod (F Int) (F Int)
+repMap = f und
+
+
+{- This is what went wrong in GHC 9.8
+
+Inert: [W] Prod (F Int) a ~ Prod a a
+Work: [W] Prod (F Int) (F Int) ~ Prof (F Int) a
+
+---> rewrite with inert
+ [W] Prod (F Int) (F Int) ~ Prod a a
+---> swap (meta-var to left)
+ [W] Prod a a ~ Prod (F Int) (F Int)
+
+Kick out the inert
+
+Inert: [W] Prod a a ~ Prod (F Int) (F Int)
+Work: [W] Prod (F Int) a ~ Prod a a
+
+--> rewrite with inert
+ [W] Prod (F Int) a ~ Prod (F Int) (F Int)
+--> swap (size)
+ [W] Prod (F Int) (F Int) ~ Prod (F Int) a
+
+Kick out the inert
+
+Inert: [W] Prod (F Int) (F Int) ~ Prod (F Int) a
+Work: [W] Prod a a ~ Prod (F Int) (F Int)
+
+--> rewrite with inert
+ [W] Prod a a ~ Prod (F Int) a
+--> swap (size)
+ [W] Prof (F Int) a ~ Prod a a
+
+
+-}
=====================================
testsuite/tests/indexed-types/should_compile/all.T
=====================================
@@ -309,3 +309,4 @@ test('T22547', normal, compile, [''])
test('T22717', normal, makefile_test, ['T22717'])
test('T22717_fam_orph', normal, multimod_compile, ['T22717_fam_orph', '-v0'])
test('T23408', normal, compile, [''])
+test('T24134', normal, compile, [''])
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -1657,7 +1657,7 @@ module Data.Type.Bool where
forall k (tru :: k) (fls :: k). If GHC.Types.True tru fls = tru
forall k (tru :: k) (fls :: k). If GHC.Types.False tru fls = fls
type Not :: GHC.Types.Bool -> GHC.Types.Bool
- type family Not a where = res | res -> a
+ type family Not a = res | res -> a where
Not GHC.Types.False = GHC.Types.True
Not GHC.Types.True = GHC.Types.False
type (||) :: GHC.Types.Bool -> GHC.Types.Bool -> GHC.Types.Bool
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -1657,7 +1657,7 @@ module Data.Type.Bool where
forall k (tru :: k) (fls :: k). If GHC.Types.True tru fls = tru
forall k (tru :: k) (fls :: k). If GHC.Types.False tru fls = fls
type Not :: GHC.Types.Bool -> GHC.Types.Bool
- type family Not a where = res | res -> a
+ type family Not a = res | res -> a where
Not GHC.Types.False = GHC.Types.True
Not GHC.Types.True = GHC.Types.False
type (||) :: GHC.Types.Bool -> GHC.Types.Bool -> GHC.Types.Bool
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -1657,7 +1657,7 @@ module Data.Type.Bool where
forall k (tru :: k) (fls :: k). If GHC.Types.True tru fls = tru
forall k (tru :: k) (fls :: k). If GHC.Types.False tru fls = fls
type Not :: GHC.Types.Bool -> GHC.Types.Bool
- type family Not a where = res | res -> a
+ type family Not a = res | res -> a where
Not GHC.Types.False = GHC.Types.True
Not GHC.Types.True = GHC.Types.False
type (||) :: GHC.Types.Bool -> GHC.Types.Bool -> GHC.Types.Bool
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -1657,7 +1657,7 @@ module Data.Type.Bool where
forall k (tru :: k) (fls :: k). If GHC.Types.True tru fls = tru
forall k (tru :: k) (fls :: k). If GHC.Types.False tru fls = fls
type Not :: GHC.Types.Bool -> GHC.Types.Bool
- type family Not a where = res | res -> a
+ type family Not a = res | res -> a where
Not GHC.Types.False = GHC.Types.True
Not GHC.Types.True = GHC.Types.False
type (||) :: GHC.Types.Bool -> GHC.Types.Bool -> GHC.Types.Bool
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -32,6 +32,7 @@ module ExactPrint
) where
import GHC
+import GHC.Base (NonEmpty(..))
import GHC.Core.Coercion.Axiom (Role(..))
import GHC.Data.Bag
import qualified GHC.Data.BooleanFormula as BF
@@ -366,7 +367,7 @@ enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do
when (flush == NoFlushComments) $ do
when ((getFollowingComments cs) /= []) $ do
debugM $ "starting trailing comments:" ++ showAst (getFollowingComments cs)
- mapM_ printOneComment (map tokComment $ getFollowingComments cs)
+ mapM_ printOneComment (concatMap tokComment $ getFollowingComments cs)
debugM $ "ending trailing comments"
eof <- getEofPos
@@ -393,7 +394,7 @@ enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do
-- ---------------------------------------------------------------------
addCommentsA :: (Monad m, Monoid w) => [LEpaComment] -> EP w m ()
-addCommentsA csNew = addComments (map tokComment csNew)
+addCommentsA csNew = addComments (concatMap tokComment csNew)
{-
TODO: When we addComments, some may have an anchor that is no longer
@@ -547,7 +548,7 @@ printStringAtAAC :: (Monad m, Monoid w)
=> CaptureComments -> EpaLocation -> String -> EP w m EpaLocation
printStringAtAAC capture (EpaSpan r _) s = printStringAtRsC capture r s
printStringAtAAC capture (EpaDelta d cs) s = do
- mapM_ (printOneComment . tokComment) cs
+ mapM_ printOneComment $ concatMap tokComment cs
pe1 <- getPriorEndD
p1 <- getPosP
printStringAtLsDelta d s
@@ -1357,7 +1358,7 @@ instance ExactPrint (HsModule GhcPs) where
exact hsmod@(HsModule {hsmodExt = XModulePs { hsmodAnn = EpAnnNotUsed }}) = withPpr hsmod >> return hsmod
exact (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) = do
- mbDoc' <- markAnnotated mbDoc
+ let mbDoc' = mbDoc
(an0, mmn' , mdeprec', mexports') <-
case mmn of
@@ -1382,7 +1383,7 @@ instance ExactPrint (HsModule GhcPs) where
am_decls' <- markTrailing (am_decls $ anns an0)
imports' <- markTopLevelList imports
- decls' <- markTopLevelList decls
+ decls' <- markTopLevelList (filter removeDocDecl decls)
lo1 <- case lo0 of
ExplicitBraces open close -> do
@@ -1402,6 +1403,11 @@ instance ExactPrint (HsModule GhcPs) where
return (HsModule (XModulePs anf lo1 mdeprec' mbDoc') mmn' mexports' imports' decls')
+
+removeDocDecl :: LHsDecl GhcPs -> Bool
+removeDocDecl (L _ DocD{}) = False
+removeDocDecl _ = True
+
-- ---------------------------------------------------------------------
instance ExactPrint ModuleName where
@@ -1533,9 +1539,27 @@ instance ExactPrint (ImportDecl GhcPs) where
instance ExactPrint HsDocString where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ = a
- exact ds = do
- (printStringAdvance . exactPrintHsDocString) ds
- return ds
+
+ exact (MultiLineDocString decorator (x :| xs)) = do
+ printStringAdvance ("-- " ++ printDecorator decorator)
+ pe <- getPriorEndD
+ debugM $ "MultiLineDocString: (pe,x)=" ++ showAst (pe,x)
+ x' <- markAnnotated x
+ xs' <- markAnnotated (map dedentDocChunk xs)
+ return (MultiLineDocString decorator (x' :| xs'))
+ exact x = do
+ -- TODO: can this happen?
+ debugM $ "Not exact printing:" ++ showAst x
+ return x
+
+
+instance ExactPrint HsDocStringChunk where
+ getAnnotationEntry _ = NoEntryVal
+ setAnnotationAnchor a _ _ = a
+ exact chunk = do
+ printStringAdvance ("--" ++ unpackHDSC chunk)
+ return chunk
+
instance ExactPrint a => ExactPrint (WithHsDocIdentifiers a GhcPs) where
getAnnotationEntry _ = NoEntryVal
@@ -1895,11 +1919,8 @@ instance ExactPrint (DocDecl GhcPs) where
getAnnotationEntry = const NoEntryVal
setAnnotationAnchor a _ _ = a
- exact v = case v of
- (DocCommentNext ds) -> DocCommentNext <$> exact ds
- (DocCommentPrev ds) -> DocCommentPrev <$> exact ds
- (DocCommentNamed s ds) -> DocCommentNamed s <$> exact ds
- (DocGroup i ds) -> DocGroup i <$> exact ds
+ -- We print these as plain comments instead, do a NOP here.
+ exact v = return v
-- ---------------------------------------------------------------------
@@ -3936,8 +3957,7 @@ instance ExactPrint (HsType GhcPs) where
return (HsSpliceTy a splice')
exact (HsDocTy an ty doc) = do
ty' <- markAnnotated ty
- doc' <- markAnnotated doc
- return (HsDocTy an ty' doc')
+ return (HsDocTy an ty' doc)
exact (HsBangTy an (HsSrcBang mt up str) ty) = do
an0 <-
case mt of
@@ -4246,7 +4266,6 @@ instance ExactPrint (ConDecl GhcPs) where
, con_mb_cxt = mcxt
, con_args = args
, con_doc = doc }) = do
- doc' <- mapM markAnnotated doc
an0 <- if has_forall
then markEpAnnL an lidl AnnForall
else return an
@@ -4266,11 +4285,11 @@ instance ExactPrint (ConDecl GhcPs) where
, con_ex_tvs = ex_tvs'
, con_mb_cxt = mcxt'
, con_args = args'
- , con_doc = doc' })
+ , con_doc = doc })
where
- -- -- In ppr_details: let's not print the multiplicities (they are always 1, by
- -- -- definition) as they do not appear in an actual declaration.
+ -- In ppr_details: let's not print the multiplicities (they are always 1, by
+ -- definition) as they do not appear in an actual declaration.
exact_details (InfixCon t1 t2) = do
t1' <- markAnnotated t1
con' <- markAnnotated con
@@ -4294,7 +4313,6 @@ instance ExactPrint (ConDecl GhcPs) where
, con_bndrs = bndrs
, con_mb_cxt = mcxt, con_g_args = args
, con_res_ty = res_ty, con_doc = doc }) = do
- doc' <- mapM markAnnotated doc
cons' <- mapM markAnnotated cons
dcol' <- markUniToken dcol
an1 <- annotationsToComments an lidl [AnnOpenP, AnnCloseP]
@@ -4323,7 +4341,7 @@ instance ExactPrint (ConDecl GhcPs) where
, con_dcolon = dcol'
, con_bndrs = bndrs'
, con_mb_cxt = mcxt', con_g_args = args'
- , con_res_ty = res_ty', con_doc = doc' })
+ , con_res_ty = res_ty', con_doc = doc })
-- ---------------------------------------------------------------------
@@ -4359,8 +4377,8 @@ instance ExactPrint (ConDeclField GhcPs) where
names' <- markAnnotated names
an0 <- markEpAnnL an lidl AnnDcolon
ftype' <- markAnnotated ftype
- mdoc' <- mapM markAnnotated mdoc
- return (ConDeclField an0 names' ftype' mdoc')
+ -- mdoc' <- mapM markAnnotated mdoc
+ return (ConDeclField an0 names' ftype' mdoc)
-- ---------------------------------------------------------------------
@@ -4563,7 +4581,14 @@ instance ExactPrint (IE GhcPs) where
m' <- markAnnotated m
return (IEModuleContents (depr', an0) m')
- exact x = error $ "missing match for IE:" ++ showAst x
+ -- These three exist to not error out, but are no-ops The contents
+ -- appear as "normal" comments too, which we process instead.
+ exact (IEGroup x lev doc) = do
+ return (IEGroup x lev doc)
+ exact (IEDoc x doc) = do
+ return (IEDoc x doc)
+ exact (IEDocNamed x str) = do
+ return (IEDocNamed x str)
-- ---------------------------------------------------------------------
=====================================
utils/check-exact/Preprocess.hs
=====================================
@@ -124,8 +124,9 @@ getCppTokensAsComments cppOptions sourceFile = do
goodComment :: GHC.LEpaComment -> Bool
goodComment c = isGoodComment (tokComment c)
where
- isGoodComment :: Comment -> Bool
- isGoodComment (Comment "" _ _ _) = False
+ isGoodComment :: [Comment] -> Bool
+ isGoodComment [] = False
+ isGoodComment [Comment "" _ _ _] = False
isGoodComment _ = True
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -36,6 +36,7 @@ import GHC.Types.SrcLoc
import GHC.Driver.Ppr
import GHC.Data.FastString
import qualified GHC.Data.Strict as Strict
+import GHC.Base (NonEmpty(..))
import Data.Data hiding ( Fixity )
import Data.List (sortBy, elemIndex)
@@ -236,8 +237,47 @@ ghcCommentText (L _ (GHC.EpaComment (EpaLineComment s) _)) = s
ghcCommentText (L _ (GHC.EpaComment (EpaBlockComment s) _)) = s
ghcCommentText (L _ (GHC.EpaComment (EpaEofComment) _)) = ""
-tokComment :: LEpaComment -> Comment
-tokComment t@(L lt c) = mkComment (normaliseCommentText $ ghcCommentText t) lt (ac_prior_tok c)
+tokComment :: LEpaComment -> [Comment]
+tokComment t@(L lt c) =
+ case c of
+ (GHC.EpaComment (EpaDocComment dc) pt) -> hsDocStringComments lt pt dc
+ _ -> [mkComment (normaliseCommentText (ghcCommentText t)) lt (ac_prior_tok c)]
+
+hsDocStringComments :: Anchor -> RealSrcSpan -> GHC.HsDocString -> [Comment]
+hsDocStringComments _ pt (MultiLineDocString dec (x :| xs)) =
+ let
+ decStr = printDecorator dec
+ L lx x' = dedentDocChunkBy (3 + length decStr) x
+ str = "-- " ++ decStr ++ unpackHDSC x'
+ docChunk _ [] = []
+ docChunk pt' (L l chunk:cs)
+ = Comment ("--" ++ unpackHDSC chunk) (spanAsAnchor l) pt' Nothing : docChunk (rs l) cs
+ in
+ (Comment str (spanAsAnchor lx) pt Nothing : docChunk (rs lx) (map dedentDocChunk xs))
+hsDocStringComments anc pt (NestedDocString dec@(HsDocStringNamed _) (L _ chunk))
+ = [Comment ("{- " ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") anc pt Nothing ]
+hsDocStringComments anc pt (NestedDocString dec (L _ chunk))
+ = [Comment ("{-" ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") anc pt Nothing ]
+
+hsDocStringComments _ _ (GeneratedDocString _) = [] -- Should not appear in user-written code
+
+-- At the moment the locations of the 'HsDocStringChunk's are from the start of
+-- the string part, leaving aside the "--". So we need to subtract 2 columns from it
+dedentDocChunk :: LHsDocStringChunk -> LHsDocStringChunk
+dedentDocChunk chunk = dedentDocChunkBy 2 chunk
+
+dedentDocChunkBy :: Int -> LHsDocStringChunk -> LHsDocStringChunk
+dedentDocChunkBy dedent (L (RealSrcSpan l mb) c) = L (RealSrcSpan l' mb) c
+ where
+ f = srcSpanFile l
+ sl = srcSpanStartLine l
+ sc = srcSpanStartCol l
+ el = srcSpanEndLine l
+ ec = srcSpanEndCol l
+ l' = mkRealSrcSpan (mkRealSrcLoc f sl (sc - dedent))
+ (mkRealSrcLoc f el (ec - dedent))
+
+dedentDocChunkBy _ x = x
mkEpaComments :: [Comment] -> [Comment] -> EpAnnComments
mkEpaComments priorCs []
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/78060ce1fbfbda1ac76b3095f1f9e9bf6d95e8e5...7b06e3b1571743d4b8b2d3fbb66143004310d2fe
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/78060ce1fbfbda1ac76b3095f1f9e9bf6d95e8e5...7b06e3b1571743d4b8b2d3fbb66143004310d2fe
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/20231031/c36ed51d/attachment-0001.html>
More information about the ghc-commits
mailing list