[Git][ghc/ghc][wip/27183] changelog-d: Add support for emitting markdown for library changelogs
by Zubin (＠wz1000) 28 Apr '26
by Zubin (＠wz1000) 28 Apr '26
28 Apr '26
Zubin pushed to branch wip/27183 at Glasgow Haskell Compiler / GHC
Commits:
84998393 by Zubin Duggal at 2026-04-28T17:11:45+05:30
changelog-d: Add support for emitting markdown for library changelogs
Now library changelog entries are written in changelog.d/ uniformly, and the
changelog-d tool gains functionality to output markdown fragments for the
library changelog files. The fragments will be spliced into the respective files
at release time by the release manager.
Also changes the lint-changelog CI job to ensure that changes which touch base
have a changelog entry and a CLC proposal.
Fixes #27183
- - - - -
12 changed files:
- .gitlab-ci.yml
- .gitlab/merge_request_templates/Default.md
- changelog.d/config
- docs/users_guide/ghc_config.py.in
- hadrian/src/Rules/Changelog.hs
- libraries/integer-gmp/integer-gmp.cabal
- testsuite/tests/linters/Makefile
- utils/changelog-d/ChangelogD.hs
- utils/changelog-d/README.md
- + utils/changelog-d/tests/config
- + utils/changelog-d/tests/expected/test-parser-rewriter.md
- + utils/changelog-d/tests/test-parser-rewriter
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -247,6 +247,9 @@ ghc-linters:
# Check that MRs include a changelog entry in changelog.d/.
# Skipped if the MR has the ~"no-changelog" label.
+#
+# If MR's diff touches libraries/base/, the changelog must also have a non-empty
+# `clc:` field.
lint-changelog:
stage: tool-lint
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV"
@@ -254,6 +257,7 @@ lint-changelog:
variables:
BUILD_FLAVOUR: default
CHANGELOG_EXPECT_MR: "$CI_MERGE_REQUEST_IID"
+ CHANGELOG_EXPECT_CLC: ""
script:
# Check that the MR adds at least one changelog entry
- git fetch "$CI_MERGE_REQUEST_PROJECT_URL" "$CI_MERGE_REQUEST_TARGET_BRANCH_NAME"
@@ -276,6 +280,10 @@ lint-changelog:
when: never
- if: '$CI_MERGE_REQUEST_LABELS =~ /.*no-changelog.*/'
when: never
+ - changes:
+ - libraries/base/**/*
+ variables:
+ CHANGELOG_EXPECT_CLC: "1"
- if: $CI_MERGE_REQUEST_ID
- *drafts-can-fail-lint
=====================================
.gitlab/merge_request_templates/Default.md
=====================================
@@ -23,7 +23,8 @@ https://gitlab.haskell.org/ghc/ghc/-/wikis/Contributing-a-Patch
- [ ] This MR solves the problem described in the following issue: <!-- issue number here (please open a new issue if there isn't one) -->
- [ ] A changelog entry was added in `changelog.d/` for user-facing changes (see [changelog guide][changelog]).
If this MR does not need a changelog entry, the ~"no-changelog" label was applied.
-- [ ] This MR does not make any significant changes to `base`, or it has an accompanying [CLC proposal](https://github.com/haskell/core-libraries-committee#base-package).
+- [ ] This MR does not make any significant changes to `base`, or it has an accompanying [CLC proposal](https://github.com/haskell/core-libraries-committee#base-package)
+ and the changelog fragment uses `section: base` with the `clc: #<proposal>` field set.
- [ ] If this MR has the potential to break user programs, the ~"user-facing" label was applied to
test against head.hackage.
- [ ] All commits are either individually buildable or squashed.
=====================================
changelog.d/config
=====================================
@@ -27,6 +27,7 @@ sections: {
cmm Cmm
build-tools Build tools
base ``base`` library
+ ghc-internal ``ghc-internal`` library
ghc-prim ``ghc-prim`` library
ghc-lib ``ghc`` library
ghc-heap ``ghc-heap`` library
@@ -36,6 +37,18 @@ sections: {
ghc-toolchain ``ghc-toolchain``
}
+-- markdown-targets: sections that also need to end up in
+-- per-library changelog files. The optional third token
+-- lists extra fields that might be required for this section
+-- like `clc` for base.
+markdown-targets: {
+ base libraries/base/changelog.md clc
+ ghc-internal libraries/ghc-internal/CHANGELOG.md
+ ghc-prim libraries/ghc-prim/changelog.md
+ ghc-experimental libraries/ghc-experimental/CHANGELOG.md
+ template-haskell libraries/template-haskell/changelog.md
+}
+
included-libraries-preamble: {
The package database provided with this distribution also contains a number of
packages other than GHC itself. See the changelogs provided with these packages
=====================================
docs/users_guide/ghc_config.py.in
=====================================
@@ -7,12 +7,14 @@ if parse_version(sphinx.__version__) >= parse_version("4.0.0"):
'ghc-ticket': ('https://gitlab.haskell.org/ghc/ghc/issues/%s', '#%s'),
'ghc-wiki': ('https://gitlab.haskell.org/ghc/ghc/wikis/%s', '%s'),
'ghc-mr': ('https://gitlab.haskell.org/ghc/ghc/-/merge_requests/%s', '!%s'),
+ 'clc': ('https://github.com/haskell/core-libraries-committee/issues/%s', 'CLC proposal #%s'),
}
else:
extlinks = {
'ghc-ticket': ('https://gitlab.haskell.org/ghc/ghc/issues/%s', '#'),
'ghc-wiki': ('https://gitlab.haskell.org/ghc/ghc/wikis/%s', ''),
'ghc-mr': ('https://gitlab.haskell.org/ghc/ghc/-/merge_requests/%s', '!'),
+ 'clc': ('https://github.com/haskell/core-libraries-committee/issues/%s', 'CLC proposal #'),
}
libs_base_uri = '../libraries'
=====================================
hadrian/src/Rules/Changelog.hs
=====================================
@@ -11,8 +11,9 @@ import qualified System.Directory as IO
-- | Rules for generating and managing changelog entries.
--
-- Targets:
--- hadrian/build changelog -- generate release notes
+-- hadrian/build changelog -- generate RST release notes
-- hadrian/build changelog --changelog-version=10.2.1 -- with explicit version
+-- hadrian/build libraries-changelog-markdown -- emit per-library Markdown bullets to stdout
-- hadrian/build changelog-clear -- remove old entries
changelogRules :: Rules ()
changelogRules = do
@@ -25,19 +26,6 @@ changelogRules = do
ctx <- programContext stage0Boot changelogD
progPath <- programPath ctx
need [progPath]
-
- -- These cabal files are needed by changelog-d to determine the
- -- versions of packages shipped with GHC.
- let templatedCabalFiles = map pkgCabalFile
- [ ghcBoot
- , ghcBootTh
- , ghcExperimental
- , ghcInternal
- , ghci
- , compiler
- , ghcHeap
- , templateHaskell
- ]
need templatedCabalFiles
top <- topDirectory
@@ -47,6 +35,18 @@ changelogRules = do
:: Action ()
putSuccess $ "| Generated release notes: " ++ outFile
+ phony "libraries-changelog-markdown" $ do
+ ctx <- programContext stage0Boot changelogD
+ progPath <- programPath ctx
+ need [progPath]
+ need templatedCabalFiles
+
+ top <- topDirectory
+ cmd_ [progPath]
+ [ top -/- "changelog.d/"
+ , "--libraries-changelog-markdown"
+ ]
+
phony "changelog-clear" $ do
top <- topDirectory
let dir = top -/- "changelog.d"
@@ -54,3 +54,17 @@ changelogRules = do
let toRemove = filter (\f -> f /= "config" && not (isPrefixOf "." f)) entries
liftIO $ mapM_ (IO.removeFile . (dir -/-)) toRemove
putSuccess $ "| Removed " ++ show (length toRemove) ++ " changelog entries"
+ where
+ -- These cabal files are needed by changelog-d to determine the
+ -- versions of packages shipped with GHC.
+ templatedCabalFiles = map pkgCabalFile
+ [ ghcBoot
+ , ghcBootTh
+ , ghcExperimental
+ , ghcInternal
+ , ghci
+ , compiler
+ , ghcHeap
+ , templateHaskell
+ , base
+ ]
=====================================
libraries/integer-gmp/integer-gmp.cabal
=====================================
@@ -13,6 +13,9 @@ build-type: Simple
homepage: https://www.haskell.org/ghc/
bug-reports: https://gitlab.haskell.org/ghc/ghc/issues/new
+extra-source-files:
+ changelog.md
+
description:
This package used to provide an implementation of the standard 'Integer'
type based on the
=====================================
testsuite/tests/linters/Makefile
=====================================
@@ -30,8 +30,12 @@ notes:
(cd $(TOP)/.. && $(LINT_NOTES) broken-refs)
changelog-d:
-ifdef CHANGELOG_EXPECT_MR
+ifneq "$(CHANGELOG_EXPECT_MR)" ""
+ifneq "$(CHANGELOG_EXPECT_CLC)" ""
+ (cd $(TOP)/.. && $(CHANGELOG_D) changelog.d/ --validate --expect-mr $(CHANGELOG_EXPECT_MR) --expect-clc)
+else
(cd $(TOP)/.. && $(CHANGELOG_D) changelog.d/ --validate --expect-mr $(CHANGELOG_EXPECT_MR))
+endif
else
(cd $(TOP)/.. && $(CHANGELOG_D) changelog.d/ --validate)
endif
=====================================
utils/changelog-d/ChangelogD.hs
=====================================
@@ -10,15 +10,15 @@
module Main (main) where
import Control.Exception (Exception (..))
-import Control.Monad (unless, void, when)
-import Data.Char (isSpace)
+import Control.Monad (filterM, unless, void, when)
+import Data.Char (isAlpha, isSpace)
import Data.Foldable (for_, toList, traverse_)
import Data.Function (on)
-import Data.List (intercalate, sort, sortBy)
+import Data.List (find, intercalate, isPrefixOf, isSuffixOf, sort, sortBy, stripPrefix)
import Data.Maybe (isJust, isNothing, mapMaybe)
import Data.Set (Set)
import Data.Traversable (for)
-import System.Directory (listDirectory)
+import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)
import System.Environment (getArgs)
import System.Exit (exitFailure)
import System.FilePath ((</>), dropTrailingPathSeparator, takeDirectory)
@@ -58,16 +58,35 @@ usage = unlines
, " Collect changelog entries and produce release notes."
, ""
, "Options:"
- , " --version <version> Version number for RST file header (e.g. 10.2.1)"
- , " --validate Validate entries only, no output"
- , " --expect-mr <N> Check that at least one entry references MR !N"
- , " --help Show this help"
+ , " --version <version> Version number for RST file header (e.g. 10.2.1)"
+ , " --validate Validate entries only, no output"
+ , " --expect-mr <N> Check that at least one entry references MR !N"
+ , " --expect-clc Require the entry matched by --expect-mr"
+ , " to have a non-empty 'clc:' field. Used by"
+ , " CI for MRs touching base."
+ , " --libraries-changelog-markdown Emit per-library Markdown bullets to"
+ , " stdout (suppresses RST emission). Output"
+ , " is intended to be pasted into each"
+ , " libraries/<lib>/changelog.md by hand;"
+ , " --section <key> Restrict --libraries-changelog-markdown"
+ , " to a single section. Without this, all"
+ , " configured markdown-targets are emitted,"
+ , " separated by HTML-comment markers."
+ , " --help Show this help"
]
parseArgs :: [String] -> Either String Opts
parseArgs = go defaultOpts
where
- defaultOpts = Opts "changelog.d" Nothing False Nothing
+ defaultOpts = Opts
+ { optDirectory = "changelog.d"
+ , optVersion = Nothing
+ , optValidate = False
+ , optExpectMR = Nothing
+ , optExpectCLC = False
+ , optMarkdown = False
+ , optMdSection = Nothing
+ }
go opts [] = Right opts
go _ ("--help" : _) = Left ""
@@ -78,6 +97,11 @@ parseArgs = go defaultOpts
[(mr, "")] -> go opts { optExpectMR = Just mr } rest
_ -> Left $ "--expect-mr requires a number, got: " ++ n
go _ ("--expect-mr" : []) = Left "--expect-mr requires an argument"
+ go opts ("--expect-clc" : rest) = go opts { optExpectCLC = True } rest
+ go opts ("--libraries-changelog-markdown" : rest) =
+ go opts { optMarkdown = True } rest
+ go opts ("--section" : s : rest) = go opts { optMdSection = Just s } rest
+ go _ ("--section" : []) = Left "--section requires an argument"
go _ (('-':'-':opt) : _) = Left $ "Unknown option: --" ++ opt
go _ (('-':opt) : _) = Left $ "Unknown option: -" ++ opt
go opts (dir : rest) = go opts { optDirectory = dir } rest
@@ -124,9 +148,14 @@ makeChangelog Opts {..} = do
either (exitWithExc . PlainError) return $
parseWith parseConfig filename contents
+ -- Read only regular files, skipping config, dotfiles, and any
+ -- subdirectories (e.g. golden-output dirs alongside test fragments).
dirContents <- filter (not . isTmpFile) <$> listDirectory optDirectory
+ fragmentNames <-
+ filterM (\name -> doesFileExist (optDirectory </> name))
+ (filter (/= "config") $ sort dirContents)
allEntries <- fmap Map.fromList $
- for (filter (/= "config") $ sort dirContents) $ \name -> do
+ for fragmentNames $ \name -> do
let fp = optDirectory </> name
contents <- BS.readFile fp
entry <- parseEntryFile fp contents
@@ -140,17 +169,38 @@ makeChangelog Opts {..} = do
exitWithExc $ PlainError "Validation failed."
-- Check expected MR number if specified
- for_ optExpectMR $ \expectedMR -> do
- let expectedMRNum = MRNumber expectedMR
- entriesWithMR = Map.filter (\e -> expectedMRNum `Set.member` entryMrs e) allEntries
- when (Map.null entriesWithMR && not (Map.null allEntries)) $ do
- hPutStrLn stderr $ "Warning: No changelog entry references this MR (!" ++ show expectedMR ++ ")."
- hPutStrLn stderr $ "Add 'mrs: !" ++ show expectedMR ++ "' to your changelog entry."
- hPutStrLn stderr ""
- exitFailure
+ matchedByMR <- case optExpectMR of
+ Nothing -> pure Map.empty
+ Just expectedMR -> do
+ let expectedMRNum = MRNumber expectedMR
+ withMR = Map.filter (\e -> expectedMRNum `Set.member` entryMrs e) allEntries
+ when (Map.null withMR && not (Map.null allEntries)) $ do
+ hPutStrLn stderr $ "Warning: No changelog entry references this MR (!" ++ show expectedMR ++ ")."
+ hPutStrLn stderr $ "Add 'mrs: !" ++ show expectedMR ++ "' to your changelog entry."
+ hPutStrLn stderr ""
+ exitFailure
+ pure withMR
+
+ -- --expect-clc: assert that the MR-matched entry has clc: set.
+ when optExpectCLC $ case optExpectMR of
+ Nothing -> exitWithExc $ PlainError
+ "--expect-clc requires --expect-mr (which entry to check?)"
+ Just expectedMR ->
+ when (not (Map.null matchedByMR)
+ && all (Set.null . entryClcs) matchedByMR) $ do
+ hPutStrLn stderr $
+ "Error: changelog entry for !" ++ show expectedMR
+ ++ " does not have a 'clc:' field."
+ hPutStrLn stderr
+ "Changes to base or user-facing changes require a CLC proposal."
+ hPutStrLn stderr "Add 'clc: #<proposal>' to your changelog entry."
+ exitFailure
unless optValidate $
- outputRST optDirectory optVersion cfg (Map.elems allEntries)
+ if optMarkdown
+ then outputMarkdown optDirectory cfg optMdSection
+ (Map.elems allEntries)
+ else outputRST optDirectory optVersion cfg (Map.elems allEntries)
-------------------------------------------------------------------------------
-- RST output
@@ -218,6 +268,9 @@ formatEntry Entry {..} =
] ++
[ "(:ghc-mr:`" ++ show n ++ "`)"
| MRNumber n <- Set.toList entryMrs
+ ] ++
+ [ "(:clc:`" ++ show n ++ "`)"
+ | CLCNumber n <- Set.toList entryClcs
]
description = maybe "" (\d -> "\n" ++ trim d ++ "\n\n") entryDescription
@@ -262,25 +315,281 @@ generateIncludedLibraries baseDir preamble libs = do
where
fst3 (a, _, _) = a
- extractField :: String -> String -> Maybe String
- extractField fieldName contents =
- case mapMaybe (matchField fieldName) (lines contents) of
- (v:_) -> Just v
- [] -> Nothing
-
- matchField :: String -> String -> Maybe String
- matchField fieldName line =
- let stripped = dropWhile isSpace line
- (key, rest) = break (\c -> c == ':' || isSpace c) stripped
- in if map toLower' key == map toLower' fieldName
- then case dropWhile isSpace rest of
- (':':val) -> Just (trim (dropWhile isSpace val))
- _ -> Nothing
- else Nothing
-
- toLower' c
- | c >= 'A' && c <= 'Z' = toEnum (fromEnum c + 32)
- | otherwise = c
+extractField :: String -> String -> Maybe String
+extractField fieldName contents =
+ case mapMaybe (matchField fieldName) (lines contents) of
+ (v:_) -> Just v
+ [] -> Nothing
+
+matchField :: String -> String -> Maybe String
+matchField fieldName line =
+ let stripped = dropWhile isSpace line
+ (key, rest) = break (\c -> c == ':' || isSpace c) stripped
+ in if map toLower' key == map toLower' fieldName
+ then case dropWhile isSpace rest of
+ (':':val) -> Just (trim (dropWhile isSpace val))
+ _ -> Nothing
+ else Nothing
+
+toLower' :: Char -> Char
+toLower' c
+ | c >= 'A' && c <= 'Z' = toEnum (fromEnum c + 32)
+ | otherwise = c
+
+-------------------------------------------------------------------------------
+-- Markdown output
+-------------------------------------------------------------------------------
+
+-- | Emit per-library Markdown bullets to stdout.
+--
+-- With 'mSect' set, emit just that section's bullets (used interactively).
+-- Without it, emit every section listed in @markdown-targets:@, separated
+-- by HTML comments naming each section
+outputMarkdown
+ :: FilePath -- ^ changelog.d directory (used to locate cabal files)
+ -> Cfg
+ -> Maybe String -- ^ --section <key>
+ -> [Entry]
+ -> IO ()
+outputMarkdown dir Cfg{..} mSect entries = do
+ targets <- case mSect of
+ Just key -> case find ((== key) . mtSection) cfgMarkdownTargets of
+ Nothing -> exitWithExc $ PlainError $
+ "Unknown markdown section: " ++ key
+ ++ "\nKnown sections: "
+ ++ intercalate ", " (map mtSection cfgMarkdownTargets)
+ Just mt -> pure [mt]
+ Nothing -> pure cfgMarkdownTargets
+
+ let multi = isNothing mSect
+ baseDir = takeDirectory (dropTrailingPathSeparator dir)
+
+ case mSect of
+ Just key | not (any (\mt -> mtSection mt == key) cfgMarkdownTargets) ->
+ -- impossible; handled above
+ pure ()
+ Just key | null (entriesFor key entries) ->
+ exitWithExc $ PlainError $ "No entries for section " ++ key
+ _ -> pure ()
+
+ for_ targets $ \mt -> do
+ let es = entriesFor (mtSection mt) entries
+ unless (null es) $ do
+ when multi $ do
+ putStrLn $ "<!-- ===== " ++ mtSection mt
+ ++ " (" ++ mtPath mt ++ ") ===== -->"
+ putStrLn ""
+ libVer <- readLibraryVersion baseDir (mtPath mt)
+ putStrLn $ "## " ++ libVer ++ " *TBA*"
+ putStrLn ""
+ for_ (sortBy (flip compare `on` hasDescription) es) $ \entry ->
+ putStr (formatEntryMd entry)
+ when multi $ putStrLn ""
+
+entriesFor :: String -> [Entry] -> [Entry]
+entriesFor key = filter $ \e -> case entrySection e of
+ Just (Section s) -> s == key
+ Nothing -> False
+
+-- | Given the path of a library's @changelog.md@ (repo-relative), find the
+-- sibling @*.cabal@ (or @*.cabal.in@) and read the @version:@ field.
+readLibraryVersion :: FilePath -> FilePath -> IO String
+readLibraryVersion baseDir mdPath = do
+ let libDir = takeDirectory mdPath
+ libDirFs = baseDir </> libDir
+ exists <- doesDirectoryExist libDirFs
+ if not exists
+ then do
+ hPutStrLn stderr $ "Warning: directory does not exist: " ++ libDirFs
+ pure "?.?.?"
+ else do
+ candidates <- listDirectory libDirFs
+ let cabals = filter (\f -> ".cabal" `isSuffixOf` f) candidates
+ -- Prefer non-templated *.cabal over *.cabal.in (the former is
+ -- the rendered file Hadrian needs before invoking us).
+ ranked = sortBy (compare `on` (\f -> if ".cabal.in" `isSuffixOf` f then (1::Int) else 0)) cabals
+ case ranked of
+ [] -> do
+ hPutStrLn stderr $
+ "Warning: no .cabal file under " ++ libDir
+ pure "?.?.?"
+ (cf:_) -> do
+ contents <- readFile (libDirFs </> cf)
+ case extractField "version" contents of
+ Just v -> pure v
+ Nothing -> do
+ hPutStrLn stderr $
+ "Warning: could not parse version from " ++ libDir </> cf
+ pure "?.?.?"
+
+-- | Format an Entry as a Markdown bullet. Mirrors 'formatEntry' for RST
+-- but emits Markdown links for issues/MRs/CLC and rewrites RST inline
+-- markup to markdown.
+formatEntryMd :: Entry -> String
+formatEntryMd Entry{..} = indentBulletMd (header ++ description)
+ where
+ header = unwords $
+ [ rstToMarkdown entrySynopsis ] ++
+ [ mdLink ("#" ++ show n)
+ ("https://gitlab.haskell.org/ghc/ghc/issues/" ++ show n)
+ | IssueNumber n <- Set.toList entryIssues
+ ] ++
+ [ mdLink ("!" ++ show n)
+ ("https://gitlab.haskell.org/ghc/ghc/-/merge_requests/" ++ show n)
+ | MRNumber n <- Set.toList entryMrs
+ ] ++
+ [ mdLink ("CLC proposal #" ++ show n)
+ ("https://github.com/haskell/core-libraries-committee/issues/" ++ show n)
+ | CLCNumber n <- Set.toList entryClcs
+ ]
+
+ description = maybe "" (\d -> "\n\n" ++ rstToMarkdown (trim d) ++ "\n") entryDescription
+
+ mdLink :: String -> String -> String
+ mdLink txt url = "(" ++ "[" ++ txt ++ "](" ++ url ++ ")" ++ ")"
+
+-- | Indent text as a Markdown bullet: the first line gets @"* "@ prefix,
+-- subsequent lines are indented two spaces. Mirrors 'indentBullet'.
+indentBulletMd :: String -> String
+indentBulletMd = unlines . go . lines
+ where
+ go [] = []
+ go (x:xs) = ("* " ++ x) : map indentLine xs
+ indentLine "" = ""
+ indentLine s = " " ++ s
+
+-------------------------------------------------------------------------------
+-- RST -> Markdown rewriting
+-------------------------------------------------------------------------------
+--
+-- Applies the following rules:
+--
+-- | RST | Markdown |
+-- | -------------------------------------------------| ------------------------------------------------------------------------------------------------------ |
+-- | ``code`` (double-backtick) | `code` (single-backtick) |
+-- | `text <url>`_ | [text](url) |
+-- | :ghc-ticket:`N` | [#N](https://gitlab.haskell.org/ghc/ghc/issues/N) |
+-- | :ghc-mr:`N` | [!N](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/N) |
+-- | :ghc-wiki:`p` | [p](https://gitlab.haskell.org/ghc/ghc/wikis/p) |
+-- | :clc:`N` | [CLC proposal #N](https://github.com/haskell/core-libraries-committee/issues/N) |
+-- | :ghc-flag:`-foo` | `-foo` |
+-- | :extension:`E` | `E` |
+-- | :ghci-cmd:`X`, :rts-flag:`X` | `X` |
+-- | :base-ref:`Mod.id` `` | `Mod.id` |
+-- | :th-ref:, :cabal-ref: ,:ghc-prim-ref: | `ref` |
+-- | .. code-block:: lang + indented body | Triple-backtick fenced block with `lang` |
+-- | .. note:: / .. warning:: | `> **Note:**` / `> **Warning:**` blockquote |
+
+rstToMarkdown :: String -> String
+rstToMarkdown s =
+ let trailingNL = not (null s) && last s == '\n'
+ body = intercalate "\n" . blockPass . lines . inlinePass $ s
+ in body ++ (if trailingNL then "\n" else "")
+
+inlinePass :: String -> String
+inlinePass [] = []
+-- Double-backtick code: ``code`` → `code`
+inlinePass ('`':'`':rest) =
+ case breakOnSubstring "``" rest of
+ (body, _:_:after) -> "`" ++ body ++ "`" ++ inlinePass after
+ _ -> '`':'`': inlinePass rest
+-- RST hyperlink: `text <url>`_ → [text](url)
+inlinePass ('`':rest)
+ | Just (txt, url, after) <- pickRstLink rest =
+ "[" ++ trim txt ++ "](" ++ url ++ ")" ++ inlinePass after
+-- :role:`body` interpreted-text role
+inlinePass (':':rest)
+ | Just (role, body, after) <- pickRole rest =
+ renderRole role body ++ inlinePass after
+inlinePass (c:cs) = c : inlinePass cs
+
+breakOnSubstring :: String -> String -> (String, String)
+breakOnSubstring needle = go
+ where
+ go [] = ([], [])
+ go s@(c:cs)
+ | needle `isPrefixOf` s = ([], s)
+ | otherwise =
+ let (a, b) = go cs in (c:a, b)
+
+-- | Try to consume a @\`text \<url\>\`_@ RST hyperlink starting after the
+-- leading backtick. Returns @(text, url, rest)@ on success.
+pickRstLink :: String -> Maybe (String, String, String)
+pickRstLink xs = do
+ let (txt, r1) = break (== '<') xs
+ case r1 of
+ '<':r2 -> do
+ let (url, r3) = break (== '>') r2
+ case r3 of
+ '>':'`':'_':'_':after -> Just (txt, url, after)
+ '>':'`':'_':after -> Just (txt, url, after)
+ _ -> Nothing
+ _ -> Nothing
+
+-- | Try to consume a @role:\`body\`@ interpreted-text role starting just
+-- after the leading colon.
+pickRole :: String -> Maybe (String, String, String)
+pickRole xs =
+ let (name, r1) = span (\c -> isAlpha c || c == '-') xs
+ in case (null name, r1) of
+ (False, ':':'`':r2) -> case break (== '`') r2 of
+ (body, '`':after) | not (null body) -> Just (name, body, after)
+ _ -> Nothing
+ _ -> Nothing
+
+-- | Render a known interpreted-text role to Markdown.
+renderRole :: String -> String -> String
+renderRole role body = case role of
+ "ghc-ticket" -> mdLink ("#" ++ body) ("https://gitlab.haskell.org/ghc/ghc/issues/" ++ body)
+ "ghc-mr" -> mdLink ("!" ++ body) ("https://gitlab.haskell.org/ghc/ghc/-/merge_requests/" ++ body)
+ "ghc-wiki" -> mdLink body ("https://gitlab.haskell.org/ghc/ghc/wikis/" ++ body)
+ "clc" -> mdLink ("CLC proposal #" ++ body)
+ ("https://github.com/haskell/core-libraries-committee/issues/" ++ body)
+ "ghc-flag" -> "`" ++ body ++ "`"
+ "extension" -> "`" ++ body ++ "`"
+ "ghci-cmd" -> "`" ++ body ++ "`"
+ "rts-flag" -> "`" ++ body ++ "`"
+ "doc" -> body
+ "base-ref" -> "`" ++ body ++ "`"
+ "th-ref" -> "`" ++ body ++ "`"
+ "cabal-ref" -> "`" ++ body ++ "`"
+ "ghc-prim-ref" -> "`" ++ body ++ "`"
+ _ -> ":" ++ role ++ ":`" ++ body ++ "`"
+ where
+ mdLink txt url = "[" ++ txt ++ "](" ++ url ++ ")"
+
+-- | Block-level transforms applied after the inline pass.
+blockPass :: [String] -> [String]
+blockPass [] = []
+blockPass (l:rest)
+ | Just lang <- stripPrefix ".. code-block:: " (trim l) =
+ let (body, rest') = takeIndentedBlock rest
+ in ("```" ++ lang) : map (dropIndent 4) body ++ ["```"] ++ blockPass rest'
+ | trim l == ".. note::" =
+ let (body, rest') = takeIndentedBlock rest
+ in "> **Note:**" : map (("> " ++) . dropIndent 4) body ++ blockPass rest'
+ | trim l == ".. warning::" =
+ let (body, rest') = takeIndentedBlock rest
+ in "> **Warning:**" : map (("> " ++) . dropIndent 4) body ++ blockPass rest'
+ | otherwise = l : blockPass rest
+
+-- | Take a block of indented (or blank) lines following a directive; stop
+-- at the first non-blank, non-indented line.
+takeIndentedBlock :: [String] -> ([String], [String])
+takeIndentedBlock = go . dropWhile null
+ where
+ go [] = ([], [])
+ go (x:xs)
+ | null x = let (a, b) = go xs in (x:a, b)
+ | take 1 x == " " = let (a, b) = go xs in (x:a, b)
+ | otherwise = ([], x:xs)
+
+-- | Drop up to @n@ leading spaces from a line.
+dropIndent :: Int -> String -> String
+dropIndent _ "" = ""
+dropIndent 0 s = s
+dropIndent n (' ':cs) = dropIndent (n-1) cs
+dropIndent _ s = s
-------------------------------------------------------------------------------
-- Section grouping
@@ -303,10 +612,13 @@ groupBySections sectionDefs entries =
-------------------------------------------------------------------------------
data Opts = Opts
- { optDirectory :: FilePath
- , optVersion :: Maybe String
- , optValidate :: Bool
- , optExpectMR :: Maybe Int -- ^ Expected MR number
+ { optDirectory :: FilePath
+ , optVersion :: Maybe String
+ , optValidate :: Bool
+ , optExpectMR :: Maybe Int -- ^ Expected MR number
+ , optExpectCLC :: Bool -- ^ Require entry matched by --expect-mr to have clc:
+ , optMarkdown :: Bool -- ^ Emit per-library Markdown to stdout
+ , optMdSection :: Maybe String -- ^ Restrict markdown emission to one section
}
deriving (Show)
@@ -332,6 +644,24 @@ instance C.Parsec MRNumber where
instance C.Pretty MRNumber where
pretty (MRNumber n) = PP.char '!' PP.<> PP.int n
+newtype CLCNumber = CLCNumber Int
+ deriving (Eq, Ord, Show)
+
+instance C.Parsec CLCNumber where
+ parsec = do
+ _ <- P.char '#'
+ CLCNumber <$> P.integral
+
+instance C.Pretty CLCNumber where
+ pretty (CLCNumber n) = PP.char '#' PP.<> PP.int n
+
+data MarkdownTarget = MarkdownTarget
+ { mtSection :: String -- ^ section key matching an entry's `section:`
+ , mtPath :: FilePath -- ^ target changelog path, repo-relative
+ , mtRequiredFields :: [String] -- ^ extra required-fields when this section is used
+ }
+ deriving (Show)
+
newtype Section = Section String
deriving (Eq, Ord, Show)
@@ -351,6 +681,7 @@ data Cfg = Cfg
, cfgPreamble :: String
, cfgIncludedLibraries :: [(FilePath, String)] -- ^ (cabalPath, description)
, cfgIncludedLibrariesPreamble :: String
+ , cfgMarkdownTargets :: [MarkdownTarget]
}
deriving (Show)
@@ -364,6 +695,7 @@ parseConfig fields0 = do
, cfgPreamble = cfgRawPreamble raw
, cfgIncludedLibraries = parseIncludedLibraries (cfgRawIncludedLibraries raw)
, cfgIncludedLibrariesPreamble = cfgRawIncludedLibrariesPreamble raw
+ , cfgMarkdownTargets = parseMarkdownTargets (cfgRawMarkdownTargets raw)
}
where
(fields, sections) = C.partitionFields fields0
@@ -378,6 +710,7 @@ data CfgRaw = CfgRaw
, cfgRawPreamble :: String
, cfgRawIncludedLibraries :: String
, cfgRawIncludedLibrariesPreamble :: String
+ , cfgRawMarkdownTargets :: String
}
cfgRawRequiredFieldsL :: Functor f => (Set String -> f (Set String)) -> CfgRaw -> f CfgRaw
@@ -395,6 +728,9 @@ cfgRawIncludedLibrariesL f s = (\x -> s { cfgRawIncludedLibraries = x }) <$> f (
cfgRawIncludedLibrariesPreambleL :: Functor f => (String -> f String) -> CfgRaw -> f CfgRaw
cfgRawIncludedLibrariesPreambleL f s = (\x -> s { cfgRawIncludedLibrariesPreamble = x }) <$> f (cfgRawIncludedLibrariesPreamble s)
+cfgRawMarkdownTargetsL :: Functor f => (String -> f String) -> CfgRaw -> f CfgRaw
+cfgRawMarkdownTargetsL f s = (\x -> s { cfgRawMarkdownTargets = x }) <$> f (cfgRawMarkdownTargets s)
+
cfgRawGrammar :: C.ParsecFieldGrammar CfgRaw CfgRaw
cfgRawGrammar = CfgRaw
<$> C.monoidalFieldAla "required-fields" (C.alaSet' C.FSep C.Token) cfgRawRequiredFieldsL
@@ -402,6 +738,7 @@ cfgRawGrammar = CfgRaw
<*> C.freeTextFieldDef "preamble" cfgRawPreambleL
<*> C.freeTextFieldDef "included-libraries" cfgRawIncludedLibrariesL
<*> C.freeTextFieldDef "included-libraries-preamble" cfgRawIncludedLibrariesPreambleL
+ <*> C.freeTextFieldDef "markdown-targets" cfgRawMarkdownTargetsL
parseSections :: String -> [(String, String)]
parseSections = mapMaybe parseLine . lines
@@ -419,6 +756,20 @@ parseIncludedLibraries = mapMaybe parseLine . lines
(path, rest) | not (null path) -> Just (path, trim rest)
_ -> Nothing
+-- | Parse the @markdown-targets:@ block.
+--
+-- Each non-empty, non-comment line is
+-- <section-key> <path> [<extra-required-field>...]
+-- The extra tokens declare additional fields required of any entry whose section: matches.
+parseMarkdownTargets :: String -> [MarkdownTarget]
+parseMarkdownTargets = mapMaybe parseLine . lines
+ where
+ parseLine l = case words (trim l) of
+ [] -> Nothing
+ [_] -> Nothing -- need at least section + path
+ (sect:path:extra) ->
+ Just $ MarkdownTarget sect path extra
+
-------------------------------------------------------------------------------
-- Entry
-------------------------------------------------------------------------------
@@ -428,6 +779,7 @@ data Entry = Entry
, entryDescription :: Maybe String
, entryMrs :: Set MRNumber
, entryIssues :: Set IssueNumber
+ , entryClcs :: Set CLCNumber
, entrySection :: Maybe Section
}
deriving (Show)
@@ -447,6 +799,9 @@ entryMrsL f s = (\x -> s { entryMrs = x }) <$> f (entryMrs s)
entryIssuesL :: Functor f => (Set IssueNumber -> f (Set IssueNumber)) -> Entry -> f Entry
entryIssuesL f s = (\x -> s { entryIssues = x }) <$> f (entryIssues s)
+entryClcsL :: Functor f => (Set CLCNumber -> f (Set CLCNumber)) -> Entry -> f Entry
+entryClcsL f s = (\x -> s { entryClcs = x }) <$> f (entryClcs s)
+
entrySectionL :: Functor f => (Maybe Section -> f (Maybe Section)) -> Entry -> f Entry
entrySectionL f s = (\x -> s { entrySection = x }) <$> f (entrySection s)
@@ -477,6 +832,7 @@ entryGrammar = Entry
<*> C.freeTextField "description" entryDescriptionL
<*> C.monoidalFieldAla "mrs" (C.alaSet C.NoCommaFSep) entryMrsL
<*> C.monoidalFieldAla "issues" (C.alaSet C.NoCommaFSep) entryIssuesL
+ <*> C.monoidalFieldAla "clc" (C.alaSet C.NoCommaFSep) entryClcsL
<*> C.optionalField "section" entrySectionL
-------------------------------------------------------------------------------
@@ -510,8 +866,21 @@ validateEntry cfg entry = foldMap (\validator -> validator cfg entry)
validateRequiredFields :: Validator
validateRequiredFields Cfg{..} Entry{..} = fmap RequiredFieldError $
- mapMaybe checkField $ Set.toList cfgRequiredFields
+ mapMaybe checkField $ Set.toList effectiveRequired
where
+ -- Effective required-fields = global cfgRequiredFields + extras for the
+ -- entry's section as declared in cfgMarkdownTargets
+ -- (e.g. `base` adds `clc`).
+ effectiveRequired =
+ cfgRequiredFields `Set.union`
+ Set.fromList
+ [ f
+ | Just (Section sect) <- [entrySection]
+ , mt <- cfgMarkdownTargets
+ , mtSection mt == sect
+ , f <- mtRequiredFields mt
+ ]
+
checkField :: String -> Maybe RequiredFieldError
checkField reqField = case fieldIsEmpty reqField of
Left err -> Just err
@@ -522,6 +891,7 @@ validateRequiredFields Cfg{..} Entry{..} = fmap RequiredFieldError $
fieldIsEmpty "description" = pure $ isNothing entryDescription
fieldIsEmpty "mrs" = pure $ null entryMrs
fieldIsEmpty "issues" = pure $ null entryIssues
+ fieldIsEmpty "clc" = pure $ null entryClcs
fieldIsEmpty "section" = pure $ isNothing entrySection
fieldIsEmpty f = Left $ UnknownRequiredField f
=====================================
utils/changelog-d/README.md
=====================================
@@ -23,46 +23,55 @@ description: {
**Required fields:** `section`, `synopsis`, `mrs`, `issues`
-**Optional fields:** `description`
+**Optional fields:** `description`, `clc`
+
+**Conditionally required**: entries with `section: base` MUST also include a `clc:`
+field referencing the CLC proposal authorising the change.
If your MR doesn't need a changelog entry, apply the `no-changelog` label.
### Fields
-| Field | Format | Description |
-| ------------- | ------------------------------- | -----------------------------------------------|
-| `synopsis` | Free-form RST | Brief description of the change |
-| `mrs` | `!N` (space-separated) | MR number(s) |
-| `issues` | `#N` (space-separated) | Issue number(s) |
-| `section` | Section key (see below) | GHC component |
-| `description` | Free-form RST in `{ ... }` | Extended details. Printed after the main entry |
+| Field | Format | Description |
+| ------------- | -------------------------- | ----------------------------------------------------- |
+| `synopsis` | Free-form RST | Brief description of the change |
+| `mrs` | `!N` (space-separated) | MR number(s) |
+| `issues` | `#N` (space-separated) | Issue number(s) |
+| `clc` | `#N` (space-separated) | CLC proposal number(s). Required for `section: base`. |
+| `section` | Section key (see below) | GHC component |
+| `description` | Free-form RST | Extended details. Printed after the main entry |
### Section keys
-| Key | Heading |
-| ------------------ | -------------------------------- |
-| `language` | Language |
-| `compiler` | Compiler |
-| `profiling` | Profiling |
-| `codegen` | Code generation |
-| `llvm-backend` | LLVM backend |
-| `js-backend` | JavaScript backend |
-| `wasm-backend` | WebAssembly backend |
-| `ghci` | GHCi |
-| `rts` | Runtime system |
-| `linker` | Linker |
-| `bytecode` | Bytecode compiler |
-| `packaging` | Packaging & build system |
-| `cmm` | Cmm |
-| `build-tools` | Build tools |
-| `base` | ``base`` library |
-| `ghc-prim` | ``ghc-prim`` library |
-| `ghc-lib` | ``ghc`` library |
-| `ghc-heap` | ``ghc-heap`` library |
-| `ghc-experimental` | ``ghc-experimental`` library |
-| `template-haskell` | ``template-haskell`` library |
-| `ghc-pkg` | ``ghc-pkg`` |
-| `ghc-toolchain` | ``ghc-toolchain`` |
+The "Markdown" column indicates whether entries in that section also flow to
+a per-library `changelog.md`. Sections without a
+Markdown target appear only in the GHC release notes RST.
+
+| Key | Heading | Markdown target |
+| ------------------ | ---------------------------- | ---------------------------------------------- |
+| `language` | Language | — |
+| `compiler` | Compiler | — |
+| `profiling` | Profiling | — |
+| `codegen` | Code generation | — |
+| `llvm-backend` | LLVM backend | — |
+| `js-backend` | JavaScript backend | — |
+| `wasm-backend` | WebAssembly backend | — |
+| `ghci` | GHCi | — |
+| `rts` | Runtime system | — |
+| `linker` | Linker | — |
+| `bytecode` | Bytecode compiler | — |
+| `packaging` | Packaging & build system | — |
+| `cmm` | Cmm | — |
+| `build-tools` | Build tools | — |
+| `base` | ``base`` library | `libraries/base/changelog.md` |
+| `ghc-internal` | ``ghc-internal`` library | `libraries/ghc-internal/CHANGELOG.md` |
+| `ghc-prim` | ``ghc-prim`` library | `libraries/ghc-prim/changelog.md` |
+| `ghc-lib` | ``ghc`` library | — |
+| `ghc-heap` | ``ghc-heap`` library | — |
+| `ghc-experimental` | ``ghc-experimental`` library | `libraries/ghc-experimental/CHANGELOG.md` |
+| `template-haskell` | ``template-haskell`` library | `libraries/template-haskell/changelog.md` |
+| `ghc-pkg` | ``ghc-pkg`` | — |
+| `ghc-toolchain` | ``ghc-toolchain`` | — |
### Entry format
@@ -83,20 +92,34 @@ library's `Distribution.Fields` parser
## Configuration
The file `changelog.d/config` declares the structure of the generated release
-notes: required fields, section names, preamble text, and the included-libraries
-table. Edit it when adding new sections or changing release note formatting.
+notes: required fields, section names, preamble text, the included-libraries
+table, and the `markdown-targets:` mapping that wires sections to per-library
+`changelog.md` files. Edit it when adding new sections or changing release-note
+formatting.
+
+The `markdown-targets:` block is the source of truth for "which section's
+entries get a Markdown emission, and which extra fields (e.g. `clc`) are
+required for that section." Each line is `<section-key> <path> [<extra-required-field>...]`.
## For maintainers
### Hadrian targets
-Generate release notes:
+Generate RST release notes (existing behaviour):
```
hadrian/build changelog # uses project version
hadrian/build changelog --changelog-version=10.2.1 # explicit version
```
Output: `docs/users_guide/<version>-notes.rst`
+Generate per-library Markdown bullets:
+
+```
+hadrian/build libraries-changelog-markdown
+```
+
+Output is one stream containing every configured `markdown-targets:` section.
+
Clear entries after branch cut:
```
@@ -108,3 +131,25 @@ Validate entries:
```
hadrian/build test --only=changelog-d
```
+
+### RST -> Markdown rewrite rules
+
+`--libraries-changelog-markdown` rewrites the inline RST in each entry to Markdown:
+
+| RST | Markdown |
+| -------------------------------------------------| ------------------------------------------------------------------------------------------------------ |
+| ``code`` (double-backtick) | `code` (single-backtick) |
+| `text <url>`_ | [text](url) |
+| :ghc-ticket:`N` | [#N](https://gitlab.haskell.org/ghc/ghc/issues/N) |
+| :ghc-mr:`N` | [!N](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/N) |
+| :ghc-wiki:`p` | [p](https://gitlab.haskell.org/ghc/ghc/wikis/p) |
+| :clc:`N` | [CLC proposal #N](https://github.com/haskell/core-libraries-committee/issues/N) |
+| :ghc-flag:`-foo` | `-foo` |
+| :extension:`E` | `E` |
+| :ghci-cmd:`X`, :rts-flag:`X` | `X` |
+| :base-ref:`Mod.id` `` | `Mod.id` |
+| :th-ref:, :cabal-ref: ,:ghc-prim-ref: | `ref` |
+| .. code-block:: lang + indented body | Triple-backtick fenced block with `lang` |
+| .. note:: / .. warning:: | `> **Note:**` / `> **Warning:**` blockquote |
+
+
=====================================
utils/changelog-d/tests/config
=====================================
@@ -0,0 +1,9 @@
+required-fields: synopsis mrs issues section
+
+sections: {
+ base ``base`` library
+}
+
+markdown-targets: {
+ base _fake/changelog.md clc
+}
=====================================
utils/changelog-d/tests/expected/test-parser-rewriter.md
=====================================
@@ -0,0 +1,33 @@
+## ?.?.? *TBA*
+
+* Self-test fixture exercising the parser/rewriter. Uses double-backtick `code`,
+ RST hyperlinks [the changelog wiki](https://gitlab.haskell.org/ghc/ghc/-/wikis/contributing/changelog),
+ GHC-flavoured roles [#12345](https://gitlab.haskell.org/ghc/ghc/issues/12345), [!6789](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6789), [commentary/compiler](https://gitlab.haskell.org/ghc/ghc/wikis/commentary/co…,
+ [CLC proposal #123](https://github.com/haskell/core-libraries-committee/issues/123), `-fxxx`, `TypeApplications`, `:type`,
+ `-N`, haddock cross-refs `Data.Maybe.fromMaybe`,
+ `Language.Haskell.TH.Lib`, `Distribution.Simple`,
+ `GHC.Prim`, the internal-doc role, and an :unknown-role:`pass-through`. ([#26002](https://gitlab.haskell.org/ghc/ghc/issues/26002)) ([!15830](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/15830)) ([CLC proposal #0](https://github.com/haskell/core-libraries-committee/issues/0))
+
+ This description block exercises block-level rewrites and inline rewrites
+ inside a multi-line braced field.
+
+ Inline forms inside the description: `inline code`, `DataKinds`,
+ [!15830](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/15830), `Control.Applicative`, and a [bare RST link](https://example.invalid/).
+
+ > **Note:**
+ > This is an RST note admonition. It should render as a Markdown
+ > blockquote prefixed with `> **Note:**`.
+ >
+ > **Warning:**
+ > This is an RST warning admonition. It should render as a Markdown
+ > blockquote prefixed with `> **Warning:**`.
+ >
+ ```haskell
+ foo :: Int -> Int
+ foo x = x + 1
+ bar :: String
+ bar = "hello"
+
+ ```
+ After the code block, plain prose continues. Verify that the renderer
+ exits the fenced block correctly and resumes paragraph flow here.
=====================================
utils/changelog-d/tests/test-parser-rewriter
=====================================
@@ -0,0 +1,48 @@
+-- This file exercises every construct supported by changelog-d's parser
+-- and RST -> Markdown rewriter. It is kept in tree as a regression
+-- fixture: when the parser or rewriter is touched, run
+-- cabal run changelog-d -- --validate changelog.d/
+-- cabal run changelog-d -- --libraries-changelog-markdown changelog.d/
+-- and visually compare the output. The tool treats this like any
+-- other fragment, so it WILL appear in `--version`'ed RST and in
+-- `--libraries-changelog-markdown` output. Delete it before cutting a
+-- release, or move it under utils/changelog-d/tests/ if/when that
+-- directory is wired up.
+section: base
+synopsis: Self-test fixture exercising the parser/rewriter. Uses double-backtick ``code``,
+ RST hyperlinks `the changelog wiki <https://gitlab.haskell.org/ghc/ghc/-/wikis/contributing/changelog>`_,
+ GHC-flavoured roles :ghc-ticket:`12345`, :ghc-mr:`6789`, :ghc-wiki:`commentary/compiler`,
+ :clc:`123`, :ghc-flag:`-fxxx`, :extension:`TypeApplications`, :ghci-cmd:`:type`,
+ :rts-flag:`-N`, haddock cross-refs :base-ref:`Data.Maybe.fromMaybe`,
+ :th-ref:`Language.Haskell.TH.Lib`, :cabal-ref:`Distribution.Simple`,
+ :ghc-prim-ref:`GHC.Prim`, the :doc:`internal-doc` role, and an :unknown-role:`pass-through`.
+issues: #26002
+mrs: !15830
+clc: #0
+
+description: {
+ This description block exercises block-level rewrites and inline rewrites
+ inside a multi-line braced field.
+
+ Inline forms inside the description: ``inline code``, :extension:`DataKinds`,
+ :ghc-mr:`15830`, :base-ref:`Control.Applicative`, and a `bare RST link
+ <https://example.invalid/>`_.
+
+ .. note::
+ This is an RST note admonition. It should render as a Markdown
+ blockquote prefixed with ``> **Note:**``.
+
+ .. warning::
+ This is an RST warning admonition. It should render as a Markdown
+ blockquote prefixed with ``> **Warning:**``.
+
+ .. code-block:: haskell
+
+ foo :: Int -> Int
+ foo x = x + 1
+ bar :: String
+ bar = "hello"
+
+ After the code block, plain prose continues. Verify that the renderer
+ exits the fenced block correctly and resumes paragraph flow here.
+}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/84998393f2f217119785f80ab21ceac…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/84998393f2f217119785f80ab21ceac…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/27183] changelog-d: Add support for emitting markdown for library changelogs
by Zubin (＠wz1000) 28 Apr '26
by Zubin (＠wz1000) 28 Apr '26
28 Apr '26
Zubin pushed to branch wip/27183 at Glasgow Haskell Compiler / GHC
Commits:
553822f6 by Zubin Duggal at 2026-04-28T17:10:53+05:30
changelog-d: Add support for emitting markdown for library changelogs
Now library changelog entries are written in changelog.d/ uniformly, and the
changelog-d tool gains functionality to output markdown fragments for the
library changelog files. The fragments will be spliced into the respective files
at release time by the release manager.
Also changes the lint-changelog CI job to ensure that changes which touch base
have a changelog entry and a CLC proposal.
Fixes #27183
- - - - -
12 changed files:
- .gitlab-ci.yml
- .gitlab/merge_request_templates/Default.md
- changelog.d/config
- docs/users_guide/ghc_config.py.in
- hadrian/src/Rules/Changelog.hs
- libraries/integer-gmp/integer-gmp.cabal
- testsuite/tests/linters/Makefile
- utils/changelog-d/ChangelogD.hs
- utils/changelog-d/README.md
- + utils/changelog-d/tests/config
- + utils/changelog-d/tests/expected/test-parser-rewriter.md
- + utils/changelog-d/tests/test-parser-rewriter
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -247,6 +247,9 @@ ghc-linters:
# Check that MRs include a changelog entry in changelog.d/.
# Skipped if the MR has the ~"no-changelog" label.
+#
+# If MR's diff touches libraries/base/, the changelog must also have a non-empty
+# `clc:` field.
lint-changelog:
stage: tool-lint
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV"
@@ -254,6 +257,7 @@ lint-changelog:
variables:
BUILD_FLAVOUR: default
CHANGELOG_EXPECT_MR: "$CI_MERGE_REQUEST_IID"
+ CHANGELOG_EXPECT_CLC: ""
script:
# Check that the MR adds at least one changelog entry
- git fetch "$CI_MERGE_REQUEST_PROJECT_URL" "$CI_MERGE_REQUEST_TARGET_BRANCH_NAME"
@@ -276,6 +280,10 @@ lint-changelog:
when: never
- if: '$CI_MERGE_REQUEST_LABELS =~ /.*no-changelog.*/'
when: never
+ - changes:
+ - libraries/base/**/*
+ variables:
+ CHANGELOG_EXPECT_CLC: "1"
- if: $CI_MERGE_REQUEST_ID
- *drafts-can-fail-lint
=====================================
.gitlab/merge_request_templates/Default.md
=====================================
@@ -23,7 +23,8 @@ https://gitlab.haskell.org/ghc/ghc/-/wikis/Contributing-a-Patch
- [ ] This MR solves the problem described in the following issue: <!-- issue number here (please open a new issue if there isn't one) -->
- [ ] A changelog entry was added in `changelog.d/` for user-facing changes (see [changelog guide][changelog]).
If this MR does not need a changelog entry, the ~"no-changelog" label was applied.
-- [ ] This MR does not make any significant changes to `base`, or it has an accompanying [CLC proposal](https://github.com/haskell/core-libraries-committee#base-package).
+- [ ] This MR does not make any significant changes to `base`, or it has an accompanying [CLC proposal](https://github.com/haskell/core-libraries-committee#base-package)
+ and the changelog fragment uses `section: base` with the `clc: #<proposal>` field set.
- [ ] If this MR has the potential to break user programs, the ~"user-facing" label was applied to
test against head.hackage.
- [ ] All commits are either individually buildable or squashed.
=====================================
changelog.d/config
=====================================
@@ -27,6 +27,7 @@ sections: {
cmm Cmm
build-tools Build tools
base ``base`` library
+ ghc-internal ``ghc-internal`` library
ghc-prim ``ghc-prim`` library
ghc-lib ``ghc`` library
ghc-heap ``ghc-heap`` library
@@ -36,6 +37,18 @@ sections: {
ghc-toolchain ``ghc-toolchain``
}
+-- markdown-targets: sections that also need to end up in
+-- per-library changelog files. The optional third token
+-- lists extra fields that might be required for this section
+-- like `clc` for base.
+markdown-targets: {
+ base libraries/base/changelog.md clc
+ ghc-internal libraries/ghc-internal/CHANGELOG.md
+ ghc-prim libraries/ghc-prim/changelog.md
+ ghc-experimental libraries/ghc-experimental/CHANGELOG.md
+ template-haskell libraries/template-haskell/changelog.md
+}
+
included-libraries-preamble: {
The package database provided with this distribution also contains a number of
packages other than GHC itself. See the changelogs provided with these packages
=====================================
docs/users_guide/ghc_config.py.in
=====================================
@@ -7,12 +7,14 @@ if parse_version(sphinx.__version__) >= parse_version("4.0.0"):
'ghc-ticket': ('https://gitlab.haskell.org/ghc/ghc/issues/%s', '#%s'),
'ghc-wiki': ('https://gitlab.haskell.org/ghc/ghc/wikis/%s', '%s'),
'ghc-mr': ('https://gitlab.haskell.org/ghc/ghc/-/merge_requests/%s', '!%s'),
+ 'clc': ('https://github.com/haskell/core-libraries-committee/issues/%s', 'CLC proposal #%s'),
}
else:
extlinks = {
'ghc-ticket': ('https://gitlab.haskell.org/ghc/ghc/issues/%s', '#'),
'ghc-wiki': ('https://gitlab.haskell.org/ghc/ghc/wikis/%s', ''),
'ghc-mr': ('https://gitlab.haskell.org/ghc/ghc/-/merge_requests/%s', '!'),
+ 'clc': ('https://github.com/haskell/core-libraries-committee/issues/%s', 'CLC proposal #'),
}
libs_base_uri = '../libraries'
=====================================
hadrian/src/Rules/Changelog.hs
=====================================
@@ -11,8 +11,9 @@ import qualified System.Directory as IO
-- | Rules for generating and managing changelog entries.
--
-- Targets:
--- hadrian/build changelog -- generate release notes
+-- hadrian/build changelog -- generate RST release notes
-- hadrian/build changelog --changelog-version=10.2.1 -- with explicit version
+-- hadrian/build libraries-changelog-markdown -- emit per-library Markdown bullets to stdout
-- hadrian/build changelog-clear -- remove old entries
changelogRules :: Rules ()
changelogRules = do
@@ -25,19 +26,6 @@ changelogRules = do
ctx <- programContext stage0Boot changelogD
progPath <- programPath ctx
need [progPath]
-
- -- These cabal files are needed by changelog-d to determine the
- -- versions of packages shipped with GHC.
- let templatedCabalFiles = map pkgCabalFile
- [ ghcBoot
- , ghcBootTh
- , ghcExperimental
- , ghcInternal
- , ghci
- , compiler
- , ghcHeap
- , templateHaskell
- ]
need templatedCabalFiles
top <- topDirectory
@@ -47,6 +35,18 @@ changelogRules = do
:: Action ()
putSuccess $ "| Generated release notes: " ++ outFile
+ phony "libraries-changelog-markdown" $ do
+ ctx <- programContext stage0Boot changelogD
+ progPath <- programPath ctx
+ need [progPath]
+ need templatedCabalFiles
+
+ top <- topDirectory
+ cmd_ [progPath]
+ [ top -/- "changelog.d/"
+ , "--libraries-changelog-markdown"
+ ]
+
phony "changelog-clear" $ do
top <- topDirectory
let dir = top -/- "changelog.d"
@@ -54,3 +54,17 @@ changelogRules = do
let toRemove = filter (\f -> f /= "config" && not (isPrefixOf "." f)) entries
liftIO $ mapM_ (IO.removeFile . (dir -/-)) toRemove
putSuccess $ "| Removed " ++ show (length toRemove) ++ " changelog entries"
+ where
+ -- These cabal files are needed by changelog-d to determine the
+ -- versions of packages shipped with GHC.
+ templatedCabalFiles = map pkgCabalFile
+ [ ghcBoot
+ , ghcBootTh
+ , ghcExperimental
+ , ghcInternal
+ , ghci
+ , compiler
+ , ghcHeap
+ , templateHaskell
+ , base
+ ]
=====================================
libraries/integer-gmp/integer-gmp.cabal
=====================================
@@ -13,6 +13,9 @@ build-type: Simple
homepage: https://www.haskell.org/ghc/
bug-reports: https://gitlab.haskell.org/ghc/ghc/issues/new
+extra-source-files:
+ changelog.md
+
description:
This package used to provide an implementation of the standard 'Integer'
type based on the
=====================================
testsuite/tests/linters/Makefile
=====================================
@@ -30,8 +30,12 @@ notes:
(cd $(TOP)/.. && $(LINT_NOTES) broken-refs)
changelog-d:
-ifdef CHANGELOG_EXPECT_MR
+ifneq "$(CHANGELOG_EXPECT_MR)" ""
+ifneq "$(CHANGELOG_EXPECT_CLC)" ""
+ (cd $(TOP)/.. && $(CHANGELOG_D) changelog.d/ --validate --expect-mr $(CHANGELOG_EXPECT_MR) --expect-clc)
+else
(cd $(TOP)/.. && $(CHANGELOG_D) changelog.d/ --validate --expect-mr $(CHANGELOG_EXPECT_MR))
+endif
else
(cd $(TOP)/.. && $(CHANGELOG_D) changelog.d/ --validate)
endif
=====================================
utils/changelog-d/ChangelogD.hs
=====================================
@@ -10,15 +10,15 @@
module Main (main) where
import Control.Exception (Exception (..))
-import Control.Monad (unless, void, when)
-import Data.Char (isSpace)
+import Control.Monad (filterM, unless, void, when)
+import Data.Char (isAlpha, isSpace)
import Data.Foldable (for_, toList, traverse_)
import Data.Function (on)
-import Data.List (intercalate, sort, sortBy)
+import Data.List (find, intercalate, isPrefixOf, isSuffixOf, sort, sortBy, stripPrefix)
import Data.Maybe (isJust, isNothing, mapMaybe)
import Data.Set (Set)
import Data.Traversable (for)
-import System.Directory (listDirectory)
+import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)
import System.Environment (getArgs)
import System.Exit (exitFailure)
import System.FilePath ((</>), dropTrailingPathSeparator, takeDirectory)
@@ -58,16 +58,35 @@ usage = unlines
, " Collect changelog entries and produce release notes."
, ""
, "Options:"
- , " --version <version> Version number for RST file header (e.g. 10.2.1)"
- , " --validate Validate entries only, no output"
- , " --expect-mr <N> Check that at least one entry references MR !N"
- , " --help Show this help"
+ , " --version <version> Version number for RST file header (e.g. 10.2.1)"
+ , " --validate Validate entries only, no output"
+ , " --expect-mr <N> Check that at least one entry references MR !N"
+ , " --expect-clc Require the entry matched by --expect-mr"
+ , " to have a non-empty 'clc:' field. Used by"
+ , " CI for MRs touching base."
+ , " --libraries-changelog-markdown Emit per-library Markdown bullets to"
+ , " stdout (suppresses RST emission). Output"
+ , " is intended to be pasted into each"
+ , " libraries/<lib>/changelog.md by hand;"
+ , " --section <key> Restrict --libraries-changelog-markdown"
+ , " to a single section. Without this, all"
+ , " configured markdown-targets are emitted,"
+ , " separated by HTML-comment markers."
+ , " --help Show this help"
]
parseArgs :: [String] -> Either String Opts
parseArgs = go defaultOpts
where
- defaultOpts = Opts "changelog.d" Nothing False Nothing
+ defaultOpts = Opts
+ { optDirectory = "changelog.d"
+ , optVersion = Nothing
+ , optValidate = False
+ , optExpectMR = Nothing
+ , optExpectCLC = False
+ , optMarkdown = False
+ , optMdSection = Nothing
+ }
go opts [] = Right opts
go _ ("--help" : _) = Left ""
@@ -78,6 +97,11 @@ parseArgs = go defaultOpts
[(mr, "")] -> go opts { optExpectMR = Just mr } rest
_ -> Left $ "--expect-mr requires a number, got: " ++ n
go _ ("--expect-mr" : []) = Left "--expect-mr requires an argument"
+ go opts ("--expect-clc" : rest) = go opts { optExpectCLC = True } rest
+ go opts ("--libraries-changelog-markdown" : rest) =
+ go opts { optMarkdown = True } rest
+ go opts ("--section" : s : rest) = go opts { optMdSection = Just s } rest
+ go _ ("--section" : []) = Left "--section requires an argument"
go _ (('-':'-':opt) : _) = Left $ "Unknown option: --" ++ opt
go _ (('-':opt) : _) = Left $ "Unknown option: -" ++ opt
go opts (dir : rest) = go opts { optDirectory = dir } rest
@@ -124,9 +148,14 @@ makeChangelog Opts {..} = do
either (exitWithExc . PlainError) return $
parseWith parseConfig filename contents
+ -- Read only regular files, skipping config, dotfiles, and any
+ -- subdirectories (e.g. golden-output dirs alongside test fragments).
dirContents <- filter (not . isTmpFile) <$> listDirectory optDirectory
+ fragmentNames <-
+ filterM (\name -> doesFileExist (optDirectory </> name))
+ (filter (/= "config") $ sort dirContents)
allEntries <- fmap Map.fromList $
- for (filter (/= "config") $ sort dirContents) $ \name -> do
+ for fragmentNames $ \name -> do
let fp = optDirectory </> name
contents <- BS.readFile fp
entry <- parseEntryFile fp contents
@@ -140,17 +169,38 @@ makeChangelog Opts {..} = do
exitWithExc $ PlainError "Validation failed."
-- Check expected MR number if specified
- for_ optExpectMR $ \expectedMR -> do
- let expectedMRNum = MRNumber expectedMR
- entriesWithMR = Map.filter (\e -> expectedMRNum `Set.member` entryMrs e) allEntries
- when (Map.null entriesWithMR && not (Map.null allEntries)) $ do
- hPutStrLn stderr $ "Warning: No changelog entry references this MR (!" ++ show expectedMR ++ ")."
- hPutStrLn stderr $ "Add 'mrs: !" ++ show expectedMR ++ "' to your changelog entry."
- hPutStrLn stderr ""
- exitFailure
+ matchedByMR <- case optExpectMR of
+ Nothing -> pure Map.empty
+ Just expectedMR -> do
+ let expectedMRNum = MRNumber expectedMR
+ withMR = Map.filter (\e -> expectedMRNum `Set.member` entryMrs e) allEntries
+ when (Map.null withMR && not (Map.null allEntries)) $ do
+ hPutStrLn stderr $ "Warning: No changelog entry references this MR (!" ++ show expectedMR ++ ")."
+ hPutStrLn stderr $ "Add 'mrs: !" ++ show expectedMR ++ "' to your changelog entry."
+ hPutStrLn stderr ""
+ exitFailure
+ pure withMR
+
+ -- --expect-clc: assert that the MR-matched entry has clc: set.
+ when optExpectCLC $ case optExpectMR of
+ Nothing -> exitWithExc $ PlainError
+ "--expect-clc requires --expect-mr (which entry to check?)"
+ Just expectedMR ->
+ when (not (Map.null matchedByMR)
+ && all (Set.null . entryClcs) matchedByMR) $ do
+ hPutStrLn stderr $
+ "Error: changelog entry for !" ++ show expectedMR
+ ++ " does not have a 'clc:' field."
+ hPutStrLn stderr
+ "Changes to base or user-facing changes require a CLC proposal."
+ hPutStrLn stderr "Add 'clc: #<proposal>' to your changelog entry."
+ exitFailure
unless optValidate $
- outputRST optDirectory optVersion cfg (Map.elems allEntries)
+ if optMarkdown
+ then outputMarkdown optDirectory cfg optMdSection
+ (Map.elems allEntries)
+ else outputRST optDirectory optVersion cfg (Map.elems allEntries)
-------------------------------------------------------------------------------
-- RST output
@@ -218,6 +268,9 @@ formatEntry Entry {..} =
] ++
[ "(:ghc-mr:`" ++ show n ++ "`)"
| MRNumber n <- Set.toList entryMrs
+ ] ++
+ [ "(:clc:`" ++ show n ++ "`)"
+ | CLCNumber n <- Set.toList entryClcs
]
description = maybe "" (\d -> "\n" ++ trim d ++ "\n\n") entryDescription
@@ -262,25 +315,281 @@ generateIncludedLibraries baseDir preamble libs = do
where
fst3 (a, _, _) = a
- extractField :: String -> String -> Maybe String
- extractField fieldName contents =
- case mapMaybe (matchField fieldName) (lines contents) of
- (v:_) -> Just v
- [] -> Nothing
-
- matchField :: String -> String -> Maybe String
- matchField fieldName line =
- let stripped = dropWhile isSpace line
- (key, rest) = break (\c -> c == ':' || isSpace c) stripped
- in if map toLower' key == map toLower' fieldName
- then case dropWhile isSpace rest of
- (':':val) -> Just (trim (dropWhile isSpace val))
- _ -> Nothing
- else Nothing
-
- toLower' c
- | c >= 'A' && c <= 'Z' = toEnum (fromEnum c + 32)
- | otherwise = c
+extractField :: String -> String -> Maybe String
+extractField fieldName contents =
+ case mapMaybe (matchField fieldName) (lines contents) of
+ (v:_) -> Just v
+ [] -> Nothing
+
+matchField :: String -> String -> Maybe String
+matchField fieldName line =
+ let stripped = dropWhile isSpace line
+ (key, rest) = break (\c -> c == ':' || isSpace c) stripped
+ in if map toLower' key == map toLower' fieldName
+ then case dropWhile isSpace rest of
+ (':':val) -> Just (trim (dropWhile isSpace val))
+ _ -> Nothing
+ else Nothing
+
+toLower' :: Char -> Char
+toLower' c
+ | c >= 'A' && c <= 'Z' = toEnum (fromEnum c + 32)
+ | otherwise = c
+
+-------------------------------------------------------------------------------
+-- Markdown output
+-------------------------------------------------------------------------------
+
+-- | Emit per-library Markdown bullets to stdout.
+--
+-- With 'mSect' set, emit just that section's bullets (used interactively).
+-- Without it, emit every section listed in @markdown-targets:@, separated
+-- by HTML comments naming each section
+outputMarkdown
+ :: FilePath -- ^ changelog.d directory (used to locate cabal files)
+ -> Cfg
+ -> Maybe String -- ^ --section <key>
+ -> [Entry]
+ -> IO ()
+outputMarkdown dir Cfg{..} mSect entries = do
+ targets <- case mSect of
+ Just key -> case find ((== key) . mtSection) cfgMarkdownTargets of
+ Nothing -> exitWithExc $ PlainError $
+ "Unknown markdown section: " ++ key
+ ++ "\nKnown sections: "
+ ++ intercalate ", " (map mtSection cfgMarkdownTargets)
+ Just mt -> pure [mt]
+ Nothing -> pure cfgMarkdownTargets
+
+ let multi = isNothing mSect
+ baseDir = takeDirectory (dropTrailingPathSeparator dir)
+
+ case mSect of
+ Just key | not (any (\mt -> mtSection mt == key) cfgMarkdownTargets) ->
+ -- impossible; handled above
+ pure ()
+ Just key | null (entriesFor key entries) ->
+ exitWithExc $ PlainError $ "No entries for section " ++ key
+ _ -> pure ()
+
+ for_ targets $ \mt -> do
+ let es = entriesFor (mtSection mt) entries
+ unless (null es) $ do
+ when multi $ do
+ putStrLn $ "<!-- ===== " ++ mtSection mt
+ ++ " (" ++ mtPath mt ++ ") ===== -->"
+ putStrLn ""
+ libVer <- readLibraryVersion baseDir (mtPath mt)
+ putStrLn $ "## " ++ libVer ++ " *TBA*"
+ putStrLn ""
+ for_ (sortBy (flip compare `on` hasDescription) es) $ \entry ->
+ putStr (formatEntryMd entry)
+ when multi $ putStrLn ""
+
+entriesFor :: String -> [Entry] -> [Entry]
+entriesFor key = filter $ \e -> case entrySection e of
+ Just (Section s) -> s == key
+ Nothing -> False
+
+-- | Given the path of a library's @changelog.md@ (repo-relative), find the
+-- sibling @*.cabal@ (or @*.cabal.in@) and read the @version:@ field.
+readLibraryVersion :: FilePath -> FilePath -> IO String
+readLibraryVersion baseDir mdPath = do
+ let libDir = takeDirectory mdPath
+ libDirFs = baseDir </> libDir
+ exists <- doesDirectoryExist libDirFs
+ if not exists
+ then do
+ hPutStrLn stderr $ "Warning: directory does not exist: " ++ libDirFs
+ pure "?.?.?"
+ else do
+ candidates <- listDirectory libDirFs
+ let cabals = filter (\f -> ".cabal" `isSuffixOf` f) candidates
+ -- Prefer non-templated *.cabal over *.cabal.in (the former is
+ -- the rendered file Hadrian needs before invoking us).
+ ranked = sortBy (compare `on` (\f -> if ".cabal.in" `isSuffixOf` f then (1::Int) else 0)) cabals
+ case ranked of
+ [] -> do
+ hPutStrLn stderr $
+ "Warning: no .cabal file under " ++ libDir
+ pure "?.?.?"
+ (cf:_) -> do
+ contents <- readFile (libDirFs </> cf)
+ case extractField "version" contents of
+ Just v -> pure v
+ Nothing -> do
+ hPutStrLn stderr $
+ "Warning: could not parse version from " ++ libDir </> cf
+ pure "?.?.?"
+
+-- | Format an Entry as a Markdown bullet. Mirrors 'formatEntry' for RST
+-- but emits Markdown links for issues/MRs/CLC and rewrites RST inline
+-- markup to markdown.
+formatEntryMd :: Entry -> String
+formatEntryMd Entry{..} = indentBulletMd (header ++ description)
+ where
+ header = unwords $
+ [ rstToMarkdown entrySynopsis ] ++
+ [ mdLink ("#" ++ show n)
+ ("https://gitlab.haskell.org/ghc/ghc/issues/" ++ show n)
+ | IssueNumber n <- Set.toList entryIssues
+ ] ++
+ [ mdLink ("!" ++ show n)
+ ("https://gitlab.haskell.org/ghc/ghc/-/merge_requests/" ++ show n)
+ | MRNumber n <- Set.toList entryMrs
+ ] ++
+ [ mdLink ("CLC proposal #" ++ show n)
+ ("https://github.com/haskell/core-libraries-committee/issues/" ++ show n)
+ | CLCNumber n <- Set.toList entryClcs
+ ]
+
+ description = maybe "" (\d -> "\n\n" ++ rstToMarkdown (trim d) ++ "\n") entryDescription
+
+ mdLink :: String -> String -> String
+ mdLink txt url = "(" ++ "[" ++ txt ++ "](" ++ url ++ ")" ++ ")"
+
+-- | Indent text as a Markdown bullet: the first line gets @"* "@ prefix,
+-- subsequent lines are indented two spaces. Mirrors 'indentBullet'.
+indentBulletMd :: String -> String
+indentBulletMd = unlines . go . lines
+ where
+ go [] = []
+ go (x:xs) = ("* " ++ x) : map indentLine xs
+ indentLine "" = ""
+ indentLine s = " " ++ s
+
+-------------------------------------------------------------------------------
+-- RST -> Markdown rewriting
+-------------------------------------------------------------------------------
+--
+-- Applies the following rules:
+--
+-- | RST | Markdown |
+-- | -------------------------------------------------| ------------------------------------------------------------------------------------------------------ |
+-- | ``code`` (double-backtick) | `code` (single-backtick) |
+-- | `text <url>`_ | [text](url) |
+-- | :ghc-ticket:`N` | [#N](https://gitlab.haskell.org/ghc/ghc/issues/N) |
+-- | :ghc-mr:`N` | [!N](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/N) |
+-- | :ghc-wiki:`p` | [p](https://gitlab.haskell.org/ghc/ghc/wikis/p) |
+-- | :clc:`N` | [CLC proposal #N](https://github.com/haskell/core-libraries-committee/issues/N) |
+-- | :ghc-flag:`-foo` | `-foo` |
+-- | :extension:`E` | `E` |
+-- | :ghci-cmd:`X`, :rts-flag:`X` | `X` |
+-- | :base-ref:`Mod.id` `` | `Mod.id` |
+-- | :th-ref:, :cabal-ref: ,:ghc-prim-ref: | `ref` |
+-- | .. code-block:: lang + indented body | Triple-backtick fenced block with `lang` |
+-- | .. note:: / .. warning:: | `> **Note:**` / `> **Warning:**` blockquote |
+
+rstToMarkdown :: String -> String
+rstToMarkdown s =
+ let trailingNL = not (null s) && last s == '\n'
+ body = intercalate "\n" . blockPass . lines . inlinePass $ s
+ in body ++ (if trailingNL then "\n" else "")
+
+inlinePass :: String -> String
+inlinePass [] = []
+-- Double-backtick code: ``code`` → `code`
+inlinePass ('`':'`':rest) =
+ case breakOnSubstring "``" rest of
+ (body, _:_:after) -> "`" ++ body ++ "`" ++ inlinePass after
+ _ -> '`':'`': inlinePass rest
+-- RST hyperlink: `text <url>`_ → [text](url)
+inlinePass ('`':rest)
+ | Just (txt, url, after) <- pickRstLink rest =
+ "[" ++ trim txt ++ "](" ++ url ++ ")" ++ inlinePass after
+-- :role:`body` interpreted-text role
+inlinePass (':':rest)
+ | Just (role, body, after) <- pickRole rest =
+ renderRole role body ++ inlinePass after
+inlinePass (c:cs) = c : inlinePass cs
+
+breakOnSubstring :: String -> String -> (String, String)
+breakOnSubstring needle = go
+ where
+ go [] = ([], [])
+ go s@(c:cs)
+ | needle `isPrefixOf` s = ([], s)
+ | otherwise =
+ let (a, b) = go cs in (c:a, b)
+
+-- | Try to consume a @\`text \<url\>\`_@ RST hyperlink starting after the
+-- leading backtick. Returns @(text, url, rest)@ on success.
+pickRstLink :: String -> Maybe (String, String, String)
+pickRstLink xs = do
+ let (txt, r1) = break (== '<') xs
+ case r1 of
+ '<':r2 -> do
+ let (url, r3) = break (== '>') r2
+ case r3 of
+ '>':'`':'_':'_':after -> Just (txt, url, after)
+ '>':'`':'_':after -> Just (txt, url, after)
+ _ -> Nothing
+ _ -> Nothing
+
+-- | Try to consume a @role:\`body\`@ interpreted-text role starting just
+-- after the leading colon.
+pickRole :: String -> Maybe (String, String, String)
+pickRole xs =
+ let (name, r1) = span (\c -> isAlpha c || c == '-') xs
+ in case (null name, r1) of
+ (False, ':':'`':r2) -> case break (== '`') r2 of
+ (body, '`':after) | not (null body) -> Just (name, body, after)
+ _ -> Nothing
+ _ -> Nothing
+
+-- | Render a known interpreted-text role to Markdown.
+renderRole :: String -> String -> String
+renderRole role body = case role of
+ "ghc-ticket" -> mdLink ("#" ++ body) ("https://gitlab.haskell.org/ghc/ghc/issues/" ++ body)
+ "ghc-mr" -> mdLink ("!" ++ body) ("https://gitlab.haskell.org/ghc/ghc/-/merge_requests/" ++ body)
+ "ghc-wiki" -> mdLink body ("https://gitlab.haskell.org/ghc/ghc/wikis/" ++ body)
+ "clc" -> mdLink ("CLC proposal #" ++ body)
+ ("https://github.com/haskell/core-libraries-committee/issues/" ++ body)
+ "ghc-flag" -> "`" ++ body ++ "`"
+ "extension" -> "`" ++ body ++ "`"
+ "ghci-cmd" -> "`" ++ body ++ "`"
+ "rts-flag" -> "`" ++ body ++ "`"
+ "doc" -> body
+ "base-ref" -> "`" ++ body ++ "`"
+ "th-ref" -> "`" ++ body ++ "`"
+ "cabal-ref" -> "`" ++ body ++ "`"
+ "ghc-prim-ref" -> "`" ++ body ++ "`"
+ _ -> ":" ++ role ++ ":`" ++ body ++ "`"
+ where
+ mdLink txt url = "[" ++ txt ++ "](" ++ url ++ ")"
+
+-- | Block-level transforms applied after the inline pass.
+blockPass :: [String] -> [String]
+blockPass [] = []
+blockPass (l:rest)
+ | Just lang <- stripPrefix ".. code-block:: " (trim l) =
+ let (body, rest') = takeIndentedBlock rest
+ in ("```" ++ lang) : map (dropIndent 4) body ++ ["```"] ++ blockPass rest'
+ | trim l == ".. note::" =
+ let (body, rest') = takeIndentedBlock rest
+ in "> **Note:**" : map (("> " ++) . dropIndent 4) body ++ blockPass rest'
+ | trim l == ".. warning::" =
+ let (body, rest') = takeIndentedBlock rest
+ in "> **Warning:**" : map (("> " ++) . dropIndent 4) body ++ blockPass rest'
+ | otherwise = l : blockPass rest
+
+-- | Take a block of indented (or blank) lines following a directive; stop
+-- at the first non-blank, non-indented line.
+takeIndentedBlock :: [String] -> ([String], [String])
+takeIndentedBlock = go . dropWhile null
+ where
+ go [] = ([], [])
+ go (x:xs)
+ | null x = let (a, b) = go xs in (x:a, b)
+ | take 1 x == " " = let (a, b) = go xs in (x:a, b)
+ | otherwise = ([], x:xs)
+
+-- | Drop up to @n@ leading spaces from a line.
+dropIndent :: Int -> String -> String
+dropIndent _ "" = ""
+dropIndent 0 s = s
+dropIndent n (' ':cs) = dropIndent (n-1) cs
+dropIndent _ s = s
-------------------------------------------------------------------------------
-- Section grouping
@@ -303,10 +612,13 @@ groupBySections sectionDefs entries =
-------------------------------------------------------------------------------
data Opts = Opts
- { optDirectory :: FilePath
- , optVersion :: Maybe String
- , optValidate :: Bool
- , optExpectMR :: Maybe Int -- ^ Expected MR number
+ { optDirectory :: FilePath
+ , optVersion :: Maybe String
+ , optValidate :: Bool
+ , optExpectMR :: Maybe Int -- ^ Expected MR number
+ , optExpectCLC :: Bool -- ^ Require entry matched by --expect-mr to have clc:
+ , optMarkdown :: Bool -- ^ Emit per-library Markdown to stdout
+ , optMdSection :: Maybe String -- ^ Restrict markdown emission to one section
}
deriving (Show)
@@ -332,6 +644,24 @@ instance C.Parsec MRNumber where
instance C.Pretty MRNumber where
pretty (MRNumber n) = PP.char '!' PP.<> PP.int n
+newtype CLCNumber = CLCNumber Int
+ deriving (Eq, Ord, Show)
+
+instance C.Parsec CLCNumber where
+ parsec = do
+ _ <- P.char '#'
+ CLCNumber <$> P.integral
+
+instance C.Pretty CLCNumber where
+ pretty (CLCNumber n) = PP.char '#' PP.<> PP.int n
+
+data MarkdownTarget = MarkdownTarget
+ { mtSection :: String -- ^ section key matching an entry's `section:`
+ , mtPath :: FilePath -- ^ target changelog path, repo-relative
+ , mtRequiredFields :: [String] -- ^ extra required-fields when this section is used
+ }
+ deriving (Show)
+
newtype Section = Section String
deriving (Eq, Ord, Show)
@@ -351,6 +681,7 @@ data Cfg = Cfg
, cfgPreamble :: String
, cfgIncludedLibraries :: [(FilePath, String)] -- ^ (cabalPath, description)
, cfgIncludedLibrariesPreamble :: String
+ , cfgMarkdownTargets :: [MarkdownTarget]
}
deriving (Show)
@@ -364,6 +695,7 @@ parseConfig fields0 = do
, cfgPreamble = cfgRawPreamble raw
, cfgIncludedLibraries = parseIncludedLibraries (cfgRawIncludedLibraries raw)
, cfgIncludedLibrariesPreamble = cfgRawIncludedLibrariesPreamble raw
+ , cfgMarkdownTargets = parseMarkdownTargets (cfgRawMarkdownTargets raw)
}
where
(fields, sections) = C.partitionFields fields0
@@ -378,6 +710,7 @@ data CfgRaw = CfgRaw
, cfgRawPreamble :: String
, cfgRawIncludedLibraries :: String
, cfgRawIncludedLibrariesPreamble :: String
+ , cfgRawMarkdownTargets :: String
}
cfgRawRequiredFieldsL :: Functor f => (Set String -> f (Set String)) -> CfgRaw -> f CfgRaw
@@ -395,6 +728,9 @@ cfgRawIncludedLibrariesL f s = (\x -> s { cfgRawIncludedLibraries = x }) <$> f (
cfgRawIncludedLibrariesPreambleL :: Functor f => (String -> f String) -> CfgRaw -> f CfgRaw
cfgRawIncludedLibrariesPreambleL f s = (\x -> s { cfgRawIncludedLibrariesPreamble = x }) <$> f (cfgRawIncludedLibrariesPreamble s)
+cfgRawMarkdownTargetsL :: Functor f => (String -> f String) -> CfgRaw -> f CfgRaw
+cfgRawMarkdownTargetsL f s = (\x -> s { cfgRawMarkdownTargets = x }) <$> f (cfgRawMarkdownTargets s)
+
cfgRawGrammar :: C.ParsecFieldGrammar CfgRaw CfgRaw
cfgRawGrammar = CfgRaw
<$> C.monoidalFieldAla "required-fields" (C.alaSet' C.FSep C.Token) cfgRawRequiredFieldsL
@@ -402,6 +738,7 @@ cfgRawGrammar = CfgRaw
<*> C.freeTextFieldDef "preamble" cfgRawPreambleL
<*> C.freeTextFieldDef "included-libraries" cfgRawIncludedLibrariesL
<*> C.freeTextFieldDef "included-libraries-preamble" cfgRawIncludedLibrariesPreambleL
+ <*> C.freeTextFieldDef "markdown-targets" cfgRawMarkdownTargetsL
parseSections :: String -> [(String, String)]
parseSections = mapMaybe parseLine . lines
@@ -419,6 +756,20 @@ parseIncludedLibraries = mapMaybe parseLine . lines
(path, rest) | not (null path) -> Just (path, trim rest)
_ -> Nothing
+-- | Parse the @markdown-targets:@ block.
+--
+-- Each non-empty, non-comment line is
+-- <section-key> <path> [<extra-required-field>...]
+-- The extra tokens declare additional fields required of any entry whose section: matches.
+parseMarkdownTargets :: String -> [MarkdownTarget]
+parseMarkdownTargets = mapMaybe parseLine . lines
+ where
+ parseLine l = case words (trim l) of
+ [] -> Nothing
+ [_] -> Nothing -- need at least section + path
+ (sect:path:extra) ->
+ Just $ MarkdownTarget sect path extra
+
-------------------------------------------------------------------------------
-- Entry
-------------------------------------------------------------------------------
@@ -428,6 +779,7 @@ data Entry = Entry
, entryDescription :: Maybe String
, entryMrs :: Set MRNumber
, entryIssues :: Set IssueNumber
+ , entryClcs :: Set CLCNumber
, entrySection :: Maybe Section
}
deriving (Show)
@@ -447,6 +799,9 @@ entryMrsL f s = (\x -> s { entryMrs = x }) <$> f (entryMrs s)
entryIssuesL :: Functor f => (Set IssueNumber -> f (Set IssueNumber)) -> Entry -> f Entry
entryIssuesL f s = (\x -> s { entryIssues = x }) <$> f (entryIssues s)
+entryClcsL :: Functor f => (Set CLCNumber -> f (Set CLCNumber)) -> Entry -> f Entry
+entryClcsL f s = (\x -> s { entryClcs = x }) <$> f (entryClcs s)
+
entrySectionL :: Functor f => (Maybe Section -> f (Maybe Section)) -> Entry -> f Entry
entrySectionL f s = (\x -> s { entrySection = x }) <$> f (entrySection s)
@@ -477,6 +832,7 @@ entryGrammar = Entry
<*> C.freeTextField "description" entryDescriptionL
<*> C.monoidalFieldAla "mrs" (C.alaSet C.NoCommaFSep) entryMrsL
<*> C.monoidalFieldAla "issues" (C.alaSet C.NoCommaFSep) entryIssuesL
+ <*> C.monoidalFieldAla "clc" (C.alaSet C.NoCommaFSep) entryClcsL
<*> C.optionalField "section" entrySectionL
-------------------------------------------------------------------------------
@@ -510,8 +866,21 @@ validateEntry cfg entry = foldMap (\validator -> validator cfg entry)
validateRequiredFields :: Validator
validateRequiredFields Cfg{..} Entry{..} = fmap RequiredFieldError $
- mapMaybe checkField $ Set.toList cfgRequiredFields
+ mapMaybe checkField $ Set.toList effectiveRequired
where
+ -- Effective required-fields = global cfgRequiredFields + extras for the
+ -- entry's section as declared in cfgMarkdownTargets
+ -- (e.g. `base` adds `clc`).
+ effectiveRequired =
+ cfgRequiredFields `Set.union`
+ Set.fromList
+ [ f
+ | Just (Section sect) <- [entrySection]
+ , mt <- cfgMarkdownTargets
+ , mtSection mt == sect
+ , f <- mtRequiredFields mt
+ ]
+
checkField :: String -> Maybe RequiredFieldError
checkField reqField = case fieldIsEmpty reqField of
Left err -> Just err
@@ -522,6 +891,7 @@ validateRequiredFields Cfg{..} Entry{..} = fmap RequiredFieldError $
fieldIsEmpty "description" = pure $ isNothing entryDescription
fieldIsEmpty "mrs" = pure $ null entryMrs
fieldIsEmpty "issues" = pure $ null entryIssues
+ fieldIsEmpty "clc" = pure $ null entryClcs
fieldIsEmpty "section" = pure $ isNothing entrySection
fieldIsEmpty f = Left $ UnknownRequiredField f
=====================================
utils/changelog-d/README.md
=====================================
@@ -23,46 +23,55 @@ description: {
**Required fields:** `section`, `synopsis`, `mrs`, `issues`
-**Optional fields:** `description`
+**Optional fields:** `description`, `clc`
+
+**Conditionally required**: entries with `section: base` MUST also include a `clc:`
+field referencing the CLC proposal authorising the change.
If your MR doesn't need a changelog entry, apply the `no-changelog` label.
### Fields
-| Field | Format | Description |
-| ------------- | ------------------------------- | -----------------------------------------------|
-| `synopsis` | Free-form RST | Brief description of the change |
-| `mrs` | `!N` (space-separated) | MR number(s) |
-| `issues` | `#N` (space-separated) | Issue number(s) |
-| `section` | Section key (see below) | GHC component |
-| `description` | Free-form RST in `{ ... }` | Extended details. Printed after the main entry |
+| Field | Format | Description |
+| ------------- | -------------------------- | ----------------------------------------------------- |
+| `synopsis` | Free-form RST | Brief description of the change |
+| `mrs` | `!N` (space-separated) | MR number(s) |
+| `issues` | `#N` (space-separated) | Issue number(s) |
+| `clc` | `#N` (space-separated) | CLC proposal number(s). Required for `section: base`. |
+| `section` | Section key (see below) | GHC component |
+| `description` | Free-form RST | Extended details. Printed after the main entry |
### Section keys
-| Key | Heading |
-| ------------------ | -------------------------------- |
-| `language` | Language |
-| `compiler` | Compiler |
-| `profiling` | Profiling |
-| `codegen` | Code generation |
-| `llvm-backend` | LLVM backend |
-| `js-backend` | JavaScript backend |
-| `wasm-backend` | WebAssembly backend |
-| `ghci` | GHCi |
-| `rts` | Runtime system |
-| `linker` | Linker |
-| `bytecode` | Bytecode compiler |
-| `packaging` | Packaging & build system |
-| `cmm` | Cmm |
-| `build-tools` | Build tools |
-| `base` | ``base`` library |
-| `ghc-prim` | ``ghc-prim`` library |
-| `ghc-lib` | ``ghc`` library |
-| `ghc-heap` | ``ghc-heap`` library |
-| `ghc-experimental` | ``ghc-experimental`` library |
-| `template-haskell` | ``template-haskell`` library |
-| `ghc-pkg` | ``ghc-pkg`` |
-| `ghc-toolchain` | ``ghc-toolchain`` |
+The "Markdown" column indicates whether entries in that section also flow to
+a per-library `changelog.md`. Sections without a
+Markdown target appear only in the GHC release notes RST.
+
+| Key | Heading | Markdown target |
+| ------------------ | ---------------------------- | ---------------------------------------------- |
+| `language` | Language | — |
+| `compiler` | Compiler | — |
+| `profiling` | Profiling | — |
+| `codegen` | Code generation | — |
+| `llvm-backend` | LLVM backend | — |
+| `js-backend` | JavaScript backend | — |
+| `wasm-backend` | WebAssembly backend | — |
+| `ghci` | GHCi | — |
+| `rts` | Runtime system | — |
+| `linker` | Linker | — |
+| `bytecode` | Bytecode compiler | — |
+| `packaging` | Packaging & build system | — |
+| `cmm` | Cmm | — |
+| `build-tools` | Build tools | — |
+| `base` | ``base`` library | `libraries/base/changelog.md` |
+| `ghc-internal` | ``ghc-internal`` library | `libraries/ghc-internal/CHANGELOG.md` |
+| `ghc-prim` | ``ghc-prim`` library | `libraries/ghc-prim/changelog.md` |
+| `ghc-lib` | ``ghc`` library | — |
+| `ghc-heap` | ``ghc-heap`` library | — |
+| `ghc-experimental` | ``ghc-experimental`` library | `libraries/ghc-experimental/CHANGELOG.md` |
+| `template-haskell` | ``template-haskell`` library | `libraries/template-haskell/changelog.md` |
+| `ghc-pkg` | ``ghc-pkg`` | — |
+| `ghc-toolchain` | ``ghc-toolchain`` | — |
### Entry format
@@ -83,20 +92,34 @@ library's `Distribution.Fields` parser
## Configuration
The file `changelog.d/config` declares the structure of the generated release
-notes: required fields, section names, preamble text, and the included-libraries
-table. Edit it when adding new sections or changing release note formatting.
+notes: required fields, section names, preamble text, the included-libraries
+table, and the `markdown-targets:` mapping that wires sections to per-library
+`changelog.md` files. Edit it when adding new sections or changing release-note
+formatting.
+
+The `markdown-targets:` block is the source of truth for "which section's
+entries get a Markdown emission, and which extra fields (e.g. `clc`) are
+required for that section." Each line is `<section-key> <path> [<extra-required-field>...]`.
## For maintainers
### Hadrian targets
-Generate release notes:
+Generate RST release notes (existing behaviour):
```
hadrian/build changelog # uses project version
hadrian/build changelog --changelog-version=10.2.1 # explicit version
```
Output: `docs/users_guide/<version>-notes.rst`
+Generate per-library Markdown bullets:
+
+```
+hadrian/build libraries-changelog-markdown
+```
+
+Output is one stream containing every configured `markdown-targets:` section.
+
Clear entries after branch cut:
```
@@ -108,3 +131,25 @@ Validate entries:
```
hadrian/build test --only=changelog-d
```
+
+### RST -> Markdown rewrite rules
+
+`--libraries-changelog-markdown` rewrites the inline RST in each entry to Markdown:
+
+| RST | Markdown |
+| -------------------------------------------------| ------------------------------------------------------------------------------------------------------ |
+| ``code`` (double-backtick) | `code` (single-backtick) |
+| `text <url>`_ | [text](url) |
+| :ghc-ticket:`N` | [#N](https://gitlab.haskell.org/ghc/ghc/issues/N) |
+| :ghc-mr:`N` | [!N](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/N) |
+| :ghc-wiki:`p` | [p](https://gitlab.haskell.org/ghc/ghc/wikis/p) |
+| :clc:`N` | [CLC proposal #N](https://github.com/haskell/core-libraries-committee/issues/N) |
+| :ghc-flag:`-foo` | `-foo` |
+| :extension:`E` | `E` |
+| :ghci-cmd:`X`, :rts-flag:`X` | `X` |
+| :base-ref:`Mod.id` `` | `Mod.id` |
+| :th-ref:, :cabal-ref: ,:ghc-prim-ref: | `ref` |
+| .. code-block:: lang + indented body | Triple-backtick fenced block with `lang` |
+| .. note:: / .. warning:: | `> **Note:**` / `> **Warning:**` blockquote |
+
+
=====================================
utils/changelog-d/tests/config
=====================================
@@ -0,0 +1,15 @@
+-- Minimal config for running changelog-d against the test fixture in
+-- this directory. Mirrors the structure of the project-root
+-- changelog.d/config but only declares the sections + markdown-targets
+-- the fixture exercises. The path declared in markdown-targets is a
+-- placeholder; readLibraryVersion warns and falls back to "?.?.?" when
+-- the directory does not exist, which is captured in the golden output.
+required-fields: synopsis mrs issues section
+
+sections: {
+ base ``base`` library
+}
+
+markdown-targets: {
+ base _fake/changelog.md clc
+}
=====================================
utils/changelog-d/tests/expected/test-parser-rewriter.md
=====================================
@@ -0,0 +1,33 @@
+## ?.?.? *TBA*
+
+* Self-test fixture exercising the parser/rewriter. Uses double-backtick `code`,
+ RST hyperlinks [the changelog wiki](https://gitlab.haskell.org/ghc/ghc/-/wikis/contributing/changelog),
+ GHC-flavoured roles [#12345](https://gitlab.haskell.org/ghc/ghc/issues/12345), [!6789](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6789), [commentary/compiler](https://gitlab.haskell.org/ghc/ghc/wikis/commentary/co…,
+ [CLC proposal #123](https://github.com/haskell/core-libraries-committee/issues/123), `-fxxx`, `TypeApplications`, `:type`,
+ `-N`, haddock cross-refs `Data.Maybe.fromMaybe`,
+ `Language.Haskell.TH.Lib`, `Distribution.Simple`,
+ `GHC.Prim`, the internal-doc role, and an :unknown-role:`pass-through`. ([#26002](https://gitlab.haskell.org/ghc/ghc/issues/26002)) ([!15830](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/15830)) ([CLC proposal #0](https://github.com/haskell/core-libraries-committee/issues/0))
+
+ This description block exercises block-level rewrites and inline rewrites
+ inside a multi-line braced field.
+
+ Inline forms inside the description: `inline code`, `DataKinds`,
+ [!15830](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/15830), `Control.Applicative`, and a [bare RST link](https://example.invalid/).
+
+ > **Note:**
+ > This is an RST note admonition. It should render as a Markdown
+ > blockquote prefixed with `> **Note:**`.
+ >
+ > **Warning:**
+ > This is an RST warning admonition. It should render as a Markdown
+ > blockquote prefixed with `> **Warning:**`.
+ >
+ ```haskell
+ foo :: Int -> Int
+ foo x = x + 1
+ bar :: String
+ bar = "hello"
+
+ ```
+ After the code block, plain prose continues. Verify that the renderer
+ exits the fenced block correctly and resumes paragraph flow here.
=====================================
utils/changelog-d/tests/test-parser-rewriter
=====================================
@@ -0,0 +1,48 @@
+-- This file exercises every construct supported by changelog-d's parser
+-- and RST -> Markdown rewriter. It is kept in tree as a regression
+-- fixture: when the parser or rewriter is touched, run
+-- cabal run changelog-d -- --validate changelog.d/
+-- cabal run changelog-d -- --libraries-changelog-markdown changelog.d/
+-- and visually compare the output. The tool treats this like any
+-- other fragment, so it WILL appear in `--version`'ed RST and in
+-- `--libraries-changelog-markdown` output. Delete it before cutting a
+-- release, or move it under utils/changelog-d/tests/ if/when that
+-- directory is wired up.
+section: base
+synopsis: Self-test fixture exercising the parser/rewriter. Uses double-backtick ``code``,
+ RST hyperlinks `the changelog wiki <https://gitlab.haskell.org/ghc/ghc/-/wikis/contributing/changelog>`_,
+ GHC-flavoured roles :ghc-ticket:`12345`, :ghc-mr:`6789`, :ghc-wiki:`commentary/compiler`,
+ :clc:`123`, :ghc-flag:`-fxxx`, :extension:`TypeApplications`, :ghci-cmd:`:type`,
+ :rts-flag:`-N`, haddock cross-refs :base-ref:`Data.Maybe.fromMaybe`,
+ :th-ref:`Language.Haskell.TH.Lib`, :cabal-ref:`Distribution.Simple`,
+ :ghc-prim-ref:`GHC.Prim`, the :doc:`internal-doc` role, and an :unknown-role:`pass-through`.
+issues: #26002
+mrs: !15830
+clc: #0
+
+description: {
+ This description block exercises block-level rewrites and inline rewrites
+ inside a multi-line braced field.
+
+ Inline forms inside the description: ``inline code``, :extension:`DataKinds`,
+ :ghc-mr:`15830`, :base-ref:`Control.Applicative`, and a `bare RST link
+ <https://example.invalid/>`_.
+
+ .. note::
+ This is an RST note admonition. It should render as a Markdown
+ blockquote prefixed with ``> **Note:**``.
+
+ .. warning::
+ This is an RST warning admonition. It should render as a Markdown
+ blockquote prefixed with ``> **Warning:**``.
+
+ .. code-block:: haskell
+
+ foo :: Int -> Int
+ foo x = x + 1
+ bar :: String
+ bar = "hello"
+
+ After the code block, plain prose continues. Verify that the renderer
+ exits the fenced block correctly and resumes paragraph flow here.
+}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/553822f637a3585068d147c9c050cad…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/553822f637a3585068d147c9c050cad…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/27183] changelog-d: Add support for emitting markdown for library changelogs
by Zubin (＠wz1000) 28 Apr '26
by Zubin (＠wz1000) 28 Apr '26
28 Apr '26
Zubin pushed to branch wip/27183 at Glasgow Haskell Compiler / GHC
Commits:
ed6faa1b by Zubin Duggal at 2026-04-28T17:06:04+05:30
changelog-d: Add support for emitting markdown for library changelogs
Now library changelog entries are written in changelog.d/ uniformly, and the
changelog-d tool gains functionality to output markdown fragments for the
library changelog files. The fragments will be spliced into the respective files
at release time by the release manager.
Also changes the lint-changelog CI job to ensure that changes which touch base
have a changelog entry and a CLC proposal.
Fixes #27183
- - - - -
12 changed files:
- .gitlab-ci.yml
- .gitlab/merge_request_templates/Default.md
- changelog.d/config
- docs/users_guide/ghc_config.py.in
- hadrian/src/Rules/Changelog.hs
- libraries/integer-gmp/integer-gmp.cabal
- testsuite/tests/linters/Makefile
- utils/changelog-d/ChangelogD.hs
- utils/changelog-d/README.md
- + utils/changelog-d/tests/config
- + utils/changelog-d/tests/expected/test-parser-rewriter.md
- + utils/changelog-d/tests/test-parser-rewriter
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -247,6 +247,9 @@ ghc-linters:
# Check that MRs include a changelog entry in changelog.d/.
# Skipped if the MR has the ~"no-changelog" label.
+#
+# If MR's diff touches libraries/base/, the changelog must also have a non-empty
+# `clc:` field.
lint-changelog:
stage: tool-lint
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV"
@@ -254,6 +257,7 @@ lint-changelog:
variables:
BUILD_FLAVOUR: default
CHANGELOG_EXPECT_MR: "$CI_MERGE_REQUEST_IID"
+ CHANGELOG_EXPECT_CLC: ""
script:
# Check that the MR adds at least one changelog entry
- git fetch "$CI_MERGE_REQUEST_PROJECT_URL" "$CI_MERGE_REQUEST_TARGET_BRANCH_NAME"
@@ -276,6 +280,10 @@ lint-changelog:
when: never
- if: '$CI_MERGE_REQUEST_LABELS =~ /.*no-changelog.*/'
when: never
+ - changes:
+ - libraries/base/**/*
+ variables:
+ CHANGELOG_EXPECT_CLC: "1"
- if: $CI_MERGE_REQUEST_ID
- *drafts-can-fail-lint
=====================================
.gitlab/merge_request_templates/Default.md
=====================================
@@ -23,7 +23,8 @@ https://gitlab.haskell.org/ghc/ghc/-/wikis/Contributing-a-Patch
- [ ] This MR solves the problem described in the following issue: <!-- issue number here (please open a new issue if there isn't one) -->
- [ ] A changelog entry was added in `changelog.d/` for user-facing changes (see [changelog guide][changelog]).
If this MR does not need a changelog entry, the ~"no-changelog" label was applied.
-- [ ] This MR does not make any significant changes to `base`, or it has an accompanying [CLC proposal](https://github.com/haskell/core-libraries-committee#base-package).
+- [ ] This MR does not make any significant changes to `base`, or it has an accompanying [CLC proposal](https://github.com/haskell/core-libraries-committee#base-package)
+ and the changelog fragment uses `section: base` with the `clc: #<proposal>` field set.
- [ ] If this MR has the potential to break user programs, the ~"user-facing" label was applied to
test against head.hackage.
- [ ] All commits are either individually buildable or squashed.
=====================================
changelog.d/config
=====================================
@@ -27,6 +27,7 @@ sections: {
cmm Cmm
build-tools Build tools
base ``base`` library
+ ghc-internal ``ghc-internal`` library
ghc-prim ``ghc-prim`` library
ghc-lib ``ghc`` library
ghc-heap ``ghc-heap`` library
@@ -36,6 +37,18 @@ sections: {
ghc-toolchain ``ghc-toolchain``
}
+-- markdown-targets: sections that also need to end up in
+-- per-library changelog files. The optional third token
+-- lists extra fields that might be required for this section
+-- like `clc` for base.
+markdown-targets: {
+ base libraries/base/changelog.md clc
+ ghc-internal libraries/ghc-internal/CHANGELOG.md
+ ghc-prim libraries/ghc-prim/changelog.md
+ ghc-experimental libraries/ghc-experimental/CHANGELOG.md
+ template-haskell libraries/template-haskell/changelog.md
+}
+
included-libraries-preamble: {
The package database provided with this distribution also contains a number of
packages other than GHC itself. See the changelogs provided with these packages
=====================================
docs/users_guide/ghc_config.py.in
=====================================
@@ -7,12 +7,14 @@ if parse_version(sphinx.__version__) >= parse_version("4.0.0"):
'ghc-ticket': ('https://gitlab.haskell.org/ghc/ghc/issues/%s', '#%s'),
'ghc-wiki': ('https://gitlab.haskell.org/ghc/ghc/wikis/%s', '%s'),
'ghc-mr': ('https://gitlab.haskell.org/ghc/ghc/-/merge_requests/%s', '!%s'),
+ 'clc': ('https://github.com/haskell/core-libraries-committee/issues/%s', 'CLC proposal #%s'),
}
else:
extlinks = {
'ghc-ticket': ('https://gitlab.haskell.org/ghc/ghc/issues/%s', '#'),
'ghc-wiki': ('https://gitlab.haskell.org/ghc/ghc/wikis/%s', ''),
'ghc-mr': ('https://gitlab.haskell.org/ghc/ghc/-/merge_requests/%s', '!'),
+ 'clc': ('https://github.com/haskell/core-libraries-committee/issues/%s', 'CLC proposal #'),
}
libs_base_uri = '../libraries'
=====================================
hadrian/src/Rules/Changelog.hs
=====================================
@@ -11,8 +11,9 @@ import qualified System.Directory as IO
-- | Rules for generating and managing changelog entries.
--
-- Targets:
--- hadrian/build changelog -- generate release notes
+-- hadrian/build changelog -- generate RST release notes
-- hadrian/build changelog --changelog-version=10.2.1 -- with explicit version
+-- hadrian/build libraries-changelog-markdown -- emit per-library Markdown bullets to stdout
-- hadrian/build changelog-clear -- remove old entries
changelogRules :: Rules ()
changelogRules = do
@@ -25,19 +26,6 @@ changelogRules = do
ctx <- programContext stage0Boot changelogD
progPath <- programPath ctx
need [progPath]
-
- -- These cabal files are needed by changelog-d to determine the
- -- versions of packages shipped with GHC.
- let templatedCabalFiles = map pkgCabalFile
- [ ghcBoot
- , ghcBootTh
- , ghcExperimental
- , ghcInternal
- , ghci
- , compiler
- , ghcHeap
- , templateHaskell
- ]
need templatedCabalFiles
top <- topDirectory
@@ -47,6 +35,21 @@ changelogRules = do
:: Action ()
putSuccess $ "| Generated release notes: " ++ outFile
+ phony "libraries-changelog-markdown" $ do
+ ctx <- programContext stage0Boot changelogD
+ progPath <- programPath ctx
+ need [progPath]
+ need templatedCabalFiles
+
+ top <- topDirectory
+ -- cmd_ (no FileStdout) lets the binary's stdout flow through to
+ -- the invoking terminal, so the release manager can pipe it to a
+ -- file or scratch buffer.
+ cmd_ [progPath]
+ [ top -/- "changelog.d/"
+ , "--libraries-changelog-markdown"
+ ]
+
phony "changelog-clear" $ do
top <- topDirectory
let dir = top -/- "changelog.d"
@@ -54,3 +57,17 @@ changelogRules = do
let toRemove = filter (\f -> f /= "config" && not (isPrefixOf "." f)) entries
liftIO $ mapM_ (IO.removeFile . (dir -/-)) toRemove
putSuccess $ "| Removed " ++ show (length toRemove) ++ " changelog entries"
+ where
+ -- These cabal files are needed by changelog-d to determine the
+ -- versions of packages shipped with GHC.
+ templatedCabalFiles = map pkgCabalFile
+ [ ghcBoot
+ , ghcBootTh
+ , ghcExperimental
+ , ghcInternal
+ , ghci
+ , compiler
+ , ghcHeap
+ , templateHaskell
+ , base
+ ]
=====================================
libraries/integer-gmp/integer-gmp.cabal
=====================================
@@ -13,6 +13,9 @@ build-type: Simple
homepage: https://www.haskell.org/ghc/
bug-reports: https://gitlab.haskell.org/ghc/ghc/issues/new
+extra-source-files:
+ changelog.md
+
description:
This package used to provide an implementation of the standard 'Integer'
type based on the
=====================================
testsuite/tests/linters/Makefile
=====================================
@@ -30,8 +30,12 @@ notes:
(cd $(TOP)/.. && $(LINT_NOTES) broken-refs)
changelog-d:
-ifdef CHANGELOG_EXPECT_MR
+ifneq "$(CHANGELOG_EXPECT_MR)" ""
+ifneq "$(CHANGELOG_EXPECT_CLC)" ""
+ (cd $(TOP)/.. && $(CHANGELOG_D) changelog.d/ --validate --expect-mr $(CHANGELOG_EXPECT_MR) --expect-clc)
+else
(cd $(TOP)/.. && $(CHANGELOG_D) changelog.d/ --validate --expect-mr $(CHANGELOG_EXPECT_MR))
+endif
else
(cd $(TOP)/.. && $(CHANGELOG_D) changelog.d/ --validate)
endif
=====================================
utils/changelog-d/ChangelogD.hs
=====================================
@@ -10,15 +10,15 @@
module Main (main) where
import Control.Exception (Exception (..))
-import Control.Monad (unless, void, when)
-import Data.Char (isSpace)
+import Control.Monad (filterM, unless, void, when)
+import Data.Char (isAlpha, isSpace)
import Data.Foldable (for_, toList, traverse_)
import Data.Function (on)
-import Data.List (intercalate, sort, sortBy)
+import Data.List (find, intercalate, isPrefixOf, isSuffixOf, sort, sortBy, stripPrefix)
import Data.Maybe (isJust, isNothing, mapMaybe)
import Data.Set (Set)
import Data.Traversable (for)
-import System.Directory (listDirectory)
+import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)
import System.Environment (getArgs)
import System.Exit (exitFailure)
import System.FilePath ((</>), dropTrailingPathSeparator, takeDirectory)
@@ -58,16 +58,35 @@ usage = unlines
, " Collect changelog entries and produce release notes."
, ""
, "Options:"
- , " --version <version> Version number for RST file header (e.g. 10.2.1)"
- , " --validate Validate entries only, no output"
- , " --expect-mr <N> Check that at least one entry references MR !N"
- , " --help Show this help"
+ , " --version <version> Version number for RST file header (e.g. 10.2.1)"
+ , " --validate Validate entries only, no output"
+ , " --expect-mr <N> Check that at least one entry references MR !N"
+ , " --expect-clc Require the entry matched by --expect-mr"
+ , " to have a non-empty 'clc:' field. Used by"
+ , " CI for MRs touching base."
+ , " --libraries-changelog-markdown Emit per-library Markdown bullets to"
+ , " stdout (suppresses RST emission). Output"
+ , " is intended to be pasted into each"
+ , " libraries/<lib>/changelog.md by hand;"
+ , " --section <key> Restrict --libraries-changelog-markdown"
+ , " to a single section. Without this, all"
+ , " configured markdown-targets are emitted,"
+ , " separated by HTML-comment markers."
+ , " --help Show this help"
]
parseArgs :: [String] -> Either String Opts
parseArgs = go defaultOpts
where
- defaultOpts = Opts "changelog.d" Nothing False Nothing
+ defaultOpts = Opts
+ { optDirectory = "changelog.d"
+ , optVersion = Nothing
+ , optValidate = False
+ , optExpectMR = Nothing
+ , optExpectCLC = False
+ , optMarkdown = False
+ , optMdSection = Nothing
+ }
go opts [] = Right opts
go _ ("--help" : _) = Left ""
@@ -78,6 +97,11 @@ parseArgs = go defaultOpts
[(mr, "")] -> go opts { optExpectMR = Just mr } rest
_ -> Left $ "--expect-mr requires a number, got: " ++ n
go _ ("--expect-mr" : []) = Left "--expect-mr requires an argument"
+ go opts ("--expect-clc" : rest) = go opts { optExpectCLC = True } rest
+ go opts ("--libraries-changelog-markdown" : rest) =
+ go opts { optMarkdown = True } rest
+ go opts ("--section" : s : rest) = go opts { optMdSection = Just s } rest
+ go _ ("--section" : []) = Left "--section requires an argument"
go _ (('-':'-':opt) : _) = Left $ "Unknown option: --" ++ opt
go _ (('-':opt) : _) = Left $ "Unknown option: -" ++ opt
go opts (dir : rest) = go opts { optDirectory = dir } rest
@@ -124,9 +148,14 @@ makeChangelog Opts {..} = do
either (exitWithExc . PlainError) return $
parseWith parseConfig filename contents
+ -- Read only regular files, skipping config, dotfiles, and any
+ -- subdirectories (e.g. golden-output dirs alongside test fragments).
dirContents <- filter (not . isTmpFile) <$> listDirectory optDirectory
+ fragmentNames <-
+ filterM (\name -> doesFileExist (optDirectory </> name))
+ (filter (/= "config") $ sort dirContents)
allEntries <- fmap Map.fromList $
- for (filter (/= "config") $ sort dirContents) $ \name -> do
+ for fragmentNames $ \name -> do
let fp = optDirectory </> name
contents <- BS.readFile fp
entry <- parseEntryFile fp contents
@@ -140,17 +169,38 @@ makeChangelog Opts {..} = do
exitWithExc $ PlainError "Validation failed."
-- Check expected MR number if specified
- for_ optExpectMR $ \expectedMR -> do
- let expectedMRNum = MRNumber expectedMR
- entriesWithMR = Map.filter (\e -> expectedMRNum `Set.member` entryMrs e) allEntries
- when (Map.null entriesWithMR && not (Map.null allEntries)) $ do
- hPutStrLn stderr $ "Warning: No changelog entry references this MR (!" ++ show expectedMR ++ ")."
- hPutStrLn stderr $ "Add 'mrs: !" ++ show expectedMR ++ "' to your changelog entry."
- hPutStrLn stderr ""
- exitFailure
+ matchedByMR <- case optExpectMR of
+ Nothing -> pure Map.empty
+ Just expectedMR -> do
+ let expectedMRNum = MRNumber expectedMR
+ withMR = Map.filter (\e -> expectedMRNum `Set.member` entryMrs e) allEntries
+ when (Map.null withMR && not (Map.null allEntries)) $ do
+ hPutStrLn stderr $ "Warning: No changelog entry references this MR (!" ++ show expectedMR ++ ")."
+ hPutStrLn stderr $ "Add 'mrs: !" ++ show expectedMR ++ "' to your changelog entry."
+ hPutStrLn stderr ""
+ exitFailure
+ pure withMR
+
+ -- --expect-clc: assert that the MR-matched entry has clc: set.
+ when optExpectCLC $ case optExpectMR of
+ Nothing -> exitWithExc $ PlainError
+ "--expect-clc requires --expect-mr (which entry to check?)"
+ Just expectedMR ->
+ when (not (Map.null matchedByMR)
+ && all (Set.null . entryClcs) matchedByMR) $ do
+ hPutStrLn stderr $
+ "Error: changelog entry for !" ++ show expectedMR
+ ++ " does not have a 'clc:' field."
+ hPutStrLn stderr
+ "Changes to base or user-facing changes require a CLC proposal."
+ hPutStrLn stderr "Add 'clc: #<proposal>' to your changelog entry."
+ exitFailure
unless optValidate $
- outputRST optDirectory optVersion cfg (Map.elems allEntries)
+ if optMarkdown
+ then outputMarkdown optDirectory cfg optMdSection
+ (Map.elems allEntries)
+ else outputRST optDirectory optVersion cfg (Map.elems allEntries)
-------------------------------------------------------------------------------
-- RST output
@@ -218,6 +268,9 @@ formatEntry Entry {..} =
] ++
[ "(:ghc-mr:`" ++ show n ++ "`)"
| MRNumber n <- Set.toList entryMrs
+ ] ++
+ [ "(:clc:`" ++ show n ++ "`)"
+ | CLCNumber n <- Set.toList entryClcs
]
description = maybe "" (\d -> "\n" ++ trim d ++ "\n\n") entryDescription
@@ -262,25 +315,281 @@ generateIncludedLibraries baseDir preamble libs = do
where
fst3 (a, _, _) = a
- extractField :: String -> String -> Maybe String
- extractField fieldName contents =
- case mapMaybe (matchField fieldName) (lines contents) of
- (v:_) -> Just v
- [] -> Nothing
-
- matchField :: String -> String -> Maybe String
- matchField fieldName line =
- let stripped = dropWhile isSpace line
- (key, rest) = break (\c -> c == ':' || isSpace c) stripped
- in if map toLower' key == map toLower' fieldName
- then case dropWhile isSpace rest of
- (':':val) -> Just (trim (dropWhile isSpace val))
- _ -> Nothing
- else Nothing
-
- toLower' c
- | c >= 'A' && c <= 'Z' = toEnum (fromEnum c + 32)
- | otherwise = c
+extractField :: String -> String -> Maybe String
+extractField fieldName contents =
+ case mapMaybe (matchField fieldName) (lines contents) of
+ (v:_) -> Just v
+ [] -> Nothing
+
+matchField :: String -> String -> Maybe String
+matchField fieldName line =
+ let stripped = dropWhile isSpace line
+ (key, rest) = break (\c -> c == ':' || isSpace c) stripped
+ in if map toLower' key == map toLower' fieldName
+ then case dropWhile isSpace rest of
+ (':':val) -> Just (trim (dropWhile isSpace val))
+ _ -> Nothing
+ else Nothing
+
+toLower' :: Char -> Char
+toLower' c
+ | c >= 'A' && c <= 'Z' = toEnum (fromEnum c + 32)
+ | otherwise = c
+
+-------------------------------------------------------------------------------
+-- Markdown output
+-------------------------------------------------------------------------------
+
+-- | Emit per-library Markdown bullets to stdout.
+--
+-- With 'mSect' set, emit just that section's bullets (used interactively).
+-- Without it, emit every section listed in @markdown-targets:@, separated
+-- by HTML comments naming each section
+outputMarkdown
+ :: FilePath -- ^ changelog.d directory (used to locate cabal files)
+ -> Cfg
+ -> Maybe String -- ^ --section <key>
+ -> [Entry]
+ -> IO ()
+outputMarkdown dir Cfg{..} mSect entries = do
+ targets <- case mSect of
+ Just key -> case find ((== key) . mtSection) cfgMarkdownTargets of
+ Nothing -> exitWithExc $ PlainError $
+ "Unknown markdown section: " ++ key
+ ++ "\nKnown sections: "
+ ++ intercalate ", " (map mtSection cfgMarkdownTargets)
+ Just mt -> pure [mt]
+ Nothing -> pure cfgMarkdownTargets
+
+ let multi = isNothing mSect
+ baseDir = takeDirectory (dropTrailingPathSeparator dir)
+
+ case mSect of
+ Just key | not (any (\mt -> mtSection mt == key) cfgMarkdownTargets) ->
+ -- impossible; handled above
+ pure ()
+ Just key | null (entriesFor key entries) ->
+ exitWithExc $ PlainError $ "No entries for section " ++ key
+ _ -> pure ()
+
+ for_ targets $ \mt -> do
+ let es = entriesFor (mtSection mt) entries
+ unless (null es) $ do
+ when multi $ do
+ putStrLn $ "<!-- ===== " ++ mtSection mt
+ ++ " (" ++ mtPath mt ++ ") ===== -->"
+ putStrLn ""
+ libVer <- readLibraryVersion baseDir (mtPath mt)
+ putStrLn $ "## " ++ libVer ++ " *TBA*"
+ putStrLn ""
+ for_ (sortBy (flip compare `on` hasDescription) es) $ \entry ->
+ putStr (formatEntryMd entry)
+ when multi $ putStrLn ""
+
+entriesFor :: String -> [Entry] -> [Entry]
+entriesFor key = filter $ \e -> case entrySection e of
+ Just (Section s) -> s == key
+ Nothing -> False
+
+-- | Given the path of a library's @changelog.md@ (repo-relative), find the
+-- sibling @*.cabal@ (or @*.cabal.in@) and read the @version:@ field.
+readLibraryVersion :: FilePath -> FilePath -> IO String
+readLibraryVersion baseDir mdPath = do
+ let libDir = takeDirectory mdPath
+ libDirFs = baseDir </> libDir
+ exists <- doesDirectoryExist libDirFs
+ if not exists
+ then do
+ hPutStrLn stderr $ "Warning: directory does not exist: " ++ libDirFs
+ pure "?.?.?"
+ else do
+ candidates <- listDirectory libDirFs
+ let cabals = filter (\f -> ".cabal" `isSuffixOf` f) candidates
+ -- Prefer non-templated *.cabal over *.cabal.in (the former is
+ -- the rendered file Hadrian needs before invoking us).
+ ranked = sortBy (compare `on` (\f -> if ".cabal.in" `isSuffixOf` f then (1::Int) else 0)) cabals
+ case ranked of
+ [] -> do
+ hPutStrLn stderr $
+ "Warning: no .cabal file under " ++ libDir
+ pure "?.?.?"
+ (cf:_) -> do
+ contents <- readFile (libDirFs </> cf)
+ case extractField "version" contents of
+ Just v -> pure v
+ Nothing -> do
+ hPutStrLn stderr $
+ "Warning: could not parse version from " ++ libDir </> cf
+ pure "?.?.?"
+
+-- | Format an Entry as a Markdown bullet. Mirrors 'formatEntry' for RST
+-- but emits Markdown links for issues/MRs/CLC and rewrites RST inline
+-- markup to markdown.
+formatEntryMd :: Entry -> String
+formatEntryMd Entry{..} = indentBulletMd (header ++ description)
+ where
+ header = unwords $
+ [ rstToMarkdown entrySynopsis ] ++
+ [ mdLink ("#" ++ show n)
+ ("https://gitlab.haskell.org/ghc/ghc/issues/" ++ show n)
+ | IssueNumber n <- Set.toList entryIssues
+ ] ++
+ [ mdLink ("!" ++ show n)
+ ("https://gitlab.haskell.org/ghc/ghc/-/merge_requests/" ++ show n)
+ | MRNumber n <- Set.toList entryMrs
+ ] ++
+ [ mdLink ("CLC proposal #" ++ show n)
+ ("https://github.com/haskell/core-libraries-committee/issues/" ++ show n)
+ | CLCNumber n <- Set.toList entryClcs
+ ]
+
+ description = maybe "" (\d -> "\n\n" ++ rstToMarkdown (trim d) ++ "\n") entryDescription
+
+ mdLink :: String -> String -> String
+ mdLink txt url = "(" ++ "[" ++ txt ++ "](" ++ url ++ ")" ++ ")"
+
+-- | Indent text as a Markdown bullet: the first line gets @"* "@ prefix,
+-- subsequent lines are indented two spaces. Mirrors 'indentBullet'.
+indentBulletMd :: String -> String
+indentBulletMd = unlines . go . lines
+ where
+ go [] = []
+ go (x:xs) = ("* " ++ x) : map indentLine xs
+ indentLine "" = ""
+ indentLine s = " " ++ s
+
+-------------------------------------------------------------------------------
+-- RST -> Markdown rewriting
+-------------------------------------------------------------------------------
+--
+-- Applies the following rules:
+--
+-- | RST | Markdown |
+-- | -------------------------------------------------| ------------------------------------------------------------------------------------------------------ |
+-- | ``code`` (double-backtick) | `code` (single-backtick) |
+-- | `text <url>`_ | [text](url) |
+-- | :ghc-ticket:`N` | [#N](https://gitlab.haskell.org/ghc/ghc/issues/N) |
+-- | :ghc-mr:`N` | [!N](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/N) |
+-- | :ghc-wiki:`p` | [p](https://gitlab.haskell.org/ghc/ghc/wikis/p) |
+-- | :clc:`N` | [CLC proposal #N](https://github.com/haskell/core-libraries-committee/issues/N) |
+-- | :ghc-flag:`-foo` | `-foo` |
+-- | :extension:`E` | `E` |
+-- | :ghci-cmd:`X`, :rts-flag:`X` | `X` |
+-- | :base-ref:`Mod.id` `` | `Mod.id` |
+-- | :th-ref:, :cabal-ref: ,:ghc-prim-ref: | `ref` |
+-- | .. code-block:: lang + indented body | Triple-backtick fenced block with `lang` |
+-- | .. note:: / .. warning:: | `> **Note:**` / `> **Warning:**` blockquote |
+
+rstToMarkdown :: String -> String
+rstToMarkdown s =
+ let trailingNL = not (null s) && last s == '\n'
+ body = intercalate "\n" . blockPass . lines . inlinePass $ s
+ in body ++ (if trailingNL then "\n" else "")
+
+inlinePass :: String -> String
+inlinePass [] = []
+-- Double-backtick code: ``code`` → `code`
+inlinePass ('`':'`':rest) =
+ case breakOnSubstring "``" rest of
+ (body, _:_:after) -> "`" ++ body ++ "`" ++ inlinePass after
+ _ -> '`':'`': inlinePass rest
+-- RST hyperlink: `text <url>`_ → [text](url)
+inlinePass ('`':rest)
+ | Just (txt, url, after) <- pickRstLink rest =
+ "[" ++ trim txt ++ "](" ++ url ++ ")" ++ inlinePass after
+-- :role:`body` interpreted-text role
+inlinePass (':':rest)
+ | Just (role, body, after) <- pickRole rest =
+ renderRole role body ++ inlinePass after
+inlinePass (c:cs) = c : inlinePass cs
+
+breakOnSubstring :: String -> String -> (String, String)
+breakOnSubstring needle = go
+ where
+ go [] = ([], [])
+ go s@(c:cs)
+ | needle `isPrefixOf` s = ([], s)
+ | otherwise =
+ let (a, b) = go cs in (c:a, b)
+
+-- | Try to consume a @\`text \<url\>\`_@ RST hyperlink starting after the
+-- leading backtick. Returns @(text, url, rest)@ on success.
+pickRstLink :: String -> Maybe (String, String, String)
+pickRstLink xs = do
+ let (txt, r1) = break (== '<') xs
+ case r1 of
+ '<':r2 -> do
+ let (url, r3) = break (== '>') r2
+ case r3 of
+ '>':'`':'_':'_':after -> Just (txt, url, after)
+ '>':'`':'_':after -> Just (txt, url, after)
+ _ -> Nothing
+ _ -> Nothing
+
+-- | Try to consume a @role:\`body\`@ interpreted-text role starting just
+-- after the leading colon.
+pickRole :: String -> Maybe (String, String, String)
+pickRole xs =
+ let (name, r1) = span (\c -> isAlpha c || c == '-') xs
+ in case (null name, r1) of
+ (False, ':':'`':r2) -> case break (== '`') r2 of
+ (body, '`':after) | not (null body) -> Just (name, body, after)
+ _ -> Nothing
+ _ -> Nothing
+
+-- | Render a known interpreted-text role to Markdown.
+renderRole :: String -> String -> String
+renderRole role body = case role of
+ "ghc-ticket" -> mdLink ("#" ++ body) ("https://gitlab.haskell.org/ghc/ghc/issues/" ++ body)
+ "ghc-mr" -> mdLink ("!" ++ body) ("https://gitlab.haskell.org/ghc/ghc/-/merge_requests/" ++ body)
+ "ghc-wiki" -> mdLink body ("https://gitlab.haskell.org/ghc/ghc/wikis/" ++ body)
+ "clc" -> mdLink ("CLC proposal #" ++ body)
+ ("https://github.com/haskell/core-libraries-committee/issues/" ++ body)
+ "ghc-flag" -> "`" ++ body ++ "`"
+ "extension" -> "`" ++ body ++ "`"
+ "ghci-cmd" -> "`" ++ body ++ "`"
+ "rts-flag" -> "`" ++ body ++ "`"
+ "doc" -> body
+ "base-ref" -> "`" ++ body ++ "`"
+ "th-ref" -> "`" ++ body ++ "`"
+ "cabal-ref" -> "`" ++ body ++ "`"
+ "ghc-prim-ref" -> "`" ++ body ++ "`"
+ _ -> ":" ++ role ++ ":`" ++ body ++ "`"
+ where
+ mdLink txt url = "[" ++ txt ++ "](" ++ url ++ ")"
+
+-- | Block-level transforms applied after the inline pass.
+blockPass :: [String] -> [String]
+blockPass [] = []
+blockPass (l:rest)
+ | Just lang <- stripPrefix ".. code-block:: " (trim l) =
+ let (body, rest') = takeIndentedBlock rest
+ in ("```" ++ lang) : map (dropIndent 4) body ++ ["```"] ++ blockPass rest'
+ | trim l == ".. note::" =
+ let (body, rest') = takeIndentedBlock rest
+ in "> **Note:**" : map (("> " ++) . dropIndent 4) body ++ blockPass rest'
+ | trim l == ".. warning::" =
+ let (body, rest') = takeIndentedBlock rest
+ in "> **Warning:**" : map (("> " ++) . dropIndent 4) body ++ blockPass rest'
+ | otherwise = l : blockPass rest
+
+-- | Take a block of indented (or blank) lines following a directive; stop
+-- at the first non-blank, non-indented line.
+takeIndentedBlock :: [String] -> ([String], [String])
+takeIndentedBlock = go . dropWhile null
+ where
+ go [] = ([], [])
+ go (x:xs)
+ | null x = let (a, b) = go xs in (x:a, b)
+ | take 1 x == " " = let (a, b) = go xs in (x:a, b)
+ | otherwise = ([], x:xs)
+
+-- | Drop up to @n@ leading spaces from a line.
+dropIndent :: Int -> String -> String
+dropIndent _ "" = ""
+dropIndent 0 s = s
+dropIndent n (' ':cs) = dropIndent (n-1) cs
+dropIndent _ s = s
-------------------------------------------------------------------------------
-- Section grouping
@@ -303,10 +612,13 @@ groupBySections sectionDefs entries =
-------------------------------------------------------------------------------
data Opts = Opts
- { optDirectory :: FilePath
- , optVersion :: Maybe String
- , optValidate :: Bool
- , optExpectMR :: Maybe Int -- ^ Expected MR number
+ { optDirectory :: FilePath
+ , optVersion :: Maybe String
+ , optValidate :: Bool
+ , optExpectMR :: Maybe Int -- ^ Expected MR number
+ , optExpectCLC :: Bool -- ^ Require entry matched by --expect-mr to have clc:
+ , optMarkdown :: Bool -- ^ Emit per-library Markdown to stdout
+ , optMdSection :: Maybe String -- ^ Restrict markdown emission to one section
}
deriving (Show)
@@ -332,6 +644,24 @@ instance C.Parsec MRNumber where
instance C.Pretty MRNumber where
pretty (MRNumber n) = PP.char '!' PP.<> PP.int n
+newtype CLCNumber = CLCNumber Int
+ deriving (Eq, Ord, Show)
+
+instance C.Parsec CLCNumber where
+ parsec = do
+ _ <- P.char '#'
+ CLCNumber <$> P.integral
+
+instance C.Pretty CLCNumber where
+ pretty (CLCNumber n) = PP.char '#' PP.<> PP.int n
+
+data MarkdownTarget = MarkdownTarget
+ { mtSection :: String -- ^ section key matching an entry's `section:`
+ , mtPath :: FilePath -- ^ target changelog path, repo-relative
+ , mtRequiredFields :: [String] -- ^ extra required-fields when this section is used
+ }
+ deriving (Show)
+
newtype Section = Section String
deriving (Eq, Ord, Show)
@@ -351,6 +681,7 @@ data Cfg = Cfg
, cfgPreamble :: String
, cfgIncludedLibraries :: [(FilePath, String)] -- ^ (cabalPath, description)
, cfgIncludedLibrariesPreamble :: String
+ , cfgMarkdownTargets :: [MarkdownTarget]
}
deriving (Show)
@@ -364,6 +695,7 @@ parseConfig fields0 = do
, cfgPreamble = cfgRawPreamble raw
, cfgIncludedLibraries = parseIncludedLibraries (cfgRawIncludedLibraries raw)
, cfgIncludedLibrariesPreamble = cfgRawIncludedLibrariesPreamble raw
+ , cfgMarkdownTargets = parseMarkdownTargets (cfgRawMarkdownTargets raw)
}
where
(fields, sections) = C.partitionFields fields0
@@ -378,6 +710,7 @@ data CfgRaw = CfgRaw
, cfgRawPreamble :: String
, cfgRawIncludedLibraries :: String
, cfgRawIncludedLibrariesPreamble :: String
+ , cfgRawMarkdownTargets :: String
}
cfgRawRequiredFieldsL :: Functor f => (Set String -> f (Set String)) -> CfgRaw -> f CfgRaw
@@ -395,6 +728,9 @@ cfgRawIncludedLibrariesL f s = (\x -> s { cfgRawIncludedLibraries = x }) <$> f (
cfgRawIncludedLibrariesPreambleL :: Functor f => (String -> f String) -> CfgRaw -> f CfgRaw
cfgRawIncludedLibrariesPreambleL f s = (\x -> s { cfgRawIncludedLibrariesPreamble = x }) <$> f (cfgRawIncludedLibrariesPreamble s)
+cfgRawMarkdownTargetsL :: Functor f => (String -> f String) -> CfgRaw -> f CfgRaw
+cfgRawMarkdownTargetsL f s = (\x -> s { cfgRawMarkdownTargets = x }) <$> f (cfgRawMarkdownTargets s)
+
cfgRawGrammar :: C.ParsecFieldGrammar CfgRaw CfgRaw
cfgRawGrammar = CfgRaw
<$> C.monoidalFieldAla "required-fields" (C.alaSet' C.FSep C.Token) cfgRawRequiredFieldsL
@@ -402,6 +738,7 @@ cfgRawGrammar = CfgRaw
<*> C.freeTextFieldDef "preamble" cfgRawPreambleL
<*> C.freeTextFieldDef "included-libraries" cfgRawIncludedLibrariesL
<*> C.freeTextFieldDef "included-libraries-preamble" cfgRawIncludedLibrariesPreambleL
+ <*> C.freeTextFieldDef "markdown-targets" cfgRawMarkdownTargetsL
parseSections :: String -> [(String, String)]
parseSections = mapMaybe parseLine . lines
@@ -419,6 +756,20 @@ parseIncludedLibraries = mapMaybe parseLine . lines
(path, rest) | not (null path) -> Just (path, trim rest)
_ -> Nothing
+-- | Parse the @markdown-targets:@ block.
+--
+-- Each non-empty, non-comment line is
+-- <section-key> <path> [<extra-required-field>...]
+-- The extra tokens declare additional fields required of any entry whose section: matches.
+parseMarkdownTargets :: String -> [MarkdownTarget]
+parseMarkdownTargets = mapMaybe parseLine . lines
+ where
+ parseLine l = case words (trim l) of
+ [] -> Nothing
+ [_] -> Nothing -- need at least section + path
+ (sect:path:extra) ->
+ Just $ MarkdownTarget sect path extra
+
-------------------------------------------------------------------------------
-- Entry
-------------------------------------------------------------------------------
@@ -428,6 +779,7 @@ data Entry = Entry
, entryDescription :: Maybe String
, entryMrs :: Set MRNumber
, entryIssues :: Set IssueNumber
+ , entryClcs :: Set CLCNumber
, entrySection :: Maybe Section
}
deriving (Show)
@@ -447,6 +799,9 @@ entryMrsL f s = (\x -> s { entryMrs = x }) <$> f (entryMrs s)
entryIssuesL :: Functor f => (Set IssueNumber -> f (Set IssueNumber)) -> Entry -> f Entry
entryIssuesL f s = (\x -> s { entryIssues = x }) <$> f (entryIssues s)
+entryClcsL :: Functor f => (Set CLCNumber -> f (Set CLCNumber)) -> Entry -> f Entry
+entryClcsL f s = (\x -> s { entryClcs = x }) <$> f (entryClcs s)
+
entrySectionL :: Functor f => (Maybe Section -> f (Maybe Section)) -> Entry -> f Entry
entrySectionL f s = (\x -> s { entrySection = x }) <$> f (entrySection s)
@@ -477,6 +832,7 @@ entryGrammar = Entry
<*> C.freeTextField "description" entryDescriptionL
<*> C.monoidalFieldAla "mrs" (C.alaSet C.NoCommaFSep) entryMrsL
<*> C.monoidalFieldAla "issues" (C.alaSet C.NoCommaFSep) entryIssuesL
+ <*> C.monoidalFieldAla "clc" (C.alaSet C.NoCommaFSep) entryClcsL
<*> C.optionalField "section" entrySectionL
-------------------------------------------------------------------------------
@@ -510,8 +866,21 @@ validateEntry cfg entry = foldMap (\validator -> validator cfg entry)
validateRequiredFields :: Validator
validateRequiredFields Cfg{..} Entry{..} = fmap RequiredFieldError $
- mapMaybe checkField $ Set.toList cfgRequiredFields
+ mapMaybe checkField $ Set.toList effectiveRequired
where
+ -- Effective required-fields = global cfgRequiredFields + extras for the
+ -- entry's section as declared in cfgMarkdownTargets
+ -- (e.g. `base` adds `clc`).
+ effectiveRequired =
+ cfgRequiredFields `Set.union`
+ Set.fromList
+ [ f
+ | Just (Section sect) <- [entrySection]
+ , mt <- cfgMarkdownTargets
+ , mtSection mt == sect
+ , f <- mtRequiredFields mt
+ ]
+
checkField :: String -> Maybe RequiredFieldError
checkField reqField = case fieldIsEmpty reqField of
Left err -> Just err
@@ -522,6 +891,7 @@ validateRequiredFields Cfg{..} Entry{..} = fmap RequiredFieldError $
fieldIsEmpty "description" = pure $ isNothing entryDescription
fieldIsEmpty "mrs" = pure $ null entryMrs
fieldIsEmpty "issues" = pure $ null entryIssues
+ fieldIsEmpty "clc" = pure $ null entryClcs
fieldIsEmpty "section" = pure $ isNothing entrySection
fieldIsEmpty f = Left $ UnknownRequiredField f
=====================================
utils/changelog-d/README.md
=====================================
@@ -23,46 +23,55 @@ description: {
**Required fields:** `section`, `synopsis`, `mrs`, `issues`
-**Optional fields:** `description`
+**Optional fields:** `description`, `clc`
+
+**Conditionally required**: entries with `section: base` MUST also include a `clc:`
+field referencing the CLC proposal authorising the change.
If your MR doesn't need a changelog entry, apply the `no-changelog` label.
### Fields
-| Field | Format | Description |
-| ------------- | ------------------------------- | -----------------------------------------------|
-| `synopsis` | Free-form RST | Brief description of the change |
-| `mrs` | `!N` (space-separated) | MR number(s) |
-| `issues` | `#N` (space-separated) | Issue number(s) |
-| `section` | Section key (see below) | GHC component |
-| `description` | Free-form RST in `{ ... }` | Extended details. Printed after the main entry |
+| Field | Format | Description |
+| ------------- | -------------------------- | ----------------------------------------------------- |
+| `synopsis` | Free-form RST | Brief description of the change |
+| `mrs` | `!N` (space-separated) | MR number(s) |
+| `issues` | `#N` (space-separated) | Issue number(s) |
+| `clc` | `#N` (space-separated) | CLC proposal number(s). Required for `section: base`. |
+| `section` | Section key (see below) | GHC component |
+| `description` | Free-form RST | Extended details. Printed after the main entry |
### Section keys
-| Key | Heading |
-| ------------------ | -------------------------------- |
-| `language` | Language |
-| `compiler` | Compiler |
-| `profiling` | Profiling |
-| `codegen` | Code generation |
-| `llvm-backend` | LLVM backend |
-| `js-backend` | JavaScript backend |
-| `wasm-backend` | WebAssembly backend |
-| `ghci` | GHCi |
-| `rts` | Runtime system |
-| `linker` | Linker |
-| `bytecode` | Bytecode compiler |
-| `packaging` | Packaging & build system |
-| `cmm` | Cmm |
-| `build-tools` | Build tools |
-| `base` | ``base`` library |
-| `ghc-prim` | ``ghc-prim`` library |
-| `ghc-lib` | ``ghc`` library |
-| `ghc-heap` | ``ghc-heap`` library |
-| `ghc-experimental` | ``ghc-experimental`` library |
-| `template-haskell` | ``template-haskell`` library |
-| `ghc-pkg` | ``ghc-pkg`` |
-| `ghc-toolchain` | ``ghc-toolchain`` |
+The "Markdown" column indicates whether entries in that section also flow to
+a per-library `changelog.md`. Sections without a
+Markdown target appear only in the GHC release notes RST.
+
+| Key | Heading | Markdown target |
+| ------------------ | ---------------------------- | ---------------------------------------------- |
+| `language` | Language | — |
+| `compiler` | Compiler | — |
+| `profiling` | Profiling | — |
+| `codegen` | Code generation | — |
+| `llvm-backend` | LLVM backend | — |
+| `js-backend` | JavaScript backend | — |
+| `wasm-backend` | WebAssembly backend | — |
+| `ghci` | GHCi | — |
+| `rts` | Runtime system | — |
+| `linker` | Linker | — |
+| `bytecode` | Bytecode compiler | — |
+| `packaging` | Packaging & build system | — |
+| `cmm` | Cmm | — |
+| `build-tools` | Build tools | — |
+| `base` | ``base`` library | `libraries/base/changelog.md` |
+| `ghc-internal` | ``ghc-internal`` library | `libraries/ghc-internal/CHANGELOG.md` |
+| `ghc-prim` | ``ghc-prim`` library | `libraries/ghc-prim/changelog.md` |
+| `ghc-lib` | ``ghc`` library | — |
+| `ghc-heap` | ``ghc-heap`` library | — |
+| `ghc-experimental` | ``ghc-experimental`` library | `libraries/ghc-experimental/CHANGELOG.md` |
+| `template-haskell` | ``template-haskell`` library | `libraries/template-haskell/changelog.md` |
+| `ghc-pkg` | ``ghc-pkg`` | — |
+| `ghc-toolchain` | ``ghc-toolchain`` | — |
### Entry format
@@ -83,20 +92,34 @@ library's `Distribution.Fields` parser
## Configuration
The file `changelog.d/config` declares the structure of the generated release
-notes: required fields, section names, preamble text, and the included-libraries
-table. Edit it when adding new sections or changing release note formatting.
+notes: required fields, section names, preamble text, the included-libraries
+table, and the `markdown-targets:` mapping that wires sections to per-library
+`changelog.md` files. Edit it when adding new sections or changing release-note
+formatting.
+
+The `markdown-targets:` block is the source of truth for "which section's
+entries get a Markdown emission, and which extra fields (e.g. `clc`) are
+required for that section." Each line is `<section-key> <path> [<extra-required-field>...]`.
## For maintainers
### Hadrian targets
-Generate release notes:
+Generate RST release notes (existing behaviour):
```
hadrian/build changelog # uses project version
hadrian/build changelog --changelog-version=10.2.1 # explicit version
```
Output: `docs/users_guide/<version>-notes.rst`
+Generate per-library Markdown bullets:
+
+```
+hadrian/build libraries-changelog-markdown
+```
+
+Output is one stream containing every configured `markdown-targets:` section.
+
Clear entries after branch cut:
```
@@ -108,3 +131,25 @@ Validate entries:
```
hadrian/build test --only=changelog-d
```
+
+### RST -> Markdown rewrite rules
+
+`--libraries-changelog-markdown` rewrites the inline RST in each entry to Markdown:
+
+| RST | Markdown |
+| -------------------------------------------------| ------------------------------------------------------------------------------------------------------ |
+| ``code`` (double-backtick) | `code` (single-backtick) |
+| `text <url>`_ | [text](url) |
+| :ghc-ticket:`N` | [#N](https://gitlab.haskell.org/ghc/ghc/issues/N) |
+| :ghc-mr:`N` | [!N](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/N) |
+| :ghc-wiki:`p` | [p](https://gitlab.haskell.org/ghc/ghc/wikis/p) |
+| :clc:`N` | [CLC proposal #N](https://github.com/haskell/core-libraries-committee/issues/N) |
+| :ghc-flag:`-foo` | `-foo` |
+| :extension:`E` | `E` |
+| :ghci-cmd:`X`, :rts-flag:`X` | `X` |
+| :base-ref:`Mod.id` `` | `Mod.id` |
+| :th-ref:, :cabal-ref: ,:ghc-prim-ref: | `ref` |
+| .. code-block:: lang + indented body | Triple-backtick fenced block with `lang` |
+| .. note:: / .. warning:: | `> **Note:**` / `> **Warning:**` blockquote |
+
+
=====================================
utils/changelog-d/tests/config
=====================================
@@ -0,0 +1,15 @@
+-- Minimal config for running changelog-d against the test fixture in
+-- this directory. Mirrors the structure of the project-root
+-- changelog.d/config but only declares the sections + markdown-targets
+-- the fixture exercises. The path declared in markdown-targets is a
+-- placeholder; readLibraryVersion warns and falls back to "?.?.?" when
+-- the directory does not exist, which is captured in the golden output.
+required-fields: synopsis mrs issues section
+
+sections: {
+ base ``base`` library
+}
+
+markdown-targets: {
+ base _fake/changelog.md clc
+}
=====================================
utils/changelog-d/tests/expected/test-parser-rewriter.md
=====================================
@@ -0,0 +1,33 @@
+## ?.?.? *TBA*
+
+* Self-test fixture exercising the parser/rewriter. Uses double-backtick `code`,
+ RST hyperlinks [the changelog wiki](https://gitlab.haskell.org/ghc/ghc/-/wikis/contributing/changelog),
+ GHC-flavoured roles [#12345](https://gitlab.haskell.org/ghc/ghc/issues/12345), [!6789](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6789), [commentary/compiler](https://gitlab.haskell.org/ghc/ghc/wikis/commentary/co…,
+ [CLC proposal #123](https://github.com/haskell/core-libraries-committee/issues/123), `-fxxx`, `TypeApplications`, `:type`,
+ `-N`, haddock cross-refs `Data.Maybe.fromMaybe`,
+ `Language.Haskell.TH.Lib`, `Distribution.Simple`,
+ `GHC.Prim`, the internal-doc role, and an :unknown-role:`pass-through`. ([#26002](https://gitlab.haskell.org/ghc/ghc/issues/26002)) ([!15830](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/15830)) ([CLC proposal #0](https://github.com/haskell/core-libraries-committee/issues/0))
+
+ This description block exercises block-level rewrites and inline rewrites
+ inside a multi-line braced field.
+
+ Inline forms inside the description: `inline code`, `DataKinds`,
+ [!15830](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/15830), `Control.Applicative`, and a [bare RST link](https://example.invalid/).
+
+ > **Note:**
+ > This is an RST note admonition. It should render as a Markdown
+ > blockquote prefixed with `> **Note:**`.
+ >
+ > **Warning:**
+ > This is an RST warning admonition. It should render as a Markdown
+ > blockquote prefixed with `> **Warning:**`.
+ >
+ ```haskell
+ foo :: Int -> Int
+ foo x = x + 1
+ bar :: String
+ bar = "hello"
+
+ ```
+ After the code block, plain prose continues. Verify that the renderer
+ exits the fenced block correctly and resumes paragraph flow here.
=====================================
utils/changelog-d/tests/test-parser-rewriter
=====================================
@@ -0,0 +1,48 @@
+-- This file exercises every construct supported by changelog-d's parser
+-- and RST -> Markdown rewriter. It is kept in tree as a regression
+-- fixture: when the parser or rewriter is touched, run
+-- cabal run changelog-d -- --validate changelog.d/
+-- cabal run changelog-d -- --libraries-changelog-markdown changelog.d/
+-- and visually compare the output. The tool treats this like any
+-- other fragment, so it WILL appear in `--version`'ed RST and in
+-- `--libraries-changelog-markdown` output. Delete it before cutting a
+-- release, or move it under utils/changelog-d/tests/ if/when that
+-- directory is wired up.
+section: base
+synopsis: Self-test fixture exercising the parser/rewriter. Uses double-backtick ``code``,
+ RST hyperlinks `the changelog wiki <https://gitlab.haskell.org/ghc/ghc/-/wikis/contributing/changelog>`_,
+ GHC-flavoured roles :ghc-ticket:`12345`, :ghc-mr:`6789`, :ghc-wiki:`commentary/compiler`,
+ :clc:`123`, :ghc-flag:`-fxxx`, :extension:`TypeApplications`, :ghci-cmd:`:type`,
+ :rts-flag:`-N`, haddock cross-refs :base-ref:`Data.Maybe.fromMaybe`,
+ :th-ref:`Language.Haskell.TH.Lib`, :cabal-ref:`Distribution.Simple`,
+ :ghc-prim-ref:`GHC.Prim`, the :doc:`internal-doc` role, and an :unknown-role:`pass-through`.
+issues: #26002
+mrs: !15830
+clc: #0
+
+description: {
+ This description block exercises block-level rewrites and inline rewrites
+ inside a multi-line braced field.
+
+ Inline forms inside the description: ``inline code``, :extension:`DataKinds`,
+ :ghc-mr:`15830`, :base-ref:`Control.Applicative`, and a `bare RST link
+ <https://example.invalid/>`_.
+
+ .. note::
+ This is an RST note admonition. It should render as a Markdown
+ blockquote prefixed with ``> **Note:**``.
+
+ .. warning::
+ This is an RST warning admonition. It should render as a Markdown
+ blockquote prefixed with ``> **Warning:**``.
+
+ .. code-block:: haskell
+
+ foo :: Int -> Int
+ foo x = x + 1
+ bar :: String
+ bar = "hello"
+
+ After the code block, plain prose continues. Verify that the renderer
+ exits the fenced block correctly and resumes paragraph flow here.
+}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ed6faa1ba45dc442f31315e1b88f0e3…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ed6faa1ba45dc442f31315e1b88f0e3…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Zubin pushed new branch wip/27183 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/27183
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26989] 2 commits: Do not use mkCast during typechecking
by Simon Peyton Jones (＠simonpj) 28 Apr '26
by Simon Peyton Jones (＠simonpj) 28 Apr '26
28 Apr '26
Simon Peyton Jones pushed to branch wip/T26989 at Glasgow Haskell Compiler / GHC
Commits:
9ec89815 by Simon Peyton Jones at 2026-04-28T11:48:38+01:00
Do not use mkCast during typechecking
This commit fixes #27219. The problem was that the typechecker was using
`mkCast`, whose assertion checks legitimately fail when applied to types
that contain unification variables.
- - - - -
bd1503ad by Simon Peyton Jones at 2026-04-28T11:50:14+01:00
More improvements
* pushCoValArg and pushCoTyArg return tyL, which is helpful for the caller
* Don't optimise coercions if the type-substitution is empty.
See Note [Optimising coercions]
- - - - -
4 changed files:
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Tc/Types/Evidence.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -2875,43 +2875,44 @@ pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion)
-- 'co' is always Representational
pushCoArg co arg
| Type ty <- arg
- = do { (ty', m_co') <- pushCoTyArg co ty
+ = do { (_, ty', m_co') <- pushCoTyArg co ty
; return (Type ty', m_co') }
| otherwise
- = do { (arg_mco, m_co') <- pushCoValArg co
+ = do { (_, arg_mco, m_co') <- pushCoValArg co
; let arg_mco' = checkReflexiveMCo arg_mco
-- checkReflexiveMCo: see Note [Check for reflexive casts in eta expansion]
-- The coercion is very often (arg_co -> res_co), but without
-- the argument coercion actually being ReflCo
; return (arg `mkCastMCo` arg_mco', m_co') }
-pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercionR)
+pushCoTyArg :: CoercionR -> Type -> Maybe (Type, Type, MCoercionR)
-- We have (fun |> co) @ty
-- Push the coercion through to return
-- (fun @ty') |> co'
-- 'co' is always Representational
-- If the returned coercion is Nothing, then it would have been reflexive;
-- it's faster not to compute it, though.
-pushCoTyArg co ty
+pushCoTyArg co arg_ty
-- The following is inefficient - don't do `eqType` here, the coercion
-- optimizer will take care of it. See #14737.
-- -- | tyL `eqType` tyR
-- -- = Just (ty, Nothing)
- | isReflCo co
- = Just (ty, MRefl)
+ | Just (ty, _) <- isReflCo_maybe co
+ = Just (ty, arg_ty, MRefl)
| isForAllTy_ty tyL
- = assertPpr (isForAllTy_ty tyR) (ppr co $$ ppr ty) $
- Just (ty `mkCastTy` co1, MCo co2)
+ = assertPpr (isForAllTy_ty tyR) (ppr co $$ ppr arg_ty) $
+ Just (tyL, arg_ty `mkCastTy` co1, MCo co2)
| otherwise
= Nothing
where
- Pair tyL tyR = coercionKind co
- -- co :: tyL ~R tyR
- -- tyL = forall (a1 :: k1). ty1
- -- tyR = forall (a2 :: k2). ty2
+ -- co :: tyL ~R tyR
+ -- tyL = forall (a1 :: k1). ty1
+ -- tyR = forall (a2 :: k2). ty2
+ tyL = coercionLKind co
+ tyR = coercionRKind co -- Used only in asssertions and debug messages
co1 = mkSymCo (mkSelCo SelForAll co)
-- co1 :: k2 ~N k1
@@ -2919,30 +2920,32 @@ pushCoTyArg co ty
-- kinds of the types related by a coercion between forall-types.
-- See the SelCo case in GHC.Core.Lint.
- co2 = mkInstCo co (mkGReflLeftCo Nominal ty co1)
- -- co2 :: ty1[ (ty|>co1)/a1 ] ~R ty2[ ty/a2 ]
+ co2 = mkInstCo co (mkGReflLeftCo Nominal arg_ty co1)
+ -- co2 :: ty1[ (arg_ty|>co1)/a1 ] ~R ty2[ arg_ty/a2 ]
-- Arg of mkInstCo is always nominal, hence Nominal
--- | If @pushCoValArg co = Just (co_arg, co_res)@, then
+-- | If @pushCoValArg co = Just (tyL, co_arg, co_res)@, then
--
--- > (\x.body) |> co = (\y. let { x = y |> co_arg } in body) |> co_res)
+-- co :: tyL ~R# tyR
+-- and
+-- (\x.body) |> co = (\y. let { x = y |> co_arg } in body) |> co_res)
--
-- or, equivalently
--
--- > (fun |> co) arg = (fun (arg |> co_arg)) |> co_res
+-- (fun |> co) arg = (fun (arg |> co_arg)) |> co_res
--
-- If the LHS is well-typed, then so is the RHS. In particular, the argument
-- @arg |> co_arg@ is guaranteed to have a fixed 'RuntimeRep', in the sense of
-- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.
-pushCoValArg :: CoercionR -> Maybe (MCoercionR, MCoercionR)
+pushCoValArg :: CoercionR -> Maybe (Type, MCoercionR, MCoercionR)
pushCoValArg co
-- The following is inefficient - don't do `eqType` here, the coercion
-- optimizer will take care of it. See #14737.
-- -- | tyL `eqType` tyR
-- -- = Just (mkRepReflCo arg, Nothing)
- | isReflCo co
- = Just (MRefl, MRefl)
+ | Just (ty, _) <- isReflCo_maybe co
+ = Just (ty, MRefl, MRefl)
| isFunTy tyL
, (_, co1, co2) <- decomposeFunCo co
@@ -2961,7 +2964,7 @@ pushCoValArg co
(vcat [ text "co:" <+> ppr co
, text "old_arg_ty:" <+> ppr old_arg_ty
, text "new_arg_ty:" <+> ppr new_arg_ty ]) $
- Just (coToMCo (mkSymCo co1), coToMCo co2)
+ Just (tyL, coToMCo (mkSymCo co1), coToMCo co2)
-- Critically, coToMCo to checks for ReflCo; the whole coercion may not
-- be reflexive, but either of its components might be
-- We could use isReflexiveCo, but it's not clear if the benefit
@@ -2970,9 +2973,12 @@ pushCoValArg co
| otherwise
= Nothing
where
- old_arg_ty = funArgTy tyR
+ tyL = coercionLKind co
new_arg_ty = funArgTy tyL
- Pair tyL tyR = coercionKind co
+
+ -- These two are used only in assertions and debug messages
+ tyR = coercionRKind co
+ old_arg_ty = funArgTy tyR
pushCoercionIntoLambda
:: HasDebugCallStack => InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr)
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -17,8 +17,7 @@ import GHC.Driver.Flags
import GHC.Core
import GHC.Core.Opt.Simplify.Monad
import GHC.Core.Opt.ConstantFold
-import GHC.Core.Type hiding ( substCo, substTy, substTyVar, extendTvSubst, extendCvSubst )
-import GHC.Core.TyCo.Compare( eqType )
+import GHC.Core.Opt.Stats ( Tick(..) )
import GHC.Core.Opt.Simplify.Env
import GHC.Core.Opt.Simplify.Inline
import GHC.Core.Opt.Simplify.Utils
@@ -26,11 +25,14 @@ import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs )
import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr )
import qualified GHC.Core.Make
import GHC.Core.Coercion hiding ( substCo, substCoVar )
+import qualified GHC.Core.Coercion as Coercion
import GHC.Core.Reduction
import GHC.Core.Coercion.Opt ( optCoercion )
+import GHC.Core.Type hiding ( substCo, substTy, substTyVar, extendTvSubst, extendCvSubst )
+import GHC.Core.TyCo.Compare( eqType )
+import GHC.Core.TyCo.Subst( isEmptyTvSubst )
import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe )
import GHC.Core.DataCon
-import GHC.Core.Opt.Stats ( Tick(..) )
import GHC.Core.Ppr ( pprCoreExpr )
import GHC.Core.Unfold
import GHC.Core.Unfold.Make
@@ -1399,16 +1401,38 @@ simplCoercionF env co cont
simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion
simplCoercion env co
- = do { let opt_co | reSimplifying env = substCo env co
- | otherwise = optCoercion opts subst co
- -- If (reSimplifying env) is True we have already simplified
- -- this coercion once, and we don't want do so again; doing
- -- so repeatedly risks non-linear behaviour
- -- See Note [Inline depth] in GHC.Core.Opt.Simplify.Env
- ; seqCo opt_co `seq` return opt_co }
+ = seqCo opt_co `seq` return opt_co
where
+ -- See Note [Optimising coercions]
+ -- NB: substCo has a short-cut when both type and coercion substs are empty
+ opt_co | subst_only = Coercion.substCo subst co
+ | otherwise = optCoercion opts subst co
+
subst = getTCvSubst env
opts = seOptCoercionOpts env
+ subst_only = isEmptyTvSubst subst || reSimplifying env
+
+{- Note [Optimising coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Some programs have very big coercions and we'd like to avoid repeatedly
+re-optimising them:
+
+* If the type-substitution is empty (common when no further transformations
+ are taking place) then there is generally no point in re-optimising.
+ If there is a type substitution, however, Refls may appear.
+ Example where this isEmptyTCvSubst test really helped: aT5030.
+
+ Actually, if this is a "freshly-made" coercion (one built in the previous
+ iteration of the Simplifier, or a previous pass) then perhaps optimisations
+ /could/ occur; but we check for reflexivity in `rebuild_go`, and that's the
+ big win. Otherwise having a bigger-than necessary coercion is no so bad.
+
+* (reSimplifying env) is True we are in the body of an inlined function
+ so we (conservatively) and we don't want do so again; doing so repeatedly
+ risks non-linear behaviour. See Note [Inline depth] in GHC.Core.Opt.Simplify.Env.
+
+ But if the inlining did a type substitution maybe we should re-optimise?
+-}
-----------------------------------
-- | Push a TickIt context outwards past applications and cases, as
@@ -1742,6 +1766,9 @@ pushCast :: SimplEnv -> OutCoercion -> SimplCont -> SimplM SimplCont
pushCast env co cont
= go co True cont
where
+
+ -- ToDo: pushCast Refl (ApplylToVal arg1 (ApplyToVal arg2 ...))
+ -- will do lots of unnecessary work.
go :: OutCoercion -> Bool -> SimplCont -> SimplM SimplCont
go co1 _ (CastIt { sc_co = co2, sc_cont = cont }) -- See Note [Optimising reflexivity]
= go (mkTransCo co1 co2) False cont
@@ -1749,12 +1776,12 @@ pushCast env co cont
-- See Note [Avoid re-simplifying coercions]
go co co_is_opt (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })
- | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty
+ | Just (tyL, arg_ty', m_co') <- pushCoTyArg co arg_ty
= {-#SCC "addCoerce-pushCoTyArg" #-}
do { tail' <- go_mco m_co' co_is_opt tail
; return (ApplyToTy { sc_arg_ty = arg_ty'
, sc_cont = tail'
- , sc_hole_ty = coercionLKind co }) }
+ , sc_hole_ty = tyL }) }
-- NB! As the cast goes past, the
-- type of the hole changes (#16312)
@@ -1768,16 +1795,14 @@ pushCast env co cont
= -- pushCoValArg duplicates the coercion, so optimise first
go (optOutCoercion (zapSubstEnv env) co co_is_opt) True cont
--- ToDo: return coercionLKind. And similarly pushCoTyArg
-
- | Just (m_co1, m_co2) <- pushCoValArg co
+ | Just (tyL, m_co1, m_co2) <- pushCoValArg co
= {-#SCC "addCoerce-pushCoValArg" #-}
- do { tail' <- go_mco m_co2 co_is_opt tail
+ do { tail' <- go_mco m_co2 True tail
; return (ApplyToVal { sc_arg = arg
, sc_env = arg_se
, sc_cast = arg_mco `mkTransMCo` m_co1
, sc_cont = tail'
- , sc_hole_ty = coercionLKind co }) }
+ , sc_hole_ty = tyL }) }
go co co_is_opt cont
| isReflCo co = return cont -- Having this at the end makes a huge
@@ -1785,8 +1810,6 @@ pushCast env co cont
-- See Note [Optimising reflexivity]
| otherwise = return (CastIt { sc_co = co, sc_opt = co_is_opt, sc_cont = cont })
--- ToDo: pushCast Refl (ApplylToVal arg1 (ApplyToVal arg2 ...)) will do lots of unnecessary work.
-
-- If the first parameter is MRefl, then simplifying revealed a
-- reflexive coercion. Omit.
go_mco :: MOutCoercion -> Bool -> SimplCont -> SimplM SimplCont
=====================================
compiler/GHC/Core/TyCo/Subst.hs
=====================================
@@ -12,7 +12,7 @@ module GHC.Core.TyCo.Subst
-- * Substitutions
Subst(..), TvSubstEnv, CvSubstEnv, IdSubstEnv,
emptyIdSubstEnv, emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubst,
- emptySubst, mkEmptySubst, isEmptyTCvSubst, isEmptySubst,
+ emptySubst, mkEmptySubst, isEmptyTvSubst, isEmptyTCvSubst, isEmptySubst,
mkSubst, mkTCvSubst, mkTvSubst, mkCvSubst, mkIdSubst,
getTvSubstEnv, getIdSubstEnv,
getCvSubstEnv, substInScopeSet, setInScope, getSubstRangeTyCoFVs,
@@ -262,6 +262,11 @@ isEmptySubst :: Subst -> Bool
isEmptySubst (Subst _ id_env tv_env cv_env)
= isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env
+-- | Checks if the type substitution (only) is empty
+isEmptyTvSubst :: Subst -> Bool
+isEmptyTvSubst (Subst _ _ tv_env _)
+ = isEmptyVarEnv tv_env
+
-- | Checks whether the tyvar and covar environments are empty.
-- This function should be used over 'isEmptySubst' when substituting
-- for types, because types currently do not contain expressions; we can
=====================================
compiler/GHC/Tc/Types/Evidence.hs
=====================================
@@ -59,7 +59,6 @@ import GHC.Tc.Utils.TcType
import GHC.Core
import GHC.Core.Coercion.Axiom
import GHC.Core.Coercion
-import GHC.Core.Utils( mkCast )
import GHC.Core.Ppr () -- Instance OutputableBndr TyVar
import GHC.Core.Predicate
import GHC.Core.Type
@@ -932,7 +931,8 @@ evCastE ee co
| assertPpr (coercionRole co == Representational)
(vcat [text "Coercion of wrong role passed to evCastE:", ppr ee, ppr co]) $
isReflCo co = ee
- | otherwise = mkCast ee co
+ | otherwise = Cast ee co -- Do not call mkCast because its assertion
+ -- checks fail on un-zonked terms (#27219)
evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvTerm
-- Dictionary instance application, including when the "dictionary function"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9bbd56e8ba16b562d10b5b94d92dbc…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9bbd56e8ba16b562d10b5b94d92dbc…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/jeltsch/more-efficient-home-unit-imports-finding.with-debugging] WIP: fix failing test boot1 and multipleHomeUnits_reexport
by Hannes Siebenhandl (＠fendor) 28 Apr '26
by Hannes Siebenhandl (＠fendor) 28 Apr '26
28 Apr '26
Hannes Siebenhandl pushed to branch wip/jeltsch/more-efficient-home-unit-imports-finding.with-debugging at Glasgow Haskell Compiler / GHC
Commits:
862cd76a by fendor at 2026-04-28T11:26:02+02:00
WIP: fix failing test boot1 and multipleHomeUnits_reexport
- - - - -
1 changed file:
- compiler/GHC/Unit/Finder.hs
Changes:
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -214,7 +214,6 @@ findImportedModuleNoHsc fc fopts ue complete_home_units mb_home_unit mod_name mb
| otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mb_home_unit) $$ ppr uid $$ ppr (map fst all_opts))
OtherPkg _ -> pkg_import
where
- cached_module_providers = M.findWithDefault Set.empty mod_name (cu_providers complete_home_units)
mb_home_unit_id = homeUnitId <$> mb_home_unit
all_opts = case mb_home_unit_id of
Nothing -> other_fopts
@@ -249,42 +248,42 @@ findImportedModuleNoHsc fc fopts ue complete_home_units mb_home_unit mod_name mb
units = case mb_home_unit_id of
Nothing -> ue_homeUnitState ue
Just home_unit_id -> HUG.homeUnitEnv_units $ ue_findHomeUnitEnv home_unit_id ue
+
hpt_deps :: Set.Set UnitId
hpt_deps = homeUnitDepends units
+
+ -- TODO: this predicate is wrong, we need something more focused
+ sorted_deps = case finder_lookupHomeInterfaces fopts of
+ True -> Set.toList hpt_deps
+ False -> sortHomeUnitsByLikelihoodFor complete_home_units mb_home_unit_id mod_name hpt_deps
+
+ other_fopts =
+ [ (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))
+ | uid <- sorted_deps
+ ]
+
+sortHomeUnitsByLikelihoodFor :: CompleteUnits -> Maybe UnitId -> ModuleName -> Set.Set UnitId -> [UnitId]
+sortHomeUnitsByLikelihoodFor complete_home_units mb_home_unit_id mod_name hpt_deps =
+ let
+ cached_module_providers = M.findWithDefault Set.empty mod_name (cu_providers complete_home_units)
cached_providing_deps = Set.intersection cached_module_providers hpt_deps
other_cached_providing_deps =
Set.toList $
maybe cached_providing_deps (\u -> Set.delete u cached_providing_deps) mb_home_unit_id
uncached_providing_deps =
- let candidates = Set.difference hpt_deps (cu_inventory complete_home_units)
+ let candidates = Set.difference hpt_deps cached_module_providers
excluded = maybe cached_providing_deps (\u -> Set.insert u cached_providing_deps) mb_home_unit_id
in Set.toList (Set.difference candidates excluded)
- other_providing_deps = other_cached_providing_deps ++ uncached_providing_deps
- other_fopts =
- [ (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))
- | uid <- other_providing_deps
- ]
- !() = pprTrace "findImportedModuleNoHsc" (vcat lines) () where
-
- lines = [
- -- text "complete_home_units" <+> ppr complete_home_units,
- -- text "mb_home_unit " <+> ppr mb_home_unit,
- text "mod_name:" <+> ppr mod_name,
- text "cached_module_providers:" <+> ppr cached_module_providers,
- text "mb_home_unit_id:" <+> ppr mb_home_unit_id,
- -- text "all_opts:" <+> ppr all_opts,
- -- text "any_home_import:" <+> ppr any_home_import,
- -- text "pkg_import:" <+> ppr pkg_import ,
- -- text "unqual_import:" <+> ppr unqual_import,
- -- text "units:" <+> ppr units ,
- text "hpt_deps:" <+> ppr hpt_deps,
- text "cached_providing_deps:" <+> ppr cached_providing_deps,
- text "other_cached_providing_deps:" <+> ppr other_cached_providing_deps,
- text "uncached_providing_deps:" <+> ppr uncached_providing_deps,
- text "other_providing_deps:" <+> ppr other_providing_deps
- -- text "other_fopts:" <+> ppr other_fopts
- ]
+ all_deps = other_cached_providing_deps ++ uncached_providing_deps
+ in
+ assertPpr
+ (hpt_deps == Set.fromList all_deps)
+ ( text "Sorting must not remove HomeUnits"
+ $$ text "Module:" <+> ppr mod_name
+ $$ text "Original:" <+> ppr hpt_deps
+ $$ text "Sorted: " <+> ppr (Set.fromList all_deps))
+ all_deps
-- | Locate a plugin module requested by the user, for a compiler
-- plugin. This consults the same set of exposed packages as
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/862cd76afdafce25019b79d918e63ad…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/862cd76afdafce25019b79d918e63ad…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/jeltsch/more-efficient-home-unit-imports-finding.with-debugging] WIP: fix failing test boot1 and multipleHomeUnits_reexport
by Hannes Siebenhandl (＠fendor) 28 Apr '26
by Hannes Siebenhandl (＠fendor) 28 Apr '26
28 Apr '26
Hannes Siebenhandl pushed to branch wip/jeltsch/more-efficient-home-unit-imports-finding.with-debugging at Glasgow Haskell Compiler / GHC
Commits:
0c895a8d by fendor at 2026-04-28T11:24:23+02:00
WIP: fix failing test boot1 and multipleHomeUnits_reexport
- - - - -
1 changed file:
- compiler/GHC/Unit/Finder.hs
Changes:
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -214,7 +214,6 @@ findImportedModuleNoHsc fc fopts ue complete_home_units mb_home_unit mod_name mb
| otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mb_home_unit) $$ ppr uid $$ ppr (map fst all_opts))
OtherPkg _ -> pkg_import
where
- cached_module_providers = M.findWithDefault Set.empty mod_name (cu_providers complete_home_units)
mb_home_unit_id = homeUnitId <$> mb_home_unit
all_opts = case mb_home_unit_id of
Nothing -> other_fopts
@@ -249,42 +248,41 @@ findImportedModuleNoHsc fc fopts ue complete_home_units mb_home_unit mod_name mb
units = case mb_home_unit_id of
Nothing -> ue_homeUnitState ue
Just home_unit_id -> HUG.homeUnitEnv_units $ ue_findHomeUnitEnv home_unit_id ue
+
hpt_deps :: Set.Set UnitId
hpt_deps = homeUnitDepends units
+
+ sorted_deps = case finder_lookupHomeInterfaces fopts of
+ True -> Set.toList hpt_deps
+ False -> sortHomeUnitsByLikelihoodFor complete_home_units mb_home_unit_id mod_name hpt_deps
+
+ other_fopts =
+ [ (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))
+ | uid <- sorted_deps
+ ]
+
+sortHomeUnitsByLikelihoodFor :: CompleteUnits -> Maybe UnitId -> ModuleName -> Set.Set UnitId -> [UnitId]
+sortHomeUnitsByLikelihoodFor complete_home_units mb_home_unit_id mod_name hpt_deps =
+ let
+ cached_module_providers = M.findWithDefault Set.empty mod_name (cu_providers complete_home_units)
cached_providing_deps = Set.intersection cached_module_providers hpt_deps
other_cached_providing_deps =
Set.toList $
maybe cached_providing_deps (\u -> Set.delete u cached_providing_deps) mb_home_unit_id
uncached_providing_deps =
- let candidates = Set.difference hpt_deps (cu_inventory complete_home_units)
+ let candidates = Set.difference hpt_deps cached_module_providers
excluded = maybe cached_providing_deps (\u -> Set.insert u cached_providing_deps) mb_home_unit_id
in Set.toList (Set.difference candidates excluded)
- other_providing_deps = other_cached_providing_deps ++ uncached_providing_deps
- other_fopts =
- [ (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))
- | uid <- other_providing_deps
- ]
- !() = pprTrace "findImportedModuleNoHsc" (vcat lines) () where
-
- lines = [
- -- text "complete_home_units" <+> ppr complete_home_units,
- -- text "mb_home_unit " <+> ppr mb_home_unit,
- text "mod_name:" <+> ppr mod_name,
- text "cached_module_providers:" <+> ppr cached_module_providers,
- text "mb_home_unit_id:" <+> ppr mb_home_unit_id,
- -- text "all_opts:" <+> ppr all_opts,
- -- text "any_home_import:" <+> ppr any_home_import,
- -- text "pkg_import:" <+> ppr pkg_import ,
- -- text "unqual_import:" <+> ppr unqual_import,
- -- text "units:" <+> ppr units ,
- text "hpt_deps:" <+> ppr hpt_deps,
- text "cached_providing_deps:" <+> ppr cached_providing_deps,
- text "other_cached_providing_deps:" <+> ppr other_cached_providing_deps,
- text "uncached_providing_deps:" <+> ppr uncached_providing_deps,
- text "other_providing_deps:" <+> ppr other_providing_deps
- -- text "other_fopts:" <+> ppr other_fopts
- ]
+ all_deps = other_cached_providing_deps ++ uncached_providing_deps
+ in
+ assertPpr
+ (hpt_deps == Set.fromList all_deps)
+ ( text "Sorting must not remove HomeUnits"
+ $$ text "Module:" <+> ppr mod_name
+ $$ text "Original:" <+> ppr hpt_deps
+ $$ text "Sorted: " <+> ppr (Set.fromList all_deps))
+ all_deps
-- | Locate a plugin module requested by the user, for a compiler
-- plugin. This consults the same set of exposed packages as
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0c895a8da89e0534e901b36238f232b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0c895a8da89e0534e901b36238f232b…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
28 Apr '26
Zubin pushed to branch ghc-10.0 at Glasgow Haskell Compiler / GHC
Commits:
53fd9e34 by Vladislav Zavialov at 2026-04-27T22:00:02+03:00
Replace GHC 9.16 references with GHC 10.0
- - - - -
10 changed files:
- compiler/GHC/Driver/Flags.hs
- docs/users_guide/debug-info.rst
- docs/users_guide/exts/explicit_namespaces.rst
- docs/users_guide/exts/linear_types.rst
- docs/users_guide/exts/modifiers.rst
- docs/users_guide/exts/qualified_strings.rst
- docs/users_guide/exts/required_type_arguments.rst
- docs/users_guide/using-warnings.rst
- docs/users_guide/using.rst
- testsuite/tests/typecheck/should_fail/all.T
Changes:
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -1112,9 +1112,9 @@ data WarningFlag =
-- ^ @since 9.14, scheduled to be removed in 9.18
--
-- See Note [Quantifying over equalities in RULES] in GHC.Tc.Gen.Sig
- | Opt_WarnUnusableUnpackPragmas -- Since 9.14
- | Opt_WarnPatternNamespaceSpecifier -- Since 9.14
- | Opt_WarnUnrecognisedModifiers -- ^ @since 9.16
+ | Opt_WarnUnusableUnpackPragmas -- ^ @since 9.14
+ | Opt_WarnPatternNamespaceSpecifier -- ^ @since 9.14
+ | Opt_WarnUnrecognisedModifiers -- ^ @since 10.0
deriving (Eq, Ord, Show, Enum, Bounded)
-- | Return the names of a WarningFlag
@@ -1377,7 +1377,7 @@ standardWarnings -- see Note [Documenting warning flags]
Opt_WarnTypeEqualityRequiresOperators,
Opt_WarnInconsistentFlags,
Opt_WarnTypeEqualityOutOfScope,
- Opt_WarnImplicitRhsQuantification, -- was in -Wcompat since 9.8, enabled by default since 9.14, to turn into a hard error in 9.16
+ Opt_WarnImplicitRhsQuantification, -- was in -Wcompat since 9.8, enabled by default since 9.14, to turn into a hard error in 10.2 (#25911)
Opt_WarnViewPatternSignatures,
Opt_WarnUselessSpecialisations,
Opt_WarnDeprecatedPragmas,
=====================================
docs/users_guide/debug-info.rst
=====================================
@@ -478,7 +478,7 @@ to a source location. This lookup table is generated by using the ``-finfo-table
:type: dynamic
:category: debugging
- :since: 9.16
+ :since: 10.0
Disable generation of distinct info tables for all constructors.
@@ -488,7 +488,7 @@ to a source location. This lookup table is generated by using the ``-finfo-table
:type: dynamic
:category: debugging
- :since: 9.16
+ :since: 10.0
The entries in the info table map resulting from
:ghc-flag:`-fdistinct-constructor-tables` flag may significantly
=====================================
docs/users_guide/exts/explicit_namespaces.rst
=====================================
@@ -121,7 +121,7 @@ there is a need to support older GHC versions.
Wildcards in import/export lists
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-**Since:** GHC 9.16
+**Since:** GHC 10.0
Namespace-specified wildcards ``type ..`` and ``data ..`` may be used to import
all names in the corresponding namespace from a module: ::
=====================================
docs/users_guide/exts/linear_types.rst
=====================================
@@ -318,7 +318,7 @@ hidden; it is an essential part of the exposed interface.)
Interaction with Modifiers
--------------------------
-Since GHC version 9.16, Linear types use :extension:`Modifiers` syntax, and by
+Since GHC version 10.0, Linear types use :extension:`Modifiers` syntax, and by
default enable that extension. In earlier versions, linear types used a more
restricted variant of that syntax.
=====================================
docs/users_guide/exts/modifiers.rst
=====================================
@@ -6,7 +6,7 @@ Modifiers
.. extension:: Modifiers
:shortdesc: Allow experimental modifier syntax.
- :since: 9.16
+ :since: 10.0
:status: Experimental
Enable modifier syntax in various places, such as arrows (``a %m -> b``) and
@@ -138,10 +138,10 @@ and limitations.
let %1 (Just x) = ... -- (2b)
let %1 !(Just x) = ... -- (2c)
- In 9.14, (1a) and (2a) parsed as (1b) and (2b) respectively. From 9.16, (1a)
+ In 9.14, (1a) and (2a) parsed as (1b) and (2b) respectively. From 10.0, (1a)
parses as (1d), and (2a) fails to parse.
- Note that linear bindings must be strict. (1c) and (2c) parse in 9.16 the same
+ Note that linear bindings must be strict. (1c) and (2c) parse in 10.0 the same
as in 9.14. But with ``-XStrict`` enabled, (1a) and (2a) would previously have
been accepted, and are now rejected, even with
``-XLinearTypes -XNoModifiers``.
=====================================
docs/users_guide/exts/qualified_strings.rst
=====================================
@@ -6,7 +6,7 @@ Qualified string literals
.. extension:: QualifiedStrings
:shortdesc: Enable qualified string literals.
- :since: 9.16.1
+ :since: 10.0.1
Enable qualified string literals.
=====================================
docs/users_guide/exts/required_type_arguments.rst
=====================================
@@ -303,7 +303,7 @@ A few limitations apply:
* In term syntax, in positions where ``*`` is a direct argument to ``->``, e.g.
in ``f (* -> * -> *)`` and ``f (* -> Constraint)``, the ``*``\s stand for
``Type``, provided the :extension:`StarIsType` extension is enabled.
- This is supported from GHC 9.16 onwards; earlier versions will produce
+ This is supported from GHC 10.0 onwards; earlier versions will produce
a parse error.
What to do instead: use ``Type`` from the ``Data.Kind`` module.
=====================================
docs/users_guide/using-warnings.rst
=====================================
@@ -2711,7 +2711,7 @@ of ``-W(no-)*``.
:type: dynamic
:reverse: -Wno-unrecognised-modifiers
- :since: 9.16
+ :since: 10.0
:default: on
=====================================
docs/users_guide/using.rst
=====================================
@@ -1618,7 +1618,7 @@ Some flags only make sense for particular target platforms.
:type: dynamic
:category: platform-options
- :since: 9.16.1
+ :since: 10.0.1
:implies: :ghc-flag:`-mavx512f`
(x86 only) This flag allows the code generator (whether the :ref:`native code generator <native-code-gen>`
@@ -1639,7 +1639,7 @@ Some flags only make sense for particular target platforms.
:type: dynamic
:category: platform-options
- :since: 9.16.1
+ :since: 10.0.1
:implies: :ghc-flag:`-mavx512f`
(x86 only) This flag allows the code generator (whether the :ref:`native code generator <native-code-gen>`
@@ -1684,7 +1684,7 @@ Some flags only make sense for particular target platforms.
:type: dynamic
:category: platform-options
- :since: 9.16.1
+ :since: 10.0.1
:implies: :ghc-flag:`-mavx512f`
(x86 only) This flag allows the code generator (whether the :ref:`native code generator <native-code-gen>`
@@ -1823,7 +1823,7 @@ Some flags only make sense for particular target platforms.
:type: dynamic
:category: platform-options
- :since: 9.16.1
+ :since: 10.0.1
(x86 only) This flag allows the code generator (whether the :ref:`native code generator <native-code-gen>`
or the :ref:`LLVM backend <llvm-code-gen>`) to emit x86 GFNI instructions.
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -720,7 +720,7 @@ test('T17940', normal, compile_fail, [''])
test('ErrorIndexLinks', normal, compile_fail, ['-fprint-error-index-links=always'])
test('T24064', normal, compile_fail, [''])
test('T24090a', normal, compile_fail, [''])
-test('T24090b', normal, compile, ['']) # scheduled to become an actual error in GHC 9.16
+test('T24090b', normal, compile, ['']) # scheduled to become an actual error in GHC 10.2 (#25911)
test('T24298', normal, compile_fail, [''])
test('T24279', normal, compile, ['']) # Now accepted (Nov 2025)
test('T24318', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/53fd9e344713c2d826ba62a9c07d6c4…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/53fd9e344713c2d826ba62a9c07d6c4…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/split-driver-main] Split GHC.Driver.Main.hs up into multiple components.
by Andreas Klebinger (＠AndreasK) 28 Apr '26
by Andreas Klebinger (＠AndreasK) 28 Apr '26
28 Apr '26
Andreas Klebinger pushed to branch wip/andreask/split-driver-main at Glasgow Haskell Compiler / GHC
Commits:
24a04f05 by Andreas Klebinger at 2026-04-28T09:13:40+02:00
Split GHC.Driver.Main.hs up into multiple components.
This commit splits GHC.Driver.Main into four components:
* GHC.Driver.Main.Compile
* GHC.Driver.Main.Hsc
* GHC.Driver.Main.Interactive
* GHC.Driver.Main.Passes
We might improve that separation further in the future but this should
hopefully make it easier to reason about and work with this part of the
code.
- - - - -
15 changed files:
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Env/Types.hs
- compiler/GHC/Driver/Main.hs
- + compiler/GHC/Driver/Main/Compile.hs
- compiler/GHC/Driver/Main.hs-boot → compiler/GHC/Driver/Main/Compile.hs-boot
- + compiler/GHC/Driver/Main/Hsc.hs
- + compiler/GHC/Driver/Main/Interactive.hs
- + compiler/GHC/Driver/Main/Passes.hs
- + compiler/GHC/Driver/Main/Passes.hs-boot
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Tidy.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Types/Error.hs-boot
- compiler/ghc.cabal.in
- testsuite/tests/linters/notes.stdout
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/24a04f052e081d627784a2f41170ea6…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/24a04f052e081d627784a2f41170ea6…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed to branch wip/T26989 at Glasgow Haskell Compiler / GHC
Commits:
9bbd56e8 by Simon Peyton Jones at 2026-04-27T23:54:56+01:00
Wibbles
- - - - -
4 changed files:
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
Changes:
=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -426,7 +426,8 @@ decomposeFunCo :: HasDebugCallStack
decomposeFunCo (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 })
= (w, co1, co2)
- -- Short-circuits the calls to mkSelCo
+ -- Fast path that short-circuits the calls to mkSelCo,
+ -- even though they would give the exact same answers
decomposeFunCo co
= assertPpr all_ok (ppr co) $
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -2691,10 +2691,11 @@ same fix.
-- | `tryEtaReduce [x,y,z] e sd` returns `Just e'` if `\x y z -> e` is evaluated
-- according to `sd` and can soundly and gainfully be eta-reduced to `e'`.
--- See Note [Eta reduction soundness]
--- and Note [Eta reduction makes sense] when that is the case.
tryEtaReduce :: UnVarSet -> [Var] -> CoreExpr -> SubDemand -> Maybe CoreExpr
-- Return an expression equal to (\bndrs. body)
+-- See Note [Eta reduction soundness]
+-- and Note [Eta reduction makes sense] when that is the case.
+-- and Note [Eta reduction based on evaluation context] for the `eval_sd` arg
tryEtaReduce rec_ids bndrs body eval_sd
= go (reverse bndrs) body (mkRepReflCo (exprType body))
where
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -1729,10 +1729,15 @@ optOutCoercion env co already_optimised
opts = seOptCoercionOpts env
addCastMCo :: MOutCoercion -> SimplCont -> SimplCont
--- Simpler version of `pushCast` when optionally want to add a cast to the top
+-- Simpler, non-monadic version of pushCastMCo when we are certain that
+-- the cast should be at the top; i.e. cont is Stop or StrictArg
addCastMCo MRefl cont = cont
addCastMCo (MCo co) cont = CastIt { sc_co = co, sc_opt = False, sc_cont = cont }
+pushCastMCo :: SimplEnv -> MOutCoercion -> SimplCont -> SimplM SimplCont
+pushCastMCo _env MRefl cont = return cont
+pushCastMCo env (MCo co) cont = pushCast env co cont
+
pushCast :: SimplEnv -> OutCoercion -> SimplCont -> SimplM SimplCont
pushCast env co cont
= go co True cont
@@ -1753,7 +1758,7 @@ pushCast env co cont
-- NB! As the cast goes past, the
-- type of the hole changes (#16312)
- -- (f |> co) e ===> (f (e |> co1)) |> co2
+ -- (f |> co) arg ===> (f (arg |> co1)) |> co2
-- where co :: (s1->s2) ~ (t1->t2)
-- co1 :: t1 ~ s1
-- co2 :: s2 ~ t2
@@ -1763,12 +1768,14 @@ pushCast env co cont
= -- pushCoValArg duplicates the coercion, so optimise first
go (optOutCoercion (zapSubstEnv env) co co_is_opt) True cont
+-- ToDo: return coercionLKind. And similarly pushCoTyArg
+
| Just (m_co1, m_co2) <- pushCoValArg co
= {-#SCC "addCoerce-pushCoValArg" #-}
do { tail' <- go_mco m_co2 co_is_opt tail
; return (ApplyToVal { sc_arg = arg
, sc_env = arg_se
- , sc_cast = m_co1 `mkTransMCo` arg_mco
+ , sc_cast = arg_mco `mkTransMCo` m_co1
, sc_cont = tail'
, sc_hole_ty = coercionLKind co }) }
@@ -1778,6 +1785,7 @@ pushCast env co cont
-- See Note [Optimising reflexivity]
| otherwise = return (CastIt { sc_co = co, sc_opt = co_is_opt, sc_cont = cont })
+-- ToDo: pushCast Refl (ApplylToVal arg1 (ApplyToVal arg2 ...)) will do lots of unnecessary work.
-- If the first parameter is MRefl, then simplifying revealed a
-- reflexive coercion. Omit.
@@ -2295,7 +2303,8 @@ simplInId env var cont
| otherwise
= case substId env var of
ContEx se e mco
- -> simplExprF (se `setInScopeFromE` env) e (addCastMCo mco cont)
+ -> do { cont' <- pushCastMCo env mco cont
+ ; simplExprF (se `setInScopeFromE` env) e cont' }
-- Don't trimJoinCont; haven't already simplified e,
-- so the cont is not embodied in e
@@ -2393,10 +2402,12 @@ simplOutId env fun cont
_ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy
; let (m,_,_) = splitFunTy fun_ty
env' = arg_env `addNewInScopeIds` [s']
- cont' = addCastMCo arg_mco $
- ApplyToVal { sc_arg = Var s', sc_cast = MRefl
- , sc_env = Simplified OkDup, sc_cont = inner_cont
- , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty }
+ hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty
+ ; cont' <- pushCastMCo env' arg_mco $
+ ApplyToVal { sc_arg = Var s', sc_cast = MRefl
+ , sc_env = Simplified OkDup
+ , sc_cont = inner_cont
+ , sc_hole_ty = hole_ty }
-- cont' applies to s', then K
; body' <- simplExprC env' arg cont'
; return (Lam s' body') }
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -620,26 +620,33 @@ dropContArgs n cont = pprPanic "dropContArgs" (ppr n $$ ppr cont)
-- For example, when simplifying the argument `e` in `f e` and `f` has the
-- demand signature `<MP(S,A)>`, this function will give you back `P(S,A)` when
-- simplifying `e`.
---
--- PRECONDITION: Don't call with 'ApplyToVal'. We haven't thoroughly thought
--- about what to do then and no call sites so far seem to care.
-contEvalContext :: SimplCont -> SubDemand
-contEvalContext k = case k of
- Stop _ _ sd -> sd
- TickIt _ k -> contEvalContext k
- CastIt { sc_cont = k } -> contEvalContext k
- ApplyToTy{ sc_cont = k } -> contEvalContext k
- -- ApplyToVal{sc_cont=k} -> mkCalledOnceDmd $ contEvalContext k
+contEvalContext :: [Var] -> SimplCont -> SubDemand
+contEvalContext bndrs cont = go cont
+ where
+ go (Stop _ _ sd) = sd
+ go (TickIt _ k) = go k
+ go (CastIt { sc_cont = k }) = go k
+ go (ApplyToTy{ sc_cont = k }) = go k
+
+ -- The ApplyToVal case can actually happen, if we have
+ -- (CastIt co (ApplyToVal ..))
+ -- Possible code:
+ -- go (ApplyToVal{sc_cont=k}) = mkCalledOnceDmd $ contEvalContext k
-- Not 100% sure that's correct, . Here's an example:
-- f (e x) and f :: <SC(S,C(1,L))>
-- then what is the evaluation context of 'e' when we simplify it? E.g.,
-- simpl e (ApplyToVal x $ Stop "C(S,C(1,L))")
-- then it *should* be "C(1,C(S,C(1,L))", so perhaps correct after all.
- -- But for now we just panic:
- ApplyToVal{} -> pprPanic "contEvalContext" (ppr k)
- StrictArg{sc_fun=fun_info} -> subDemandIfEvaluated (Partial.head (ai_dmds fun_info))
- StrictBind{sc_bndr=bndr} -> subDemandIfEvaluated (idDemandInfo bndr)
- Select{} -> topSubDmd
+ -- But for now we just return topDmd.
+ go (ApplyToVal{ sc_arg = arg }) = warnPprTrace True "contEvalContext"
+ (vcat [ text "arg:" <+> ppr arg
+ , text "bndrs:" <+> ppr bndrs
+ , text "cont:" <+> ppr cont ])
+ topSubDmd
+
+ go (StrictArg{sc_fun=fun_info}) = subDemandIfEvaluated (Partial.head (ai_dmds fun_info))
+ go (StrictBind{sc_bndr=bndr}) = subDemandIfEvaluated (idDemandInfo bndr)
+ go (Select{}) = topSubDmd
-- Perhaps reconstruct the demand on the scrutinee by looking at field
-- and case binder dmds, see addCaseBndrDmd. No priority right now.
@@ -1957,9 +1964,7 @@ rebuildLam env bndrs@(bndr:_) body cont
mb_rhs = contIsRhs cont
-- See Note [Eta reduction based on evaluation context]
- eval_sd = contEvalContext cont
- -- NB: cont is never ApplyToVal, because beta-reduction would
- -- have happened. So contEvalContext can panic on ApplyToVal.
+ eval_sd = contEvalContext bndrs cont
try_eta :: [OutBndr] -> OutExpr -> SimplM OutExpr
try_eta bndrs body
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9bbd56e8ba16b562d10b5b94d92dbc0…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9bbd56e8ba16b562d10b5b94d92dbc0…
You're receiving this email because of your account on gitlab.haskell.org.
1
0