diff --git a/hledger-ui/Hledger/UI/Main.hs b/hledger-ui/Hledger/UI/Main.hs index aec912c42..5434b4af6 100644 --- a/hledger-ui/Hledger/UI/Main.hs +++ b/hledger-ui/Hledger/UI/Main.hs @@ -3,6 +3,7 @@ hledger-ui - a hledger add-on providing an efficient TUI. Copyright (c) 2007-2015 Simon Michael Released under GPL version 3 or later. -} +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -13,6 +14,9 @@ module Hledger.UI.Main where import Control.Applicative ((<|>)) import Control.Concurrent (threadDelay) import Control.Concurrent.Async (withAsync) +#if MIN_VERSION_base(4,20,0) +import Control.Exception.Backtrace (setBacktraceMechanismState, BacktraceMechanism(..)) +#endif import Control.Monad (forM_, void, when) import Data.Bifunctor (first) import Data.Function ((&)) @@ -61,6 +65,14 @@ hledgerUiMain :: IO () hledgerUiMain = withGhcDebug' $ withProgName "hledger-ui.log" $ do -- force Hledger.Utils.Debug.* to log to hledger-ui.log when (ghcDebugMode == GDPauseAtStart) $ ghcDebugPause' +#if MIN_VERSION_base(4,20,0) + -- Control ghc 9.10+'s stack traces. + -- Strangely only hledger-ui has been showing them (when command line processing fails), + -- even though hledger and hledger-web process it in just the same way. + -- Disable them here. + setBacktraceMechanismState HasCallStackBacktrace False +#endif + traceLogAtIO 1 "\n\n\n\n==== hledger-ui start" dbg1IO "args" progArgs dbg1IO "debugLevel" debugLevel diff --git a/hledger-web/Hledger/Web/Main.hs b/hledger-web/Hledger/Web/Main.hs index bc887bce7..6aac7e1d1 100644 --- a/hledger-web/Hledger/Web/Main.hs +++ b/hledger-web/Hledger/Web/Main.hs @@ -5,6 +5,7 @@ Copyright (c) 2007-2023 Simon Michael and contributors. Released under GPL version 3 or later. -} +{-# LANGUAGE CPP #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -12,6 +13,9 @@ Released under GPL version 3 or later. module Hledger.Web.Main where import Control.Exception (bracket) +#if MIN_VERSION_base(4,20,0) +import Control.Exception.Backtrace (setBacktraceMechanismState, BacktraceMechanism(..)) +#endif import Control.Monad (when) import Data.String (fromString) import qualified Data.Text as T @@ -49,6 +53,12 @@ hledgerWebMain :: IO () hledgerWebMain = withGhcDebug' $ do when (ghcDebugMode == GDPauseAtStart) $ ghcDebugPause' +#if MIN_VERSION_base(4,20,0) + -- Control ghc 9.10+'s stack traces. + -- hledger-web isn't showing many yet; leave this enabled for now. + setBacktraceMechanismState HasCallStackBacktrace True +#endif + -- try to encourage user's $PAGER to properly display ANSI (in command line help) usecolor <- useColorOnStdout when usecolor setupPager diff --git a/hledger/Hledger/Cli.hs b/hledger/Hledger/Cli.hs index ee1a3a1b4..dc1b3a9b5 100644 --- a/hledger/Hledger/Cli.hs +++ b/hledger/Hledger/Cli.hs @@ -66,6 +66,7 @@ etc. {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Unused LANGUAGE pragma" #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} @@ -88,6 +89,9 @@ module Hledger.Cli ( ) where +#if MIN_VERSION_base(4,20,0) +import Control.Exception.Backtrace (setBacktraceMechanismState, BacktraceMechanism(..)) +#endif import Control.Monad (when, unless) import Data.Bifunctor (second) import Data.Char (isDigit) @@ -190,6 +194,16 @@ confflagsmode = defMode{ main :: IO () main = withGhcDebug' $ do +#if MIN_VERSION_base(4,20,0) + -- Control ghc 9.10+'s stack traces. + -- hledger isn't showing many yet; leave this enabled for now + setBacktraceMechanismState HasCallStackBacktrace True + -- CostCentreBacktrace - collect cost-centre stack backtraces (only available when built with profiling) + -- HasCallStackBacktrace - collect HasCallStack backtraces + -- ExecutionBacktrace - collect backtraces from native execution stack unwinding + -- IPEBacktrace - collect backtraces from Info Table Provenance Entries +#endif + -- 0. let's go! let