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.
2024-09-16 16:57:38 +03:00 · 2024-04-25 06:28:11 -10:00 · 2024-04-25 06:28:11 -10:00 · d17b32c7eb
commit d17b32c7eb
parent e1bcbc3238
13 changed files with 187 additions and 66 deletions
--- a/hledger-lib/Hledger/Utils/Debug.hs
+++ b/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
--- a/hledger-ui/Hledger/UI/Main.hs
+++ b/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
--- a/hledger-ui/Hledger/UI/UIOptions.hs
+++ b/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
-prognameandversion = versionString progname packageversion
+-- | 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
+

 uiflags = [
  -- flagNone ["debug-ui"] (setboolopt "rules-file") "run with no terminal output, showing console"
--- a/hledger-ui/package.yaml
+++ b/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
--- a/hledger-web/Hledger/Web/Main.hs
+++ b/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
--- a/hledger-web/Hledger/Web/WebOptions.hs
+++ b/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
-prognameandversion = versionString progname packageversion
-
+-- | 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

 webflags :: [Flag RawOpts]
 webflags =
--- a/hledger-web/package.yaml
+++ b/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
--- a/hledger/Hledger/Cli.hs
+++ b/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
--- a/hledger/Hledger/Cli/CliOptions.hs
+++ b/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

--- a/hledger/Hledger/Cli/Commands.hs
+++ b/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
--- a/hledger/Hledger/Cli/Version.hs
+++ b/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
-versionStringWith egitinfo prognam packagever =
-  concat [ prognam , " " , version , ", " , os' , "-" , arch ]
+-- The GitInfo if any, fetched by template haskell, is passed down from
+-- a top-level module, reducing wasteful recompilation.
+-- 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,"")
--- a/hledger/package.yaml
+++ b/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.
-    manual: false
+    description: On POSIX systems, build with the terminfo lib for detecting terminal width
    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"
--- a/stack.yaml
+++ b/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]