hledger/tools/relnotes.hs

#!/usr/bin/env runhaskell
{-
Make/update hledger release notes from the latest release's changelogs.
Run this in the root of the hledger repo, in a release branch.
If you have switched branch recently you may have to kill an unhelpful
ghc environment file first. Eg: rm -f .ghc.environment* && tools/relnotes.hs

This reads the latest release's changes from the main CHANGES.md files,
converts to release notes format, and inserts this into relnotes.md.
If there already were release notes for this release (at top of relnotes),
they will be replaced, except for a manually added "highlights" paragraph if any
(after the release heading, beginning and ending with **), which is preserved.

The release's version is taken from the the first h1 heading in the project CHANGES.md.
It is assumed that all the other changelogs' first section is also for this version (XXX),
and that changelogs and relnotes are non-empty with specific layout and heading formats.

In the end I wrote this in haskell because everything else was harder.
-}

{-# OPTIONS_GHC -Wno-x-partial #-}

import Control.Monad
import Data.Char
import Data.List
import Data.List.Split
import System.Exit
import System.IO
import System.Process
import Text.Printf

strToVer = splitOn "."
verToStr = intercalate "."

main = do
  -- gather latest release changes & info
  (projectChangesHeading, projectChanges)       <- changelogFirstSection <$> readFile "CHANGES.md"
  (hledgerChangesHeading, hledgerChanges)       <- changelogFirstSection <$> readFile "hledger/CHANGES.md"
  (hledgerUiChangesHeading, hledgerUiChanges)   <- changelogFirstSection <$> readFile "hledger-ui/CHANGES.md"
  (hledgerWebChangesHeading, hledgerWebChanges) <- changelogFirstSection <$> readFile "hledger-web/CHANGES.md"
  reltags <- lines <$> readProcess "git" ["tag", "--sort=-creatordate", "-l", "[0-9]*"] ""
  printf $ "previous release tags: " <> unwords (take 5 reltags) <> " ...\n"
  let
    [_, ver, date] = words projectChangesHeading
    verexists = ver `elem` reltags
  printf $ "project CHANGES.md's top heading: " <> projectChangesHeading
  printf $ "inferred latest release version and date: " <> intercalate ", " [ver, date] <> "\n"
  printf $ "a tag for this release " <> (if verexists then "exists" else "does not yet exist") <> "\n"
  let prevvers =
        map verToStr $ dropWhile (>=strToVer ver) $ map strToVer $ reltags
  printf $ "releases before this one: " <> unwords (take 5 prevvers) <> " ...\n"
  when (null prevvers) $ do
    printf $ "error: no previous releases found. This expects to run before new release headings are added to changelogs\n"
    exitFailure
  let prevver = head prevvers
  printf $ "previous release: " <> prevver <> "\n"
  relauthors <- map (unwords . drop 1 . words) . lines <$> readProcess "git" ["shortlog", "-sn", prevver<>".."<>if verexists then ver else ""] ""
  printf $ "this release's authors: " <> intercalate ", " relauthors <> "\n"

  -- convert to release notes format
  let
    newrelnotesheading = printf "## %s hledger-%s\n" date ver
    newrelnotesbody = intercalate "\n\n" [
      changelogHeadingToRelnotesHeading "hledger" hledgerChangesHeading,        hledgerChanges,
      changelogHeadingToRelnotesHeading "hledger-ui" hledgerUiChangesHeading,   hledgerUiChanges,
      changelogHeadingToRelnotesHeading "hledger-web" hledgerWebChangesHeading, hledgerWebChanges,
      "### project changes " <> ver <> "\n",                                    projectChanges,
      "### credits " <> ver <> "\n",                                            intercalate ",\n" relauthors <> ".\n"
      ] <> "\n\n"

  -- insert or update in relnotes.md
  let relnotesfile = "doc/relnotes.md"
  (preamble, rnlatestver, rnlatesthighlights, rnlatestbody, rest) <-
    relnotesSections <$> readFile' relnotesfile
  -- putStrLn $
  writeFile relnotesfile $
    unlines [
      preamble,
      newrelnotesheading,
      if null rnlatesthighlights then "" else rnlatesthighlights <> "\n",
      newrelnotesbody,
      if rnlatestver == ver then "" else rnlatestbody,
      rest
      ] <> "\n"

changelogFirstSection alltext =
  case uncons $ dropWhile (not.isReleaseHeading) $ lines alltext of
    Nothing     -> ("","")
    Just (l,ls) -> (nl l, strip' $ unlines $ takeWhile (not.isReleaseHeading) ls)
  where
    isReleaseHeading = isPrefixOf "# "

changelogHeadingToRelnotesHeading pkgname heading =
  let [_, ver, _] = words heading
  in printf "### %s %s\n" pkgname ver

relnotesSections alltext = (unlines preamble, firstsectionver, firstsectionhighlights, firstsectionbody, rest)
  where
    isReleaseHeading = isPrefixOf "## "
    (preamble, (firstsectionheading:ls)) = span (not.isReleaseHeading) $ lines alltext
    firstsectionver = drop 8 $ (!!2) $ words firstsectionheading
    ls2 = dropWhile null ls
    (firstsectionhighlights, ls3) =
      case ls2 of
        ('*':'*':_):_ -> (unlines $ takeWhile (not.null) ls2, dropWhile (not.null) ls2)
        _             -> ("", ls2)
    (firstsectionls, restls) = span (not.isReleaseHeading) ls3
    firstsectionbody = unlines $ firstsectionheading : firstsectionls
    rest = unlines restls

unlines' = intercalate "\n"

lstrip = dropWhile isSpace
rstrip = reverse . lstrip . reverse
strip = lstrip . rstrip
strip' = nl . strip
nl = (<>"\n")