From d17b32c7eb81c3ea2e84bc9a8b59d65db4bc022e Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Thu, 25 Apr 2024 06:28:11 -1000 Subject: [PATCH] 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 | 59 +++++++++++++++++++++++++++ hledger-ui/Hledger/UI/Main.hs | 6 ++- hledger-ui/Hledger/UI/UIOptions.hs | 18 +++++++- hledger-ui/package.yaml | 13 +++++- hledger-web/Hledger/Web/Main.hs | 6 ++- hledger-web/Hledger/Web/WebOptions.hs | 19 +++++++-- hledger-web/package.yaml | 15 +++++-- hledger/Hledger/Cli.hs | 45 ++++++-------------- hledger/Hledger/Cli/CliOptions.hs | 21 ++++++++++ hledger/Hledger/Cli/Commands.hs | 1 - hledger/Hledger/Cli/Version.hs | 33 +++++++-------- hledger/package.yaml | 14 +++++-- stack.yaml | 3 ++ 13 files changed, 187 insertions(+), 66 deletions(-) diff --git a/hledger-lib/Hledger/Utils/Debug.hs b/hledger-lib/Hledger/Utils/Debug.hs index 44fe545a3..59f380a26 100644 --- 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 diff --git a/hledger-ui/Hledger/UI/Main.hs b/hledger-ui/Hledger/UI/Main.hs index 628815cc6..6ae0edb01 100644 --- 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 diff --git a/hledger-ui/Hledger/UI/UIOptions.hs b/hledger-ui/Hledger/UI/UIOptions.hs index f6b80cb33..d2b6183df 100644 --- 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" diff --git a/hledger-ui/package.yaml b/hledger-ui/package.yaml index 728ff19d7..2c3d1b574 100644 --- 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 diff --git a/hledger-web/Hledger/Web/Main.hs b/hledger-web/Hledger/Web/Main.hs index 2dcdc69d0..9f8df2548 100644 --- 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 diff --git a/hledger-web/Hledger/Web/WebOptions.hs b/hledger-web/Hledger/Web/WebOptions.hs index e0527b295..21b683f88 100644 --- 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 = diff --git a/hledger-web/package.yaml b/hledger-web/package.yaml index e9d1f64de..cd8be25b6 100644 --- 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 diff --git a/hledger/Hledger/Cli.hs b/hledger/Hledger/Cli.hs index b94aa8b6f..e46160579 100644 --- 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 diff --git a/hledger/Hledger/Cli/CliOptions.hs b/hledger/Hledger/Cli/CliOptions.hs index a401853ac..4c54cfb39 100644 --- 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 diff --git a/hledger/Hledger/Cli/Commands.hs b/hledger/Hledger/Cli/Commands.hs index 53a3ad5c7..e16207b7b 100644 --- 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 diff --git a/hledger/Hledger/Cli/Version.hs b/hledger/Hledger/Cli/Version.hs index a0f1143b8..8e0ef190d 100644 --- 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,"") diff --git a/hledger/package.yaml b/hledger/package.yaml index 71f825bfe..17385b80c 100644 --- 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" diff --git a/stack.yaml b/stack.yaml index 543e330fa..5fe32b31e 100644 --- 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]