imp: cli,ui,web: support ghc-debug for analysing memory/profile info

When built with the ghcdebug flag and started with --debug=-1 (or -2
to pause at startup, or -3 to pause before exit), hledger can be
controlled by ghc-debug clients like ghc-debug-brick or a custom
ghc-debug query script.

Also, refactor version string code.

hledger-lib/Hledger/Utils/Debug.hs

@@ -92,6 +92,8 @@ val
 -- http://hackage.haskell.org/packages/archive/htrace/0.1/doc/html/Debug-HTrace.html
 -- http://hackage.haskell.org/packages/archive/traced/2009.7.20/doc/html/Debug-Traced.html
 -- https://hackage.haskell.org/package/debug
+
+{-# LANGUAGE CPP #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 
 module Hledger.Utils.Debug (
@@ -161,7 +163,12 @@ module Hledger.Utils.Debug (
   ,dbg9With
 
   -- * Utilities
+  ,GhcDebugMode(..)
+  ,ghcDebugMode
+  ,withGhcDebug'
+  ,ghcDebugPause'
   ,lbl_
+  ,progName
 
   -- * Re-exports
   -- ,module Debug.Breakpoint
@@ -176,6 +183,9 @@ import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.List hiding (uncons)
 -- import Debug.Breakpoint
 import Debug.Trace (trace, traceIO, traceShowId)
+#ifdef GHCDEBUG
+import GHC.Debug.Stub (pause, withGhcDebug)
+#endif
 import Safe (readDef)
 import System.Environment (getProgName)
 import System.Exit (exitFailure)
@@ -212,6 +222,55 @@ debugLevel = case dropWhile (/="--debug") progArgs of
                    ['-':'-':'d':'e':'b':'u':'g':'=':v] -> readDef 1 v
                    _                                   -> 0
 
+-- | Whether ghc-debug support is included in this build, and if so, how it will behave.
+-- When hledger is built with the ghcdebug cabal build flag (normally disabled),
+-- it can listen (on unix ?) for connections from ghc-debug clients like ghc-debug-brick,
+-- for pausing/resuming the program and inspecting memory usage and profile information.
+--
+-- This is enabled by running hledger with a negative --debug level, with three different modes:
+-- --debug=-1 - run normally (can be paused/resumed by a ghc-debug client),
+-- --debug=-2 - pause and await client commands at program start (not useful currently),
+-- --debug=-3 - pause and await client commands at program end.
+data GhcDebugMode =
+    GDNotSupported
+  | GDDisabled
+  | GDNoPause
+  | GDPauseAtStart
+  | GDPauseAtEnd
+  -- keep synced with ghcDebugMode
+  deriving (Eq,Ord)
+
+-- | Should the program open a socket allowing control by ghc-debug-brick or similar ghc-debug client ?
+-- See GhcDebugMode.
+ghcDebugMode :: GhcDebugMode
+ghcDebugMode =
+  case debugLevel of
+    -- keep synced with GhcDebugMode
+#ifdef GHCDEBUG
+    (-1) -> GDNoPause
+    (-2) -> GDPauseAtStart
+    (-3) -> GDPauseAtEnd
+#endif
+    _    -> GDDisabled
+
+-- | When ghc-debug support has been built into the program and enabled at runtime with --debug=-N,
+-- this calls ghc-debug's withGhcDebug; otherwise it's a no-op.
+withGhcDebug' =
+#ifdef GHCDEBUG
+  if ghcDebugMode > GDDisabled then withGhcDebug else id
+#else
+  id
+#endif
+
+-- | When ghc-debug support has been built into the program, this calls ghc-debug's pause, otherwise it's a no-op.
+ghcDebugPause' :: IO ()
+ghcDebugPause' =
+#ifdef GHCDEBUG
+  pause
+#else
+  return ()
+#endif
+
 -- | Trace a value with the given show function before returning it.
 traceWith :: (a -> String) -> a -> a
 traceWith f a = trace (f a) a

hledger-ui/Hledger/UI/Main.hs

@@ -58,7 +58,9 @@ writeChan = BC.writeBChan
 
 
 hledgerUiMain :: IO ()
-hledgerUiMain = withProgName "hledger-ui.log" $ do  -- force Hledger.Utils.Debug.* to log to hledger-ui.log
+hledgerUiMain = withGhcDebug' $ withProgName "hledger-ui.log" $ do  -- force Hledger.Utils.Debug.* to log to hledger-ui.log
+  when (ghcDebugMode == GDPauseAtStart) $ ghcDebugPause'
+
   traceLogAtIO 1 "\n\n\n\n==== hledger-ui start"
   dbg1IO "args" progArgs
   dbg1IO "debugLevel" debugLevel
@@ -80,6 +82,8 @@ hledgerUiMain = withProgName "hledger-ui.log" $ do  -- force Hledger.Utils.Debug
     -- _ | boolopt "binary-filename" rawopts -> putStrLn (binaryfilename progname)
     _                                         -> withJournalDo copts' (runBrickUi opts)
 
+  when (ghcDebugMode == GDPauseAtEnd) $ ghcDebugPause'
+
 runBrickUi :: UIOpts -> Journal -> IO ()
 runBrickUi uopts0@UIOpts{uoCliOpts=copts@CliOpts{inputopts_=_iopts,reportspec_=rspec@ReportSpec{_rsReportOpts=ropts}}} j =
   do

hledger-ui/Hledger/UI/UIOptions.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-|
 
 -}
@@ -10,6 +11,7 @@ import Data.Default (def)
 import Data.List (intercalate)
 import qualified Data.Map as M
 import Data.Maybe (fromMaybe)
+import GitHash (tGitInfoCwdTry)
 import Lens.Micro (set)
 import System.Environment (getArgs)
 
@@ -29,8 +31,20 @@ packageversion =
 progname :: ProgramName
 progname = "hledger-ui"
 
-prognameandversion :: VersionString
+-- | Generate the version string for this program.
-prognameandversion = versionString progname packageversion
+-- The template haskell call is here rather than in Hledger.Cli.Version to avoid wasteful recompilation.
+prognameandversion :: String
+prognameandversion =
+  versionStringWith
+  $$tGitInfoCwdTry
+#ifdef GHCDEBUG
+  True
+#else
+  False
+#endif
+  progname
+  packageversion
+
 
 uiflags = [
   -- flagNone ["debug-ui"] (setboolopt "rules-file") "run with no terminal output, showing console"

hledger-ui/package.yaml

@@ -35,8 +35,12 @@ extra-source-files:
 flags:
   threaded:
     description: Build with support for multithreaded execution
-    manual: false
     default: true
+    manual:  false
+  ghcdebug:
+    description: Build with support for attaching a ghc-debug client
+    default: false
+    manual:  true
 
 cpp-options: -DVERSION="1.33.99"
 
@@ -51,6 +55,12 @@ ghc-options:
 dependencies:
 - base >=4.14 && <4.20
 
+when:
+- condition: (flag(ghcdebug))
+  cpp-options: -DGHCDEBUG
+  dependencies:
+  - ghc-debug-stub >=0.6.0.0 && <0.7
+
  # curses is required to build terminfo for vty for hledger-ui.
  # On POSIX systems it might be not present.
  # On windows it's very likely not present, but possibly it could be.
@@ -86,6 +96,7 @@ library:
   - extra >=1.6.3
   - filepath
   - fsnotify >=0.4 && <0.5
+  - githash >=0.1.6.2
   - microlens >=0.4
   - microlens-platform >=0.2.3.1
   - megaparsec >=7.0.0 && <9.7

hledger-web/Hledger/Web/Main.hs

@@ -46,7 +46,9 @@ hledgerWebDev =
 
 -- Run normally.
 hledgerWebMain :: IO ()
-hledgerWebMain = do
+hledgerWebMain = withGhcDebug' $ do
+  when (ghcDebugMode == GDPauseAtStart) $ ghcDebugPause'
+
   -- try to encourage user's $PAGER to properly display ANSI (in command line help)
   when useColorOnStdout setupPager
 
@@ -63,6 +65,8 @@ hledgerWebMain = do
       (`withArgs` hledgerWebTest) . filter (`notElem` ["--test","--"]) =<< getArgs
     | otherwise                              -> withJournalDo copts (web wopts)
 
+  when (ghcDebugMode == GDPauseAtEnd) $ ghcDebugPause'
+
 -- | The hledger web command.
 web :: WebOpts -> Journal -> IO ()
 web opts j = do

hledger-web/Hledger/Web/WebOptions.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Hledger.Web.WebOptions where
 
@@ -9,6 +10,7 @@ import Data.ByteString.UTF8 (fromString)
 import Data.Default (Default(def))
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
+import GitHash (tGitInfoCwdTry)
 import System.Environment (getArgs)
 import Network.Wai as WAI
 import Network.Wai.Middleware.Cors
@@ -29,12 +31,23 @@ packageversion =
   ""
 #endif
 
+-- | The name of this program's executable.
 progname :: ProgramName
 progname = "hledger-web"
 
-prognameandversion :: VersionString
+-- | Generate the version string for this program.
-prognameandversion = versionString progname packageversion
+-- The template haskell call is here rather than in Hledger.Cli.Version to avoid wasteful recompilation.
-
+prognameandversion :: String
+prognameandversion =
+  versionStringWith
+  $$tGitInfoCwdTry
+#ifdef GHCDEBUG
+  True
+#else
+  False
+#endif
+  progname
+  packageversion
 
 webflags :: [Flag RawOpts]
 webflags =

hledger-web/package.yaml

@@ -49,16 +49,20 @@ extra-source-files:
 flags:
   library-only:
     description: Build for use with "yesod devel"
-    manual: false
     default: false
+    manual:  false
   dev:
     description: Turn on development settings, like auto-reload templates.
-    manual: false
     default: false
+    manual:  false
   threaded:
     description: Build with support for multithreaded execution.
-    manual: false
     default: true
+    manual:  false
+  ghcdebug:
+    description: Build with support for attaching a ghc-debug client
+    default: false
+    manual:  true
 
 ghc-options:
 - -Wall
@@ -76,6 +80,10 @@ when:
 # 'ghc-options: -O0' is not needed. Use the --disable-optimization configure flag.
 - condition: flag(dev)
   ghc-options: -O0
+- condition: (flag(ghcdebug))
+  cpp-options: -DGHCDEBUG
+  dependencies:
+  - ghc-debug-stub >=0.6.0.0 && <0.7
 
 dependencies:
 - base >=4.14 && <4.20
@@ -109,6 +117,7 @@ library:
   - directory >=1.2.3.0
   - extra >=1.6.3
   - filepath
+  - githash >=0.1.6.2
   - hjsmin
   - http-conduit
   - http-client

hledger/Hledger/Cli.hs

@@ -1,8 +1,3 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-{-# HLINT ignore "Unused LANGUAGE pragma" #-}
-
 {-|
 
 This is the root module of the @hledger@ package,
@@ -69,9 +64,12 @@ etc.
 
 -}
 
+{-# LANGUAGE LambdaCase #-}
+
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Unused LANGUAGE pragma" #-}
+
 module Hledger.Cli (
-  prognameandversion,
-  versionString,
   main,
   mainmode,
   argsToCliOpts,
@@ -90,7 +88,9 @@ where
 import Control.Monad (when)
 import Data.List
 import qualified Data.List.NonEmpty as NE
+import Data.Time.Clock.POSIX (getPOSIXTime)
 import Safe
+import System.Console.CmdArgs.Explicit hiding (Name) -- don't clash with hledger-ui
 import qualified System.Console.CmdArgs.Explicit as C
 import System.Environment
 import System.Exit
@@ -98,12 +98,6 @@ import System.FilePath
 import System.Process
 import Text.Printf
 
-import Data.Time.Clock.POSIX (getPOSIXTime)
-
-
-import GitHash (tGitInfoCwdTry)
-import System.Console.CmdArgs.Explicit hiding (Name) -- don't clash with hledger-ui
-
 import Hledger
 import Hledger.Cli.CliOptions
 import Hledger.Cli.Commands
@@ -112,24 +106,6 @@ import Hledger.Cli.Utils
 import Hledger.Cli.Version
 
 
--- | The program name and version string for this build of the hledger tool,
--- including any git info available at build time.
-prognameandversion :: String
-prognameandversion = versionString progname packageversion
-
--- | A helper to generate the best version string we can from the given 
--- program name and package version strings, current os and architecture,
--- and any git info available at build time (commit hash, commit date, branch
--- name, patchlevel since latest release tag for that program's package).
--- Typically called for programs "hledger", "hledger-ui", or "hledger-web".
---
--- The git info changes whenever any file in the repository changes. 
--- Keeping this template haskell call here and not down in Hledger.Cli.Version
--- helps reduce the number of modules recompiled.
-versionString :: ProgramName -> PackageVersion -> String
-versionString = versionStringWith $$tGitInfoCwdTry
-
-
 -- | The overall cmdargs mode describing hledger's command-line options and subcommands.
 mainmode addons = defMode {
   modeNames = [progname ++ " [CMD]"]
@@ -172,8 +148,11 @@ mainmode addons = defMode {
 
 -- | Let's go!
 main :: IO ()
-main = do
+main = withGhcDebug' $ do
+  when (ghcDebugMode == GDPauseAtStart) $ ghcDebugPause'
+
   starttime <- getPOSIXTime
+
   -- try to encourage user's $PAGER to properly display ANSI
   when useColorOnStdout setupPager
 
@@ -286,6 +265,8 @@ main = do
 
   runHledgerCommand
 
+  when (ghcDebugMode == GDPauseAtEnd) $ ghcDebugPause'
+
 -- | Parse hledger CLI options from these command line arguments and
 -- add-on command names, or raise any error.
 argsToCliOpts :: [String] -> [String] -> IO CliOpts

hledger/Hledger/Cli/CliOptions.hs

@@ -15,6 +15,8 @@ related utilities used by hledger commands.
 {-# LANGUAGE TypeOperators       #-}
 
 module Hledger.Cli.CliOptions (
+  progname,
+  prognameandversion,
 
   -- * cmdargs flags & modes
   helpflags,
@@ -87,6 +89,7 @@ import Data.Maybe
 -- import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Void (Void)
+import GitHash (tGitInfoCwdTry)
 import Safe
 import String.ANSI
 import System.Console.CmdArgs hiding (Default,def)
@@ -110,6 +113,24 @@ import Data.Time.Clock.POSIX (POSIXTime)
 import Data.List (isPrefixOf, isSuffixOf)
 
 
+-- | The name of this program's executable.
+progname :: ProgramName
+progname = "hledger"
+
+-- | Generate the version string for this program.
+-- The template haskell call is here rather than in Hledger.Cli.Version to avoid wasteful recompilation.
+prognameandversion :: String
+prognameandversion =
+  versionStringWith
+  $$tGitInfoCwdTry
+#ifdef GHCDEBUG
+  True
+#else
+  False
+#endif
+  progname
+  packageversion
+
 -- common cmdargs flags
 -- keep synced with flag docs in doc/common.m4
 

hledger/Hledger/Cli/Commands.hs

@@ -65,7 +65,6 @@ import Test.Tasty (defaultMain)
 
 import Hledger
 import Hledger.Cli.CliOptions
-import Hledger.Cli.Version
 import Hledger.Cli.Commands.Accounts
 import Hledger.Cli.Commands.Activity
 import Hledger.Cli.Commands.Add

hledger/Hledger/Cli/Version.hs

@@ -9,7 +9,6 @@ module Hledger.Cli.Version (
   VersionString,
   packageversion,
   packagemajorversion,
-  progname,
   versionStringWith,
 )
 where
@@ -39,10 +38,6 @@ packageversion =
 packagemajorversion :: PackageVersion
 packagemajorversion = intercalate "." $ take 2 $ splitAtElement '.' packageversion
 
--- | The name of this package's main executable.
-progname :: ProgramName
-progname = "hledger"
-
 -- | Given possible git state info from the build directory (or an error message, which is ignored),
 -- the name of a program (executable) in the currently building package,
 -- and the package's version, make a complete version string. Here is the logic:
@@ -55,6 +50,7 @@ progname = "hledger"
 -- * (TODO, requires adding --match support to githash:
 --   If there are tags matching THISPKG-[0-9]*, the latest one is used to calculate patch level
 --   (number of commits since tag), and if non-zero, it and the branch name are shown.)
+-- * If the ghcdebug build flag was enabled, "ghc-debug support" is shown.
 --
 -- Some example outputs:
 --
@@ -65,9 +61,19 @@ progname = "hledger"
 -- This function requires git log to show the default (rfc2822-style) date format,
 -- so that must not be overridden by a log.date git config variable.
 --
-versionStringWith :: Either String GitInfo -> ProgramName -> PackageVersion -> VersionString
+-- The GitInfo if any, fetched by template haskell, is passed down from
-versionStringWith egitinfo prognam packagever =
+-- a top-level module, reducing wasteful recompilation.
-  concat [ prognam , " " , version , ", " , os' , "-" , arch ]
+-- The status of the ghcdebug build flag is also passed down, since it is
+-- specific to each hledger package.
+--
+-- This is used indirectly by at least hledger, hledger-ui, and hledger-web,
+-- so output should be suitable for all of those.
+--
+versionStringWith :: Either String GitInfo -> Bool -> ProgramName -> PackageVersion -> VersionString
+versionStringWith egitinfo ghcdebug progname packagever =
+  concat $
+    [ progname , " " , version , ", " , os' , "-" , arch ]
+    ++ [ " with ghc-debug support" | ghcdebug ]
   where
     os' | os == "darwin"  = "mac"
         | os == "mingw32" = "windows"
@@ -102,14 +108,3 @@ versionStringWith egitinfo prognam packagever =
                     dd = (if length day < 2 then ('0':) else id) day
           -- but could be overridden by a log.date config variable in repo or user git config
           _ -> packageversion
-
--- -- | Given a program name, return a precise platform-specific executable
--- -- name suitable for naming downloadable binaries.  Can raise an error if
--- -- the version and patch level was not defined correctly at build time.
--- binaryfilename :: String -> String
--- binaryfilename progname = concat
---     [progname, "-", buildversion, "-", os', "-", arch, suffix]
---   where
---     (os',suffix) | os == "darwin"  = ("mac","" :: String)
---                  | os == "mingw32" = ("windows",".exe")
---                  | otherwise       = (os,"")

hledger/package.yaml

@@ -80,13 +80,17 @@ extra-source-files:
 
 flags:
   terminfo:
-    description: On POSIX systems, build with the terminfo lib for detecting terminal width.
+    description: On POSIX systems, build with the terminfo lib for detecting terminal width
-    manual: false
     default: true
+    manual:  false
   threaded:
     description: Build with support for multithreaded execution
-    manual: false
     default: true
+    manual:  false
+  ghcdebug:
+    description: Build with support for attaching a ghc-debug client
+    default: false
+    manual:  true
 
 ghc-options:
 - -Wall
@@ -139,6 +143,10 @@ when:
 - condition: (!(os(windows))) && (flag(terminfo))
   dependencies:
   - terminfo
+- condition: (flag(ghcdebug))
+  cpp-options: -DGHCDEBUG
+  dependencies:
+  - ghc-debug-stub >=0.6.0.0 && <0.7
 
 library:
   cpp-options: -DVERSION="1.33.99"

stack.yaml

@@ -12,6 +12,9 @@ extra-deps:
 - process-1.6.19.0          # for HSEC-2024-0003
 - haskeline-0.8.2.1
 
+- ghc-debug-convention-0.6.0.0
+- ghc-debug-stub-0.6.0.0
+
 nix:
   pure: false
   packages: [perl gmp ncurses zlib]