fix:cli,ui,web: consistent console error output independent of GHC version [#2367]

Hledger.Utils.IO helpers have been updated and new ones have been
added (exitOnExceptions, exitWithError) to allow consistent display of
program errors whether compiled with GHC <9.10, GHC 9.10, or GHC >9.10.
The trailing newlines added by GHC 9.10 are gone,
and so is the "uncaught exception" output added by GHC 9.12.

hledger-lib/Hledger/Utils/IO.hs

@@ -22,6 +22,10 @@ module Hledger.Utils.IO (
   error',
   usageError,
   warn,
+  ansiFormatError,
+  ansiFormatWarning,
+  exitOnExceptions,
+  exitWithError,
 
   -- * Time
   getCurrentLocalTime,
@@ -111,9 +115,9 @@ module Hledger.Utils.IO (
 where
 
 import           Control.Concurrent (forkIO)
-import           Control.Exception (catch, evaluate, throwIO)
+import           Control.Exception
 import           Control.Monad (when, forM, guard, void)
-import           Data.Char (toLower)
+import           Data.Char (toLower, isSpace)
 import           Data.Colour.RGBSpace (RGB(RGB))
 import           Data.Colour.RGBSpace.HSL (lightness)
 import           Data.Colour.SRGB (sRGB)
@@ -130,7 +134,7 @@ import qualified Data.Text.Lazy.Builder as TB
 import           Data.Time.Clock (getCurrentTime)
 import           Data.Time.LocalTime (LocalTime, ZonedTime, getCurrentTimeZone, utcToLocalTime, utcToZonedTime)
 import           Data.Word (Word16)
-import           Debug.Trace (trace)
+import           Debug.Trace
 import           Foreign.C.Error (Errno(..), ePIPE)
 import           GHC.IO.Exception (IOException(..), IOErrorType (ResourceVanished))
 import           Language.Haskell.TH.Syntax (Q, Exp)
@@ -138,11 +142,12 @@ import           Safe (headMay, maximumDef)
 import           System.Console.ANSI (Color(..),ColorIntensity(..), ConsoleLayer(..), SGR(..), hSupportsANSIColor, setSGRCode, getLayerColor, ConsoleIntensity (..))
 import           System.Console.Terminal.Size (Window (Window), size)
 import           System.Directory (getHomeDirectory, getModificationTime, findExecutable)
-import           System.Environment (getArgs, lookupEnv, setEnv)
+import           System.Environment (getArgs, lookupEnv, setEnv, getProgName)
+import           System.Exit (exitFailure)
 import           System.FilePath (isRelative, (</>))
 import "Glob"    System.FilePath.Glob (glob)
 import           System.Info (os)
-import           System.IO (Handle, IOMode (..), hGetEncoding, hSetEncoding, hSetNewlineMode, openFile, stdin, stdout, stderr, universalNewlineMode, utf8_bom, hIsTerminalDevice, hPutStr, hClose)
+import           System.IO (Handle, IOMode (..), hClose, hGetEncoding, hIsTerminalDevice, hPutStr, hPutStrLn, hSetNewlineMode, hSetEncoding, openFile, stderr, stdin, stdout, universalNewlineMode, utf8_bom)
 import qualified System.IO.Encoding as Enc
 import           System.IO.Unsafe (unsafePerformIO)
 import           System.Process (CreateProcess(..), StdStream(CreatePipe), createPipe, shell, waitForProcess, withCreateProcess)
@@ -196,38 +201,76 @@ pprint' = pPrintOpt NoCheckColorTty prettyoptsNoColor
 -- Errors
 
 -- | Call errorWithoutStackTrace, prepending a "Error:" label.
--- Also do some ANSI styling of the first line when allowed (using unsafe IO).
 error' :: String -> a
-error' =
+error' = errorWithoutStackTrace . ("Error: "<>)
-  if useColorOnStderrUnsafe
-  then  -- color the program name as well
-    unsafePerformIO $ do
-      putStr fmt
-      return $ errorWithoutStackTrace . modifyFirstLine ((<>sgrresetall) . (label<>))
-  else
-    errorWithoutStackTrace . modifyFirstLine (label<>)
-  where
-    label = "Error: "
-    fmt = sgrbrightred <> sgrbold
 
 -- | Like error', but add a hint about using -h.
 usageError :: String -> a
 usageError = error' . (++ " (use -h to see usage)")
 
+-- | Apply standard ANSI SGR formatting (red, bold) suitable for console error text.
+ansiFormatError :: String -> String
+ansiFormatError = (<> sgrresetall) . ((sgrbrightred <> sgrbold) <>)
+
 -- | Show a message, with "Warning:" label, on stderr before returning the given value.
--- Also do some ANSI styling of the first line when we detect that's supported (using unsafe IO).
+-- Also do some ANSI styling of the first line when allowed (using unsafe IO).
 -- Currently we use this very sparingly in hledger; we prefer to either quietly work,
 -- or loudly raise an error. (Varying output can make scripting harder.)
 warn :: String -> a -> a
-warn msg = trace (modifyFirstLine f (label <> msg))
+warn msg = trace msg'
   where
-    label = "Warning: "
+    msg' =
-    f = if useColorOnStderrUnsafe then ((<>sgrresetall).(fmt<>)) else id
+      (if useColorOnStderrUnsafe then modifyFirstLine ansiFormatWarning else id) $
-      where
+      "Warning: "<> msg
-        fmt = sgrbrightyellow <> sgrbold
+
+-- | Apply standard ANSI SGR formatting (yellow, bold) suitable for console warning text.
+ansiFormatWarning :: String -> String
+ansiFormatWarning = (<> sgrresetall) . ((sgrbrightyellow <> sgrbold) <>)
 
 -- Transform a string's first line.
-modifyFirstLine f s = unlines $ map f l <> ls where (l,ls) = splitAt 1 $ lines s  -- total
+-- Note, this won't add a trailing newline if there isn't one,
+-- and it will remove one if there is one or more.
+modifyFirstLine :: (String -> String) -> String -> String
+modifyFirstLine f s = intercalate "\n" $ map f l <> ls where (l,ls) = splitAt 1 $ lines s  -- total
+
+-- | This wraps a program's main routine, to handle program-terminating exceptions
+-- in a consistent compiler-independent way.
+-- In particular it catches @error'@/@error@/@errorWithoutStackTrace@ calls and IO errors,
+-- strips any outer whitespace from their output, and passes this to exitWithErrorMsg.
+-- This prevents GHC 9.10's trailing newlines and GHC 9.12's "uncaught exception" output,
+-- while exitWithErrorMsg ensures a consistent prefix, and styles the first line if allowed.
+--
+-- Some program-terminating exceptions this does not handle:
+-- ExitCode (triggered by a call to exitSuccess, exitFailure, or exitWith)
+-- and UserInterrupt (triggered by control-C).
+--
+exitOnExceptions :: IO () -> IO ()
+exitOnExceptions = flip catches
+  [Handler (\(e::ErrorCall) -> exitWithError $ rstrip $ show e)
+  ,Handler (\(e::IOError)   -> exitWithError $ rstrip $ show e)
+  -- ,Handler (\(x::ExitCode)  -> exitWith x)   -- falls through
+  -- ,Handler (\UserInterrupt  -> exitFailure)  -- falls through
+  ]
+  where
+    rstrip = reverse . dropWhile isSpace . reverse
+
+-- | Print an error message on stderr, with a standard program name prefix,
+-- and styling the first line with ansiFormatError if that's allowed;
+-- then exit the program with a non-zero exit code.
+exitWithError :: String -> IO ()
+exitWithError msg = do
+  progname <- getProgName
+  usecolor <- useColorOnStderr
+  let
+    style = if usecolor then modifyFirstLine ansiFormatError else id
+    prefix = progname <> ": "
+      -- error' prepends an "Error: " prefix. But that seems to have been removed when I catch the ErrorCall exception - unless I'm running in GHCI.
+      -- Is it possible something in GHC or base is removing it ?
+      -- Use a stupid heuristic for now: add it again unless already there.
+      <> (if "Error:" `isPrefixOf` msg then "" else "Error: ")
+  hPutStrLn stderr $ style $ prefix <> msg
+  exitFailure
+
 
 -- Time
 

hledger-ui/Hledger/UI/Main.hs

@@ -76,7 +76,7 @@ writeChan = BC.writeBChan
 
 
 hledgerUiMain :: IO ()
-hledgerUiMain = withGhcDebug' $ withProgName "hledger-ui.log" $ do  -- force Hledger.Utils.Debug.* to log to hledger-ui.log
+hledgerUiMain = exitOnExceptions $ 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)

hledger-web/Hledger/Web/Main.hs

@@ -62,7 +62,7 @@ hledgerWebDev =
 
 -- Run normally.
 hledgerWebMain :: IO ()
-hledgerWebMain = withGhcDebug' $ do
+hledgerWebMain = exitOnExceptions $ withGhcDebug' $ do
   when (ghcDebugMode == GDPauseAtStart) $ ghcDebugPause'
 
 #if MIN_VERSION_base(4,20,0)

hledger/Hledger/Cli.hs

@@ -200,7 +200,7 @@ confflagsmode = defMode{
 -- implementing that would simplify hledger's CLI processing a lot.
 --
 main :: IO ()
-main = withGhcDebug' $ do
+main = exitOnExceptions $ withGhcDebug' $ do
 
 #if MIN_VERSION_base(4,20,0)
   -- Control ghc 9.10+'s stack traces.

hledger/test/csv.test

@@ -779,7 +779,6 @@ $  ./csvtest.sh
 6 \| %amount 150\|acct2
   \| \^
 line of conditional table should have 2 values, but this one has only 1
-
 /
 >=1
 # XXX regex needed for error tests with ghc 9.10, https://gitlab.haskell.org/ghc/ghc/-/issues/25116
@@ -803,7 +802,6 @@ $  ./csvtest.sh
   \| \^
 start of conditional block found, but no assignment rules afterward
 \(assignment rules in a conditional block should be indented\)
-
 /
 >=1
 # XXX
@@ -830,7 +828,6 @@ $  ./csvtest.sh
   \|   \^\^\^\^\^\^\^\^\^\^\^\^
 unexpected "myaccount2 a"
 expecting conditional block
-
 /
 >=1
 # XXX
@@ -879,7 +876,6 @@ $  ./csvtest.sh
   \| \^
 start of conditional block found, but no assignment rules afterward
 \(assignment rules in a conditional block should be indented\)
-
 /
 >=1
 # XXX

hledger/test/errors/accounts.test

@@ -9,6 +9,5 @@ account "a" has not been declared.
 Consider adding an account directive. Examples:
 
 account a
-
 /
 >>>= 1

hledger/test/errors/commodities.test

@@ -10,6 +10,5 @@ Consider adding a commodity directive. Examples:
 
 commodity A1000.00
 commodity 1.000,00 A
-
 /
 >>>= 1

hledger/test/errors/csvbalanceparse.test

@@ -10,7 +10,5 @@ the parse error is:      1:11:
   \|           \^
 unexpected end of input
 expecting '\+', '-', or number
-
-
 /
 >>>= 1

hledger/test/errors/csvbalancetypeparse.test

@@ -3,7 +3,5 @@ $$$ hledger check -f  csvbalancetypeparse.csv
 CSV record: "2022-01-01","1"
 the balance rule is: %2
 the date rule is: %1
-
-
 /
 >>>= 1

hledger/test/errors/csvdaterule.test

@@ -1,6 +1,5 @@
 $$$ hledger check -f  csvdaterule.csv
 >>>2 /hledger: Error: offset=0:
 Please specify \(at top level\) the date field. Eg: date %1
-
 /
 >>>= 1

hledger/test/errors/csvifblocknonempty.test

@@ -5,6 +5,5 @@ $$$ hledger check -f  csvifblocknonempty.csv
   \| \^
 start of conditional block found, but no assignment rules afterward
 \(assignment rules in a conditional block should be indented\)
-
 /
 >>>= 1

hledger/test/errors/csviftablenonempty.test

@@ -4,6 +4,5 @@ $$$ hledger check -f  csviftablenonempty.csv
 2 \| if,date,description,comment
   \| \^
 start of conditional table found, but no assignment rules afterward
-
 /
 >>>= 1

hledger/test/errors/csviftablevaluecount.test

@@ -4,6 +4,5 @@ $$$ hledger check -f  csviftablevaluecount.csv
 4 \| one,val1
   \| \^
 line of conditional table should have 2 values, but this one has only 1
-
 /
 >>>= 1

hledger/test/errors/csvstatusparse.test

@@ -6,7 +6,5 @@ the parse error is:      1:1:
   \| \^
 unexpected 'b'
 expecting '!', '\*', or end of input
-
-
 /
 >>>= 1

hledger/test/errors/parseable-dates.test

@@ -5,6 +5,5 @@ $$$ hledger check -f parseable-dates.j
   \| \^\^\^\^\^\^\^\^\^
 
 This is not a valid date, please fix it.
-
 /
 >>>= 1

hledger/test/errors/parseable-regexps.test

@@ -6,6 +6,5 @@ $$$ hledger check -f parseable-regexps.j
 
 This regular expression is invalid or unsupported, please correct it:
 \(
-
 /
 >>>= 1

hledger/test/errors/parseable.test

@@ -5,6 +5,5 @@ $$$ hledger check -f parseable.j
   \|  \^
 unexpected newline
 expecting date separator or digit
-
 /
 >>>= 1

hledger/test/errors/payees.test

@@ -9,6 +9,5 @@ payee "p" has not been declared.
 Consider adding a payee directive. Examples:
 
 payee p
-
 /
 >>>= 1

hledger/test/journal/directive-account.test

@@ -79,7 +79,6 @@ $ hledger -f- accounts
   \|         \^
 unexpected '\('
 expecting account name without brackets
-
 /
 >=1
 # XXX regex needed for error tests with ghc 9.10, https://gitlab.haskell.org/ghc/ghc/-/issues/25116
@@ -95,7 +94,6 @@ $ hledger -f- accounts
   \|         \^
 unexpected '\['
 expecting account name without brackets
-
 /
 >=1
 # XXX regex needed for error tests with ghc 9.10, https://gitlab.haskell.org/ghc/ghc/-/issues/25116

hledger/test/journal/parse-errors.test

@@ -12,7 +12,6 @@ $ hledger -f - print
   \|     \^
 unexpected newline
 expecting date separator or digit
-
 /
 >=1
 # XXX regex needed for error tests with ghc 9.10, https://gitlab.haskell.org/ghc/ghc/-/issues/25116

hledger/test/run.test

@@ -6,7 +6,7 @@
    assets:cash  -$100
    expenses:food
 $ hledger run -f- aregister cash
->2 /hledger: aregister: openFile: does not exist \(No such file or directory\)/
+>2 /hledger: Error: aregister: openFile: does not exist \(No such file or directory\)/
 >=1
 
 # ** 2. Run refuses to read input file and commands from stdin