imp: cli,ui,web: begin controlling GHC 9.10+'s stack traces

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 <simon@joyful.com>
 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

hledger-web/Hledger/Web/Main.hs

@@ -5,6 +5,7 @@ Copyright (c) 2007-2023 Simon Michael <simon@joyful.com> 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

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