#!/usr/bin/env stack

{- stack script --resolver nightly-2024-05-01 --compile

--extra-include-dirs /Library/Developer/CommandLineTools/SDKs/MacOSX12.1.sdk/usr/include/ffi

--package base-prelude

--package directory

--package extra

--package process

--package regex

--package safe

--package shake

--package time

-}

{-

-- add this to see packages being installed instead of a long silence:

--verbosity=info

Heavy project scripts, with file dependencies, using https://shakebuild.com.

See also justfile, Makefile.

Also uses tools like:

- hpack (same version that's in current stack release)

- GNU date (on mac, get it with brew install coreutils)

- pandoc, groff, m4, makeinfo, sed, mv, cat, rm

Some things that may be useful when working on this:

- https://docs.haskellstack.org/en/stable/GUIDE/#script-interpreter

- watch Shake.hs for compile errors: make ghcid-shake

- load Shake.hs in GHCI: make ghci-shake

- rebuild things when files change with entr (file watcher), eg:

find hledger-lib hledger | entr ./Shake manuals

- view rule dependency graph:

./Shake --report, open report.html?mode=rule-graph&query=!name(/(doc|images|js|css|fonts|time|api|ui|csv)/)

-}

{-# LANGUAGE MultiWayIf #-}

{-# LANGUAGE NamedFieldPuns #-}

{-# LANGUAGE PackageImports #-}

{-# LANGUAGE QuasiQuotes #-}

{-# LANGUAGE ScopedTypeVariables #-}

import Prelude ()

import "base-prelude" BasePrelude

import "base" Control.Exception as C

-- required packages, keep synced with Makefile -> SHAKEDEPS:

import "directory" System.Directory as S (getDirectoryContents)

import "extra" Data.List.Extra hiding (headDef, lastDef)

import "regex" Text.RE.TDFA.String

import "regex" Text.RE.Replace

import "safe" Safe

import "shake" Development.Shake

import "shake" Development.Shake.FilePath

import "time" Data.Time

-- import Debug.Trace

-- import "hledger-lib" Hledger.Utils.Debug

usage =

let scriptname = "Shake" in replaceRe [re|/Shake|] ('/':scriptname) $

unlines

---------------------------------------79--------------------------------------

["Shake: heavy project scripting. See also: justfile, Makefile"

,"Usage:"

,"./Shake.hs [CMD [ARGS]] run CMD, compiling this script first if needed"

,"./Shake [CMD [ARGS]] run CMD, using the compiled version of this script"

,"./Shake [help] show this help"

,"./Shake cabalfiles [-c] update */*.cabal files from */package.yaml"

,"./Shake setversion [VER] [PKGS] [-c]"

," update versions in source files to */.version or VER"

," and update */*.cabal files"

-- ,"./Shake flagdocs [-c] update flags in hledger CLI command docs"

-- ," (run after changing command flags)"

,"./Shake cmddocs [-c] update hledger command help (including command flags,"

," but not main flags) after changing command flags/docs)"

,"./Shake mandates update the date shown in some manual formats"

,"./Shake manuals [-c] update all packages' txt/man/info/web manuals"

-- ,"./Shake webmanuals update just the web manuals"

,"./Shake changelogs [-c] [-n/--dry-run]"

," update CHANGES.md files, adding new commits & headings"

,"./Shake docs [-c] update all program docs (CLI help, manuals, changelogs)"

,"./Shake site update (render) the website, in ./site"

,"./Shake build [PKGS] build hledger packages and their embedded docs"

,"./Shake clean remove generated texts, manuals"

,"./Shake Clean also remove object files, Shake's cache"

,"./Shake FILE build any individual file"

,"./Shake --help list shake build options (--color, --rebuild, etc."

," Keep shake option arguments adjacent to their flag.)"

,""

,"See comments in Shake.hs for more detailed descriptions."

,"Add -c/--commit to have commands commit their changes."

,"Add -V/-VV/-VVV to see more verbose output."

,"Add -B, with nothing immediately after it, to force rebuilding."

]

-- TODO

-- ,"./Shake releasebranch create a new release branch, bump master to next dev version (.99)"

-- ,"./Shake majorversion bump to the next major version project-wide, update affected files"

-- ,"./Shake minorversion PKGS bump one or more packages to their next minor version project-wide, update affected files"

-- ,"./Shake relnotes create draft release notes"

-- groff = "groff -c" " -Wall" -- see "groff" below

m4 = "m4 -P"

makeinfo = "makeinfo -cASCII_PUNCTUATION=1 --no-split --force --no-warn --no-validate" -- silence makeinfo warnings, comment these to see them

pandoc = "pandoc --strip-comments"

-- We should work with both BSD and GNU sed. Tips:

-- use [a-z] [0-9] instead of \w \d etc.

-- backslash-escape things like: { &

sed = "sed -E"

-- We should work with both BSD and GNU grep.

grep = "grep -E"

-- The kind of markdown used in our doc source files.

-- Note: without hard_line_breaks here, paragraphs get refilled,

-- which is good for nice rendered info/man/text output, but so do

-- multiline arguments to m4 macros, which is bad eg when using

-- _info_ to add Info directives (cf #806). For such situations we

-- work around by calling the macro for each line of text, it

-- would be nice to find a way to avoid this.

fromsrcmd = "-f markdown-smart-tex_math_dollars"

-- The kind of org markup used in any org source files.

-- In pandoc 2.14, org reader enables smart dashes by default;

-- use # OPTIONS: -:nil in the org file to disable it (-smart here has no effect).

-- We also write to markdown strict, which would undo any smart dashes or quotes).

fromorg = "-f org-smart"

-- The kind of markdown we like to generate for the website.

--

-- This was configured for sphinx recommonmark sphinx-markdown-tables; it could be reviewed now that we use mdbook.

-- Trying to force the use of pipe_tables here, but sometimes it uses html instead.

--

-- --markdown-headings=atx requires pandoc 2.11.2 ; with older pandoc use --atx-headers instead.

--

-- In pandoc 2.14, "If you are writing Markdown, then the smart extension has the

-- reverse effect: what would have been curly quotes comes out straight.".

-- So smart here can fix unwanted smart typography that may have crept in,

-- eg from org docs (see above).

--

towebmd = "-t markdown smart-fenced_divs-fenced_code_attributes-simple_tables-multiline_tables-grid_tables-raw_attribute --markdown-headings=atx"

main = do

-- Gather some IO values used by rules.

-- hledger manual also includes the markdown files from here:

let commandsdir = "hledger/Hledger/Cli/Commands"

commandmds <-

sort . filter (not . ("README." `isPrefixOf`) . takeFileName) . filter (".md" `isSuffixOf`) . map (commandsdir </>)

<$> S.getDirectoryContents commandsdir

let

commandmdsnew = map (<.> "new") commandmds

commandtxts = map (-<.> "txt") commandmds

-- Run the shake rule selected by the first command line argument.

-- Other arguments and some custom flags are set aside for the rule

-- to use if it wants.

-- Option arguments should be kept adjacent to their flag or this will go wrong.

(opts, args) <- partition ("-" `isPrefixOf`) <$> getArgs

let

ruleoptnames = [

"--commit", "-c"

,"--dry-run", "--dry", "-n"

]

(ruleopts, shakeopts) = partition (`elem` ruleoptnames) opts

commit = any (`elem` ruleopts) ["--commit", "-c"]

dryrun = any (`elem` ruleopts) ["--dry-run", "--dry", "-n"]

(shakearg, ruleargs) = splitAt 1 args

shakeargs = shakeopts shakearg

-- print (opts,args,shakeopts,shakearg,shakeargs,ruleopts,ruleargs)

withArgs shakeargs $ shakeArgs shakeOptions{

shakeVerbosity=Quiet

-- ,shakeReport=[".shake.html"]

}

$ do

-- The rules.

want ["help"]

phony "help" $ liftIO $ putStr usage

-- NAMES, FILES, URIS, HELPERS

let

-- main package names, in standard build order

packages = [

"hledger-lib"

,"hledger"

,"hledger-ui"

,"hledger-web"

]

pkgdirs = packages

pkgandprojdirs = "" : pkgdirs

cabalfiles = [p </> p <.> "cabal" | p <- packages]

changelogs = map (</> "CHANGES.md") pkgandprojdirs

packagemanversionm4s = [p </> ".version.m4" | p <- packages]

packagemandatem4s = [p </> ".date.m4" | p <- packages]

-- doc files (or related targets) that should be generated

-- before building hledger packages.

-- [(PKG, [TARGETS])]

embeddedFiles = [

-- hledger embeds the plain text command help files and all packages' text/nroff/info manuals

("hledger", commandtxts ["manuals"])

-- hledger-ui imports the hledger-ui manuals from hledger

,("hledger-ui", ["hledger"])

]

-- man page names (manual names plus a man section number), in suggested reading order

manpageNames = [

"hledger.1"

,"hledger-ui.1"

,"hledger-web.1"

]

-- basic manual names, without numbers

manualNames = map manpageNameToManualName manpageNames

-- main markdown m4 source files for manuals (hledger/hledger.m4.md)

-- These may include additional files using m4.

m4manuals = [manualDir m </> m <.> "m4.md" | m <- manualNames]

-- manuals as plain text, ready for embedding as CLI help (hledger/hledger.txt)

txtmanuals = [manualDir m </> m <.> "txt" | m <- manualNames]

-- manuals as nroff, ready for man (hledger/hledger.1)

nroffmanuals = [manpageDir m </> m | m <- manpageNames]

-- manuals as info, ready for info (hledger/hledger.info)

infomanuals = [manualDir m </> m <.> "info" | m <- manualNames]

-- an Info directory entry for each package's info manual (hledger/dir-entry.texi)

infodirentries = [manualDir m </> "dir-entry.texi" | m <- manualNames]

-- a generated Info directory file for easily accessing/linking the dev version of all the info manuals

-- infodir = "dir"

-- manuals as sphinx-ready markdown, to be rendered as part of the website (hledger/hledger.md)

webmanuals = [manualDir m </> m <.> "md" | m <- manualNames]

-- -- old versions of the manuals rendered to html (site/_site/doc/1.14/hledger.html)

-- oldhtmlmanuals = map (normalise . ("site/_site/doc" </>) . (<.> "html")) $

-- [ v </> manpageNameToWebManualName p | v <- docversions, v>="1.0", p <- manpageNames ["manual"] ]

-- [ v </> "manual" | v <- docversions, v <"1.0" ] -- before 1.0 there was only the combined manual

-- The directory in which to find this man page.

-- hledger.1 -> hledger/doc, hledger_journal.5 -> hledger-lib/doc

manpageDir m

| '_' `elem` m = "hledger-lib"

| otherwise = dropExtension m

-- The directory in which to find this manual.

-- hledger -> hledger, hledger_journal -> hledger-lib

manualDir m

| '_' `elem` m = "hledger-lib"

| otherwise = m

-- The web manual name (& URI "slug") corresponding to this man page.

-- hledger.1 -> hledger, hledger_journal.5 -> journal

manpageNameToWebManualName m | "hledger_" `isPrefixOf` m = dropExtension $ drop 8 m

| otherwise = dropExtension m

-- The man page corresponding to this web manual name.

-- hledger -> hledger.1, journal -> hledger_journal.5

webManualNameToManpageName u | "hledger" `isPrefixOf` u = u <.> "1"

| otherwise = "hledger_" u <.> "5"

-- VERSION NUMBERS

-- Regenerate .cabal files from package.yaml files.

-- (used by "cabalfiles" and "setversion")

let gencabalfiles = do

-- Update cabal files with stack build.

-- stack 1.7 no longer updates cabal files with --dry-run, we must do a full build.

-- stack can return zero exit code while failing to update cabal files so

-- we need to check for the error message (specifically) on stderr.

-- out <- fromStdouterr <$> -- (getting both stdout and stderr here just as an example)

-- (cmd (EchoStdout True) (EchoStderr True) Shell "stack build" :: Action (Stdouterr String))

-- when ("was generated with a newer version of hpack" `isInfixOf` out) $

-- liftIO $ putStr out >> exitFailure

-- Or update them with hpack directly.

-- It should be the same hpack version that's in current stack, to avoid commit conflicts.

forM_ pkgdirs $ \d -> cmd_ (Cwd d) Shell "hpack --no-hash"

when commit $ commitIfChanged ";cabal: update cabal files" cabalfiles

-- Update version strings in most "source" files to match what's in PKG/.version.

-- If a version number is provided as first argument, save that in PKG/.version files first.

-- If one or more subdirectories are provided as arguments, save/update only those.

-- Also regenerates .cabal files from package.yaml files.

-- See also CONTRIBUTING.md > Version numbers.

phony "setversion" $ do

let

(mver, dirargs) = (headMay ver', drop 1 ver' dirs')

where (ver',dirs') = span isVersion ruleargs

(specifieddirs, specifiedpkgs) =

case dirargs of [] -> (pkgandprojdirs, pkgdirs)

ds -> (ds, ds)

-- if a version was provided, update .version files in the specified directories

let specifiedversionfiles = map (</> ".version") specifieddirs

case mver of

Just v -> liftIO $ forM_ specifiedversionfiles $ flip maybeWriteFile (v "\n")

Nothing -> return ()

-- update "source" files depending on .version in the specified packages

let dependents = map (</> ".version.m4") specifiedpkgs

map (</> "package.yaml") specifiedpkgs

need dependents

-- and maybe commit them

when commit $ do

let msg = unwords [

";pkg: bump"

,case dirargs of

[] -> "version"

ds -> intercalate ", " ds " version"

,case mver of

Nothing -> ""

Just v -> "to " v

]

commitIfChanged msg $ specifiedversionfiles dependents

gencabalfiles

-- PKG/.version.m4 <- PKG/.version, just updates the _version_ macro

"hledger*/.version.m4" %> \out -> do

let versionfile = takeDirectory out </> ".version"

need [versionfile]

version <- ((headDef (error $ "failed to read " <> versionfile) . words) <$>) $ liftIO $ readFile versionfile

cmd_ Shell sed "-i -e" ("'s/(_version_}}, *)\\{\\{[^}] /\\1{{" version "/;'") out

-- PKG/package.yaml <- PKG/.version, just updates version strings

"hledger*/package.yaml" %> \out -> do

let versionfile = takeDirectory out </> ".version"

need [versionfile]

version <- ((headDef (error $ "failed to read " <> versionfile) . words) <$>) $ liftIO $ readFile versionfile

let ma:jor:_ = splitOn "." version

nextmajorversion = intercalate "." [ma, show $ read jor 1]

-- One simple task: update some strings in a small text file.

-- Several ugly solutions:

--

-- 1. use haskell list utils. Tedious.

-- old <- liftIO $ readFileStrictly out

-- let isversionline s = "version" `isPrefixOf` (dropWhile isSpace $ takeWhile (not.(`elem` " :")) s)

-- (before, _:after) = break isversionline $ lines old

-- -- oldversion = words versionline !! 1

-- new = unlines $ before ["version: " version] after

-- liftIO $ writeFile out new

--

-- 2. use regular expressions in haskell. Haskell has no portable,

-- featureful, replacing, backreference-supporting regex lib yet.

--

-- 3. use sed. Have to assume non-GNU sed, eg on mac.

-- Things to update in package.yaml:

--

-- version: VER

cmd_ Shell sed "-i -e" ("'s/(^version *:).*/\\1 " version "/'") out

--

-- -DVERSION="VER"

cmd_ Shell sed "-i -e" ("'s/(-DVERSION=)\"[^\"] /\\1\"" version "/'") out

--

-- this package's dependencies on other hledger packages (typically hledger-lib, hledger)

--

-- This one is a bit tricky, and we do it with these limitations:

-- a. We handle bounds in one of these forms (allowing extra whitespace):

-- ==A

-- >A

-- >=A

-- >A && <B

-- >=A && <B

-- b. We set

-- the new lower bound to: this package's new version, V

-- the new upper bound if any, to: the next major version after V

-- both of which may not be what's desired.

-- c. We convert > bounds to >= bounds.

--

-- hledger[-PKG] ==LOWER

let versionre = "([0-9] \\.)*[0-9] " -- 2 or 3 part version number regexp

cmd_ Shell sed "-i -e" ("'s/(hledger(-[a-z] )?) *== *" versionre " *$/\\1 == " version "/'") out

--

-- hledger[-PKG] >[=]LOWER

cmd_ Shell sed "-i -e" ("'s/(hledger(-[a-z] )?) *>=? *" versionre " *$/\\1 >= " version "/'") out

--

-- hledger[-PKG] >[=]LOWER && <UPPER

let

pat = "(hledger(-[a-z] )?) *>=? *" versionre " *&& *< *" versionre " *$"

rpl = "\\1 >=" version " \\&\\& <" nextmajorversion -- This was a beast. These ampersands must be backslash-escaped.

arg = "'s/" pat "/" rpl "/'"

cmd_ Shell sed "-i -e" arg out

let pkg = takeDirectory out

when (pkg /= "hledger-lib") $ liftIO $ do

putStrLn $ out ": hledger bounds are (improve if needed):"

cmd_ Shell grep "'^ *- hledger.*[<>=]'" out

" || [[ $? == 1 ]]" -- ignore no matches, https://unix.stackexchange.com/a/427598

phony "cabalfiles" $ gencabalfiles

-- MANUALS

-- Generate the manuals in plain text, nroff, info, and markdown formats.

phony "manuals" $ do

need $ concat [

nroffmanuals

,infomanuals

-- ,[infodir]

,txtmanuals

,webmanuals

]

when commit $

commitIfChanged ";doc: update manuals" $

concat [packagemandatem4s, nroffmanuals, infomanuals, infodirentries, txtmanuals] -- infodir

-- Update the dates to show in man pages, to the current month and year.

-- Currently must be run manually when needed.

-- Dates are stored in PKG/.date.m4, and are committed along with manuals by Shake manuals -c.

phony "mandates" $ do

date <- chomp . fromStdout <$> (cmd Shell "date '%B %Y'" :: Action (Stdout String))

forM_ packagemandatem4s $ \f -> do

cmd_ Shell ["perl","-pi","-e","'s/(.*)\\{\\{.*}}(.*)$/\\1\\{\\{" date "}}\\2/'",f]

-- Generate nroff man pages suitable for man output, from the .m4.md source.

-- Also updates the _monthyear_ macro to current month and year in hledger*/.date.m4.

phony "nroffmanuals" $ need nroffmanuals

nroffmanuals |%> \out -> do -- hledger/hledger.1

let src = manpageNameToManualName out <.> "m4.md"

commonm4 = "doc/common.m4"

commandsm4 = "hledger/Hledger/Cli/Commands/commands.m4"

dir = takeDirectory out

pkg = dir

packagemanversionm4 = dir </> ".version.m4"

packagemandatem4 = dir </> ".date.m4"

tmpl = "doc/manpage.nroff"

pkgversion <- liftIO $ readFile $ dir </> ".version"

-- mandate <- formatTime defaultTimeLocale "%B %Y" <$> liftIO getCurrentDay -- XXX not using this.. compare with .date.m4

-- assume any other .m4.md files in dir are included by this one XXX not true in hledger-lib

subfiles <- liftIO $ filter (/= src) . filter (".m4.md" `isSuffixOf`) . map (dir </>) <$> S.getDirectoryContents dir

need $ [src, commonm4, commandsm4, packagemanversionm4, packagemandatem4, tmpl] subfiles

when (dir=="hledger") $ need commandmds

cmd Shell

m4 "-DMANFORMAT -I" dir commonm4 commandsm4 packagemanversionm4 packagemandatem4 src "|"

pandoc fromsrcmd "-s" "--template" tmpl

("-V footer='" pkg "-" pkgversion "'")

"--lua-filter tools/pandoc-drop-html-blocks.lua"

"--lua-filter tools/pandoc-drop-html-inlines.lua"

"--lua-filter tools/pandoc-drop-links.lua"

"-o" out

-- Generate plain text manuals suitable for embedding in

-- executables and viewing with a pager, from the man pages.

-- (Depends on the nroffmanuals.)

phony "txtmanuals" $ need txtmanuals

txtmanuals |%> \out -> do -- hledger/hledger.txt

let src = manualNameToManpageName $ dropExtension out

need [src]

-- cmd Shell groff "-t -e -mandoc -Tascii" src "| col -b >" out -- http://www.tldp.org/HOWTO/Man-Page/q10.html

-- Workaround: groff 1.22.4 always calls grotty in a way that adds ANSI/SGR escape codes.

-- (groff -c is supposed to switch those to backspaces, which we could

-- remove with col -b, but it doesn't as can be seen with groff -V.)

-- To get plain text, we run groff's lower-level commands (from -V) and add -cbuo.

-- -Wall silences most troff warnings, remove to see them

-- XXX eqn complains on nonascii chars, not needed ?

-- cmd Shell "tbl" src "| eqn -Tascii | troff -Wall -mandoc -Tascii | grotty -cbuo >" out

-- XXX how to silence wide table warnings (generated by tbl, reported by troff) ?

cmd Shell "tbl" src "| troff -Wall -mandoc -Tascii | grotty -cbuo >" out

-- Generate Info manuals suitable for viewing with info, from the .m4.md source.

infomanuals |%> \out -> do -- hledger/hledger.info

let src = out -<.> "m4.md"

commonm4 = "doc/common.m4"

commandsm4 = "hledger/Hledger/Cli/Commands/commands.m4"

dir = takeDirectory out

packagemanversionm4 = dir </> ".version.m4"

packagemandatem4 = dir </> ".date.m4"

direntry = dir </> "dir-entry.texi"

-- assume any other .m4.md files in dir are included by this one XXX not true in hledger-lib

subfiles <- liftIO $ filter (/= src) . filter (".m4.md" `isSuffixOf`) . map (dir </>) <$> S.getDirectoryContents dir

need $ [src, commonm4, commandsm4, packagemanversionm4, packagemandatem4, direntry] subfiles

when (dir=="hledger") $ need commandmds

cmd_ Shell

"( cat" direntry ";"

m4 "-DINFOFORMAT -I" dir commonm4 commandsm4 packagemanversionm4 packagemandatem4 src "|"

-- sed "-e 's/^#(# )/\\1/'" "|"

pandoc fromsrcmd

"--lua-filter tools/pandoc-drop-html-blocks.lua"

"--lua-filter tools/pandoc-drop-html-inlines.lua"

"--lua-filter tools/pandoc-drop-links.lua"

-- add "standalone" headers ? sounds good for setting text encoding,

-- but messes up quotes ('a' becomes ^Xa^Y)

-- "-s"

"-t texinfo ) |"

makeinfo "-o" out

-- XXX This generates ./dir, for previewing latest dev manuals in Info's directory.

-- For that we need subdirectory paths like "hledger: (hledger/hledger)",

-- but this generates "hledger: (hledger)". Don't regenerate dir for now.

--

-- Generate an Info dir file which can be included with info -d

-- or INFOPATH to add hledger menu items in Info's Directory.

-- infodir %> \out -> do

-- need infomanuals

-- forM_ infomanuals $ \info -> cmd_ Shell "install-info" info out

phony "infomanuals" $ need $ infomanuals -- [infodir]

-- WEBSITE MARKDOWN SOURCE

-- Generate the individual web manuals' markdown source, using m4

-- and pandoc to tweak content.

phony "webmanuals" $ need webmanuals

webmanuals |%> \out -> do -- hledger/hledger.md, hledger/hledger-ui.md ..

let

dir = takeDirectory out -- hledger, hledger-lib

manpage = webManualNameToManpageName $ dropExtension $ dropExtension $ takeFileName out -- hledger, journal

manual = manpageNameToManualName manpage -- hledger, hledger_journal

src = dir </> manual <.> "m4.md"

commonm4 = "doc/common.m4"

commandsm4 = "hledger/Hledger/Cli/Commands/commands.m4"

packageversionm4 = dir </> ".version.m4"

packagemandatem4 = dir </> ".date.m4"

heading = let h = manual

in if "hledger_" `isPrefixOf` h

then drop 8 h " format"

else h

-- assume any other .m4.md files in dir are included by this one XXX not true in hledger-lib

subfiles <- liftIO $ filter (/= src) . filter (".m4.md" `isSuffixOf`) . map (dir </>) <$> S.getDirectoryContents dir

let deps = [src, commonm4, commandsm4, packageversionm4, packagemandatem4] subfiles

need deps

when (manual=="hledger") $ need commandmds

-- add the web page's heading.

-- XXX Might be nice to do this atomically with the below, so

-- make avoid any double refresh when watch docs with entr/livereload.

-- But cmd Shell doesn't handle arguments containing spaces properly.

liftIO $ writeFile out $ unlines [

"<!-- " "Generated by \"Shake webmanuals\" from " unwords deps " -->"

,"<div class=\"docversions\"></div>"

,""

,"# " heading

,""

,"<div class=\"pagetoc manual\">"

,""

,"<!-- toc -->"

,"</div>"

,""

]

cmd Shell

m4 "-DWEBFORMAT -I" dir commonm4 commandsm4 packageversionm4 packagemandatem4 src "|"

pandoc fromsrcmd towebmd

"--lua-filter tools/pandoc-demote-headers.lua"

">>" out

-- This rule, for updating the live hledger.org site, gets called by:

-- 1. github-post-receive (github webhook handler), when something is pushed

-- to the main repo on Github. Config:

-- /etc/supervisord.conf -> [program:github-post-receive]

-- /etc/github-post-receive.conf

-- 2. cron, nightly. Config: /etc/crontab

-- 3. manually (make site).

-- phony "hledgerorg" $ do

-- -- XXX ideally we would ensure here that output is logged in site.log,

-- -- but I don't know how to do that for the Shake rules.

-- -- Instead we'll do the logging in "make site".

-- cmd_ Shell

--

-- -- print timestamp. On mac, use brew-installed GNU date.

-- "PATH=\"/usr/local/opt/coreutils/libexec/gnubin:$PATH\" date --rfc-3339=seconds"

-- -- pull latest code and site repos - sometimes already done by webhook, not always

-- "&& printf 'code repo: ' && git pull"

-- "&& printf 'site repo: ' && git -C site pull"

--

-- -- Shake.hs might have been updated, but we won't execute the

-- -- new one, too insecure. Continue with this one.

--

-- Help:

-- ,"./Shake hledgerorg update the hledger.org website (when run on prod)"

-- HLEDGER PACKAGES/EXECUTABLES

-- build [PKGS]

-- Build some or all hledger packages, after generating any doc

-- files they embed or import.

-- This may also update .cabal files from package.yaml files, and/or install haskell deps.

phony "build" $ do

let

pkgs | null args = packages

| otherwise = args

sequence_ [ do

need $ fromMaybe [] $ lookup pkg embeddedFiles

cmd Shell "stack build " pkg :: Action ()

| pkg <- pkgs

]

-- Update each Hledger/Cli/Commands/*.md, replacing the flags block with latest --help output,

-- or a placeholder if there are no command-specific flags.

-- For hledger manual and also for cmddocs below.

phony "flagdocs" $ do

need commandmdsnew

when commit $ commitIfChanged ";doc: update command flag docs" commandmds

-- hledger/Hledger/Cli/Commands/CMD.md.new: a phony target that updates the flags doc

-- within hledger/Hledger/Cli/Commands/CMD.md. Runs "stack run -- hledger CMD -h" to get the latest.

-- If that fails, a warning is printed and it carries on, keeping the old flags doc.

phonys $ \out ->

if not $ "hledger/Hledger/Cli/Commands/" `isPrefixOf` out && ".md.new" `isSuffixOf` out

then Nothing

else Just $ do

let src = dropExtension out

need [src]

srcls <- fmap lines $ liftIO $ readFileStrictly src

let

(pre,rest) = break (=="```flags") srcls

(_,post) = span (/="```") rest

let cmdname = map toLower $ takeBaseName src

do

let shellcmd = "stack exec -- hledger -h " <> cmdname

liftIO $ putStrLn ("running " <> shellcmd <> " to update flags in " <> src)

cmdhelp <- lines . fromStdout <$> (cmd Shell shellcmd :: Action (Stdout String))

let

cmdflagshelp = takeWhile (not.null) $ dropWhile (/="Flags:") cmdhelp

cmdflagshelp'

| null cmdflagshelp = ["Flags:","no command-specific flags"]

| otherwise = cmdflagshelp

liftIO $ writeFile src $ unlines $ concat [pre, ["```flags"], cmdflagshelp', post]

-- This is supposed to print the error but otherwise ignore it, making this action a no-op,

-- in case hledger is not yet built/runnable.

`actionCatch` \(e::C.IOException) -> return ()

-- XXX should somehow control the output and elide the verbose "not found on path" errors

-- let elide err

-- | "path: [" `isInfixOf` err = takeWhile (/='[') err <> "..."

-- | otherwise = err

-- in \(e::C.IOException) -> liftIO $ hPutStrLn stderr $ elide $ show e -- not used

-- Regenerate Hledger/Cli/Commands/*.txt, rendering the corresponding .md files as plain text.

-- Also updates cmddocs first.

-- For commands' --help output.

phony "cmddocs" $ do

need commandtxts

when commit $ commitIfChanged ";doc: update help" commandtxts

commandtxts |%> \out -> do

let src = out -<.> "md"

liftIO $ putStrLn ("generating " <> out)

need [src <.> "new"] -- 1. update flags doc in src

need [src] -- 2. depend on src

cmd Shell

pandoc fromsrcmd src "--lua-filter" "tools/pandoc-dedent-code-blocks.lua" "-t plain" ">" out

-- CHANGELOGS

let

-- git log showing short commit hashes

gitlog = "git log --abbrev-commit"

-- git log formats suitable for changelogs/release notes

-- %s=subject, %an=author name, %n=newline if needed, %w=width/indent1/indent2, %b=body, %h=hash

changelogGitFormat = "--pretty=format:'- %s (%an)%n%w(0,2,2)%b\n'"

-- changelogVerboseGitFormat = "--pretty=format:'- %s (%an)%n%w(0,2,2)%b%h' --stat"

-- Format a git log message, with one of the formats above, as a changelog item

changelogCleanupCmd = unwords [

sed

,"-e 's/^( )*\\* /\1- /'" -- ensure bullet lists in descriptions use hyphens not stars

,"-e 's/ \\(Simon Michael\\)//'" -- strip maintainer's author name

,"-e 's/^- (doc: *)?(updated? *)?changelogs?( *updates?)?$//'" -- strip some variants of "updated changelog"

,"-e 's/^ \\[ci skip\\] *$//'" -- strip [ci skip] lines

,"-e 's/^ $//'" -- replace lines containing only spaces with empty lines

-- ,"-e 's/\r//'" -- strip windows carriage returns (XXX \r untested. IDEA doesn't like a real ^M here)

,"-e '/./,/^$/!d'" -- replace consecutive newlines with one

]

-- Things to exclude when doing git log for project-wide changelog.

-- git exclude pathspecs, https://git-scm.com/docs/gitglossary.html#gitglossary-aiddefpathspecapathspec

projectChangelogExcludeDirs = unwords [

":!hledger-lib"

,":!hledger"

,":!hledger-ui"

,":!hledger-web"

,":!tests"

]

-- update all changelogs with latest commits

phony "changelogs" $ do

need changelogs

when commit $ commitIfChanged ";doc: update changelogs" changelogs

-- [PKG/]CHANGES.md

-- Add any new non-boring commits to the specified changelog, in

-- an idempotent way, minimising manual toil, as follows. We look at:

--

-- - the changelog's topmost markdown heading, which can be a

-- dev heading (first word is a git revision like 4fffe6e7) or

-- a release heading (first word is a release version & tag

-- like 1.18.1, second word is a date like 2020-06-21) or a

-- package release heading (hledger-ui-1.18.1).

--

-- - the package version, in the adjacent .version file, which

-- can be a dev version like 1.18.99 (first two digits of last

-- part are 97, 98 or 99) or a release version like 1.18.1

-- (any other cabal-style version).

--

-- The old changelog heading is removed if it was a dev heading;

-- new commits in PKG not prefixed with semicolon are added;

-- and a suitable new heading is added: a release heading if

-- the package version looks like a release version, otherwise

-- a dev heading with the current HEAD revision.

--

-- With -n/--dry-run, print new content to stdout instead of

-- updating the changelog.

--

phonys (\out -> if out `notElem` changelogs

then Nothing

else Just $ do

tags <- lines . fromStdout <$> (cmd Shell "git tag" :: Action (Stdout String))

oldlines <- liftIO $ lines <$> readFileStrictly out

let

dir = takeDirectory out

mpkg | dir=="." = Nothing

| otherwise = Just dir

(preamble, oldheading:rest) = span isnotheading oldlines

where isnotheading = not . ("#" `isPrefixOf`)

-- changelog version: a hash or the last release version of this package (or the project)

changelogversion = headDef err $ drop 1 $ words oldheading

where err = error $ "could not parse changelog heading: " oldheading

-- prepend the package name if we are in a package (not the top-level project directory)

maybePrependPackage s = maybe s ( ("-" s)) mpkg

toTag = maybePrependPackage

isOldRelease rev = isReleaseVersion rev && toTag rev `elem` tags

isNewRelease rev = isReleaseVersion rev && toTag rev `notElem` tags

-- git revision corresponding to the changelog version:

-- a hash (a3f19c15), package release tag (hledger-ui-1.20), or project release tag (1.20)

lastrev

| isOldRelease changelogversion = toTag changelogversion -- package release tag

| isNewRelease changelogversion =

trace (out "'s version \"" changelogversion "\" is not yet tagged, can't list changes")

"HEAD"

| otherwise = changelogversion

-- interesting commit messages between lastrev and HEAD, cleaned up

let

interestingpaths = fromMaybe projectChangelogExcludeDirs mpkg

-- interestingmessages = "--invert-grep --grep '^;'" -- ignore commits beginning with ;

-- TODO: update for new commit conventions. ; now means skip CI,

-- feat:/imp:/fix: means release notes, pkg:/lib: means changelogs, etc.

interestingmessages = ""

newitems <- fromStdout <$>

(cmd Shell gitlog changelogGitFormat (lastrev "..") interestingmessages "--" interestingpaths

"|" changelogCleanupCmd :: Action (Stdout String))

-- git revision of current HEAD

headrev <- unwords . words . fromStdout <$>

(cmd Shell gitlog "-1 --pretty=%h -- " interestingpaths :: Action (Stdout String))

-- package version: the version number currently configured for this package (or the project)

packageversion <-

let versionfile = dir </> ".version"

err = error $ "could not parse a version in " versionfile

in liftIO $ headDef err . words <$> readFileStrictly versionfile

date <- liftIO getCurrentDay

let

-- the new changelog heading will be a final (dated, versioned) heading if

-- the configured package version is a new release version (non-dev & non-tagged)

(newrev, newheading)

| isNewRelease packageversion = (toTag packageversion, unwords [packageversion, show date])

| otherwise = (headrev, headrev)

newcontent = "# " newheading "\n" newitems

newchangelog =

unlines preamble

newcontent

(if isCommitHash changelogversion then "" else oldheading)

unlines rest

liftIO $ if

| lastrev == newrev -> pure () -- putStrLn $ out ": up to date"

| dryrun -> putStr $ out ":\n" newcontent

| otherwise -> do

writeFile out newchangelog

putStrLn $ out ": updated to " newrev

)

-- Update all program-specific docs, eg after setversion.

phony "docs" $ need [

"cmddocs"

,"manuals"

,"changelogs"

]

-- Update (render) the website, which should be checked out as ./site

phony "site" $ do

need [

"webmanuals"

,"orgfiles"

]

cmd_ "make -C site build"

phony "orgfiles" $

need [

-- "doc/BACKLOG.md"

]

-- These org files are converted to markdown for the website.

[ -- "doc/BACKLOG.md"

] |%> \out -> do

let src = out -<.> "org"

need [src]

-- replace the generated top heading with our own so we can insert the TOC after it

let heading = dropExtension out

mdlines <- drop 1 . lines . fromStdout <$> (cmd Shell pandoc fromorg towebmd src :: Action (Stdout String))

liftIO $ writeFile out $ unlines $ [

"<!-- " "Generated by \"Shake " out " from " src " -->"

,""

,"# " heading

,""

,"<div class=\"pagetoc\">"

,""

,"<!-- toc -->"

,"</div>"

,""

] mdlines

-- XXX try to style backlog items as unnumbered or nested-numbered list items

{-

<style>

main>ol {

list-style: none;

padding-inline-start: 1em;

counter-reset: item;

}

/* XXX when there are subitems, pandoc wraps all in a <p>,

* which forces a line break after the :before text

*/

main>ol>li:before {

content: counters(item, ".") ". ";

counter-increment: item;

}

*/

main>ol>li {

}

</style>

-}

-- MISC

-- Generate the web manuals based on the current checkout and save

-- them as the specified versioned snapshot in site/doc/VER/ .

-- .snapshot is a dummy file.

-- "site/doc/*/.snapshot" %> \out -> do

-- need webmanuals

-- let snapshot = takeDirectory out

-- cmd_ Shell "mkdir -p" snapshot

-- forM_ webmanuals $ \f -> -- site/hledger.md, site/journal.md

-- cmd_ Shell "cp" f (snapshot </> takeFileName f)

-- cmd_ Shell "cp -r site/images" snapshot

-- cmd_ Shell "touch" out

-- Help:

-- ,"./Shake site/doc/VERSION/.snapshot save current web manuals as this snapshot"

-- Cleanup.

phony "clean" $ do

putNormal "Cleaning object files in tools"

removeFilesAfter "tools" ["*.o","*.p_o","*.hi"]

phony "Clean" $ do

need ["clean"]

putNormal "Cleaning shake build cache"

removeFilesAfter ".shake" ["//*"]

-- Git commit the given files with the given message if they have changes,

-- otherwise print a no change message and continue.

commitIfChanged msg files = do

diffs <- (/=ExitSuccess) . fromExit <$> cmd Shell "git diff --no-ext-diff --quiet --exit-code --" files

if diffs

then cmd Shell ("git commit -m '" msg "' --") files

else liftIO $ putStrLn $ "nothing to commit (\"" msg "\")"

-- Convert numbered man page names to manual names.

-- hledger.1 -> hledger, hledger_journal.5 -> hledger_journal

manpageNameToManualName = dropNumericSuffix

where

dropNumericSuffix s = reverse $

case reverse s of

c : '.' : cs | isDigit c -> cs

cs -> cs

-- Convert manual names to numbered man page names.

-- hledger -> hledger.1, hledger_journal -> hledger_journal.5

manualNameToManpageName s

| '_' `elem` s = s <.> "5"

| otherwise = s <.> "1"

dropDirectory2 = dropDirectory1 . dropDirectory1

readFileStrictly :: FilePath -> IO String

readFileStrictly f = readFile f >>= \s -> C.evaluate (length s) >> return s

-- Write new content to a file, only if it's different.

maybeWriteFile :: FilePath -> String -> IO ()

maybeWriteFile f new = do

old <- readFileStrictly f

when (old /= new) $ writeFile f new

-- | Get the current local date.

getCurrentDay :: IO Day

getCurrentDay = localDay . zonedTimeToLocalTime <$> getZonedTime

-- | Replace each occurrence of a regular expression by this string.

replaceRe :: RE -> String -> String -> String

replaceRe re repl = replaceBy re (\_ _ _ -> Just repl)

-- | Replace each occurrence of a regular expression, by transforming

-- each matched text with the given function.

replaceBy :: RE -> (Match String -> RELocation -> Capture String -> Maybe String) -> String -> String

replaceBy re f src = replaceAllCaptures TOP f $ src *=~ re

-- | Does this string look like a valid cabal package version ?

isVersion s = not (null s) && all (`elem` "0123456789.") s && '.' `elem` s

-- | Does this string look like a hledger development version ?

-- Ie a version where the first two digits of the last part are the

-- special values 97, 98 or 99, indicating alpha/beta/rc or whatever.

isDevVersion s = isVersion s && lastpart >= "97"

where lastpart = lastDef "" $ splitOn "." s

-- | Does this string look like a hledger release version ?

-- Ie a cabal package version that's not a hledger development version.

isReleaseVersion s = isVersion s && not (isDevVersion s)

-- | Does this string look like a git commit hash ?

-- Ie a sequence of 7 or more numbers or letters.

isCommitHash s = length s > 6 && all isAlphaNum s

-- | Remove all trailing newlines/carriage returns.

chomp :: String -> String

chomp = reverse . dropWhile (`elem` "\r\n") . reverse