purescript · rhendric · Jul 12, 2021 · Jul 6, 2021 · Jul 11, 2021
diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md
@@ -6,7 +6,7 @@ Clearly and concisely describe the purpose of the pull request. If this PR relat
 
 **Checklist:**
 
-- [ ] Added the change to the changelog's "Unreleased" section with a reference to this PR (e.g. "- Made a change (#0000)")
+- [ ] Added a file to CHANGELOG.d for this PR (see CHANGELOG.d/README.md)
 - [ ] Added myself to CONTRIBUTORS.md (if this is my first contribution)
 - [ ] Linked any existing issues or proposals that this pull request should close
 - [ ] Updated or added relevant documentation

diff --git a/CHANGELOG.d/README.md b/CHANGELOG.d/README.md
@@ -0,0 +1,50 @@
+This directory contains changelog entries for work that has not yet been
+released. When a release goes out, these files will be concatenated and
+prepended to CHANGELOG.md in a new section for that release.
+
+Maintainers: see update-changelog.hs for details of this process.
+
+Contributors: read on!
+
+When you are preparing a new PR, add a new file to this directory. The file
+should be named `{PREFIX}_{SLUG}.md`, where `{PREFIX}` is one of the following:
+* `breaking`: for breaking changes
+* `feature`: for new features
+* `fix`: for bug fixes
+* `internal`: for work that will not directly affect users of PureScript
+* `misc`: for anything else that needs to be logged
+
+`{SLUG}` should be a short description of the work you've done. The name has no
+impact on the final CHANGELOG.md.
+
+Some example names:
+* `fix_issue-9876.md`
+* `breaking_deprecate-classes.md`
+* `misc_add-forum-to-readme.md`
+
+The contents of the file can be as brief as:
+
+```markdown
+* A short message, like the title of your commit
+```
+
+Please remember the initial `*`! These files will all be concatenated into
+lists.
+
+If you have more to say about your work, indent additional lines like so:
+
+``````markdown
+* A short message, like the title of your commit
+
+  Here is a longer explanation of what this is all about. Of course, this file
+  is Markdown, so feel free to use *formatting*
+
+  ```
+  and code blocks
+  ```
+
+  if it makes your work more understandable.
+``````
+
+You do not have to edit your changelog file to include a reference to your PR.
+The CHANGELOG.md updating script will do this automatically and credit you.
diff --git a/CHANGELOG.d/internal_changelog-dir.md b/CHANGELOG.d/internal_changelog-dir.md
@@ -0,0 +1,3 @@
+* Move unreleased changelog entries to CHANGELOG.d
+
+  See CHANGELOG.d/README.md for details.
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -2,16 +2,6 @@
 
 Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html).
 
-## [Unreleased]
-
-Breaking changes:
-
-New features:
-
-Bugfixes:
-
-Internal:
-
 ## v0.14.3
 
 New features:

diff --git a/RELEASE_GUIDE.md b/RELEASE_GUIDE.md
@@ -96,6 +96,9 @@ considering what effects this may have:
 
       - The version bounds for `purescript-cst` in `purescript.cabal`
 
+- Run `stack update-changelog.hs`, which will move the entries in `CHANGELOG.d`
+  to a new section in `CHANGELOG.md` labeled with the new version.
+
 - Create a release from the releases tab in GitHub and copy in the release
   notes. This will also create a tag, which will kick off a CI build, which
   will upload prebuilt compiler binaries to the release on GitHub when it

diff --git a/update-changelog.hs b/update-changelog.hs
@@ -0,0 +1,202 @@
+#!/usr/bin/env stack
+-- stack --resolver lts-17.6 script
+{-# LANGUAGE
+    DeriveFoldable
+  , DeriveFunctor
+  , DeriveTraversable
+  , FlexibleContexts
+  , LambdaCase
+  , NoImplicitPrelude
+  , OverloadedStrings
+  , PackageImports
+  , RecordWildCards
+  , TupleSections
+  , ViewPatterns
+#-}
+-- |
+-- This script updates CHANGELOG.md with the contents of CHANGELOG.d, and
+-- empties CHANGELOG.d. It takes care of:
+--
+-- * Sorting entries by the order in which their PRs were merged
+-- * Appending (#1234 by @author) to the first line of each fragment,
+--   optionally adding multiple PR numbers and/or authors as applicable
+-- * Grouping entries by type and adding non-empty group headings to the
+--   changelog
+-- * Syncing any affected files to the Git index, preparing for you to make
+--   your release commit
+--
+-- Be sure to run this *after* updating the version number in
+-- npm-package/package.json, as that's where this script gets the new section
+-- header from.
+--
+
+module Main (main) where
+
+import Protolude hiding (intercalate, readFile, writeFile)
+import qualified Protolude
+
+import           Control.Monad.Fail (fail)
+import qualified Data.Aeson as JSON
+import           Data.Attoparsec.ByteString (maybeResult, parse)
+import "bifunctors"
+                 Data.Bifunctor.Flip (Flip(..))
+import qualified Data.ByteString as BS
+import qualified Data.HashMap.Lazy as HM
+import qualified Data.List.NonEmpty as NEL
+import           Data.String (String)
+import qualified Data.String as String
+import qualified Data.Text as T
+import           Data.Time.Clock (UTCTime)
+import           Data.Time.Format.ISO8601 (iso8601ParseM)
+import           Data.Time.LocalTime (zonedTimeToUTC)
+import           GitHub.REST (GHEndpoint(..), GitHubState(..), KeyValue(..), MonadGitHubREST, StdMethod(..), queryGitHub, runGitHubT)
+import qualified SimpleCmd.Git as IOGit
+import           System.Directory (setCurrentDirectory)
+import           System.FilePath (normalise, takeFileName, (</>))
+
+main = runGitHubT gitHubState $ do
+  git "rev-parse" ["--show-toplevel"] >>= liftIO . setCurrentDirectory
+  entries <- String.lines <$> git "ls-tree" ["--name-only", "HEAD", "CHANGELOG.d/"]
+
+  breaks   <- processEntriesStartingWith "break" entries
+  features <- processEntriesStartingWith "feat" entries
+  fixes    <- processEntriesStartingWith "fix" entries
+  internal <- processEntriesStartingWith "int" entries
+  misc     <- processEntriesStartingWith "misc" entries
+
+  let entryFiles = ceFile <$> breaks <> features <> fixes <> internal <> misc
+  unless (null entryFiles) $ do
+
+    changes <- git "status" ("-s" : "--" : "CHANGELOG.md" : entryFiles)
+    unless (null changes) . liftIO . die $
+      "You have uncommitted changes to changelog files. " <>
+      "Please commit, stash, or revert them before running this script."
+
+    version <- getVersion
+    (changelogPreamble, changelogRest) <- T.breakOn "\n## " <$> readFile "CHANGELOG.md"
+    writeFile "CHANGELOG.md" $
+         changelogPreamble
+      <> "\n## " <> version <> "\n"
+      <> conditionalSection "Breaking changes" breaks
+      <> conditionalSection "New features" features
+      <> conditionalSection "Bugfixes" fixes
+      <> conditionalSection "Other improvements" misc
+      <> conditionalSection "Internal" internal
+      <> changelogRest
+
+    git_ "add" ["CHANGELOG.md"]
+    git_ "rm" $ "-q" : entryFiles
+
+gitHubState :: GitHubState
+gitHubState = GitHubState Nothing "purescript/purescript update-changelog.hs" "v3"
+
+processEntriesStartingWith :: (MonadFail m, MonadGitHubREST m, MonadIO m) => String -> [String] -> m [ChangelogEntry]
+processEntriesStartingWith prefix
+  = fmap (sortOn ceDate)
+  . traverse updateEntry
+  . filter ((prefix `isPrefixOf`) . map toLower . takeFileName)
+
+updateEntry :: (MonadFail m, MonadGitHubREST m, MonadIO m) => String -> m ChangelogEntry
+updateEntry file = do
+  (header, body) <- T.breakOn "\n" . T.strip <$> (readFile . normalise) file
+
+  allCommits <-
+        fmap (NEL.fromList . sortOn glcTime)
+    .   traverse (\(T.breakOn " " -> (h, T.breakOn " " . T.tail -> (c, s))) ->
+          GitLogCommit (T.tail s) h . zonedTimeToUTC <$> iso8601ParseM (toS c))
+    =<< gitLines "log" ["-m", "--follow", "--format=%H %cI %s", file]
+
+  prCommits <-
+      filterM isInterestingCommit
+    . mapMaybe (traverse parsePRNumber)
+    $ NEL.toList allCommits
+
+  let prNumbers = map (snd . glcData) prCommits
+
+  prAuthors <- ordNub <$> traverse lookupPRAuthor prNumbers
+
+  let headerSuffix = if null prNumbers then "" else
+           " ("
+        <> commaSeparate (map (("#" <>) . show) prNumbers)
+        <> " by "
+        <> commaSeparate (map ("@" <>) prAuthors)
+        <> ")"
+
+  pure $ ChangelogEntry file (header <> headerSuffix <> body <> "\n") (glcTime $ NEL.head allCommits)
+
+parsePRNumber :: Text -> Maybe (CommitType, Int)
+parsePRNumber = liftA2 (<|>)
+  (fmap (MergeCommit, ) . readMaybe . toS . fst . T.breakOn " " <=< T.stripPrefix "Merge pull request #")
+  (fmap (SquashCommit, ) . readMaybe . toS <=< T.stripSuffix ")" . snd . T.breakOnEnd "(#")
+
+-- |
+-- This function helps us exclude PRs that are just fixups of changelog
+-- wording. An interesting commit is one that has either edited a file that
+-- isn't part of the changelog, or is a merge commit.
+--
+isInterestingCommit :: MonadIO m => GitLogCommit (CommitType, Int) -> m Bool
+isInterestingCommit GitLogCommit{..} = case fst glcData of
+  MergeCommit -> pure True
+  SquashCommit ->
+    not . all (\path -> "CHANGELOG.md" == path || "CHANGELOG.d/" `T.isPrefixOf` path)
+      <$> gitLines "show" ["--format=", "--name-only", toS glcHash]
+
+lookupPRAuthor :: (MonadFail m, MonadGitHubREST m) => Int -> m Text
+lookupPRAuthor prNum =
+  queryGitHub GHEndpoint{ method = GET
+                        , endpoint = "/repos/purescript/purescript/pulls/:pr"
+                        , endpointVals = ["pr" := prNum]
+                        , ghData = []
+                        }
+    >>= \case
+      JSON.Object (HM.lookup "user" -> Just (JSON.Object (HM.lookup "login" -> Just (JSON.String name)))) -> pure name
+      _ -> fail "error accessing GitHub API"
+
+commaSeparate :: [Text] -> Text
+commaSeparate = \case
+  [] -> ""
+  [a] -> a
+  [a, b] -> a <> " and " <> b
+  more | Just (init, last) <- unsnoc more -> T.intercalate ", " init <> ", and " <> last
+
+getVersion :: (MonadFail m, MonadIO m) => m Text
+getVersion =
+  (liftIO . BS.readFile) ("npm-package" </> "package.json") >>= \case
+    (maybeResult . parse JSON.json -> Just (JSON.Object (HM.lookup "version" -> Just (JSON.String v)))) -> pure v
+    _ -> fail "could not read version from npm-package/package.json"
+
+conditionalSection :: Text -> [ChangelogEntry] -> Text
+conditionalSection header = \case
+  [] -> ""
+  entries ->
+    "\n" <> header <> ":\n\n" <> T.intercalate "\n" (map ceContent entries)
+
+git :: MonadIO m => String -> [String] -> m String
+git cmd = liftIO . IOGit.git cmd
+
+git_ :: MonadIO m => String -> [String] -> m ()
+git_ cmd = liftIO . IOGit.git_ cmd
+
+gitLines :: MonadIO m => String -> [String] -> m [Text]
+gitLines cmd args = lines . toS <$> git cmd args
+
+readFile :: MonadIO m => FilePath -> m Text
+readFile = liftIO . Protolude.readFile
+
+writeFile :: MonadIO m => FilePath -> Text -> m ()
+writeFile path = liftIO . Protolude.writeFile path
+
+data ChangelogEntry = ChangelogEntry
+  { ceFile :: String
+  , ceContent :: Text
+  , ceDate :: UTCTime
+  }
+
+data GitLogCommit a = GitLogCommit
+  { glcData :: a
+  , glcHash :: Text
+  , glcTime :: UTCTime
+  }
+  deriving (Functor, Foldable, Traversable)
+
+data CommitType = MergeCommit | SquashCommit
Original file line number	Diff line number	Diff line change
		@@ -0,0 +1,3 @@
		* Move unreleased changelog entries to CHANGELOG.d

		See CHANGELOG.d/README.md for details.