diff --git a/hledger-lib/Hledger/Utils/IO.hs b/hledger-lib/Hledger/Utils/IO.hs index 9f529f8d7..6a238ed32 100644 --- a/hledger-lib/Hledger/Utils/IO.hs +++ b/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' = - 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 +error' = errorWithoutStackTrace . ("Error: "<>) -- | 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: " - f = if useColorOnStderrUnsafe then ((<>sgrresetall).(fmt<>)) else id - where - fmt = sgrbrightyellow <> sgrbold + msg' = + (if useColorOnStderrUnsafe then modifyFirstLine ansiFormatWarning else id) $ + "Warning: "<> msg + +-- | 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 diff --git a/hledger-ui/Hledger/UI/Main.hs b/hledger-ui/Hledger/UI/Main.hs index 8d35126df..c7b803b64 100644 --- a/hledger-ui/Hledger/UI/Main.hs +++ b/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) diff --git a/hledger-web/Hledger/Web/Main.hs b/hledger-web/Hledger/Web/Main.hs index 0c75a3a10..da71f1923 100644 --- a/hledger-web/Hledger/Web/Main.hs +++ b/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) diff --git a/hledger/Hledger/Cli.hs b/hledger/Hledger/Cli.hs index 2bd98266f..aaf385747 100644 --- a/hledger/Hledger/Cli.hs +++ b/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. diff --git a/hledger/test/csv.test b/hledger/test/csv.test index 6b0780854..d571578f9 100644 --- a/hledger/test/csv.test +++ b/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 diff --git a/hledger/test/errors/accounts.test b/hledger/test/errors/accounts.test index 3d5b01598..37dcc9cc3 100644 --- a/hledger/test/errors/accounts.test +++ b/hledger/test/errors/accounts.test @@ -9,6 +9,5 @@ account "a" has not been declared. Consider adding an account directive. Examples: account a - / >>>= 1 diff --git a/hledger/test/errors/commodities.test b/hledger/test/errors/commodities.test index aa038c444..3924dfb51 100644 --- a/hledger/test/errors/commodities.test +++ b/hledger/test/errors/commodities.test @@ -10,6 +10,5 @@ Consider adding a commodity directive. Examples: commodity A1000.00 commodity 1.000,00 A - / >>>= 1 diff --git a/hledger/test/errors/csvbalanceparse.test b/hledger/test/errors/csvbalanceparse.test index e10d51118..34381f74b 100644 --- a/hledger/test/errors/csvbalanceparse.test +++ b/hledger/test/errors/csvbalanceparse.test @@ -10,7 +10,5 @@ the parse error is: 1:11: \| \^ unexpected end of input expecting '\+', '-', or number - - / >>>= 1 diff --git a/hledger/test/errors/csvbalancetypeparse.test b/hledger/test/errors/csvbalancetypeparse.test index 9647f92d3..48dd14ea6 100644 --- a/hledger/test/errors/csvbalancetypeparse.test +++ b/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 diff --git a/hledger/test/errors/csvdaterule.test b/hledger/test/errors/csvdaterule.test index 2419a021d..8156ade92 100644 --- a/hledger/test/errors/csvdaterule.test +++ b/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 diff --git a/hledger/test/errors/csvifblocknonempty.test b/hledger/test/errors/csvifblocknonempty.test index 9e6d16080..859063b96 100644 --- a/hledger/test/errors/csvifblocknonempty.test +++ b/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 diff --git a/hledger/test/errors/csviftablenonempty.test b/hledger/test/errors/csviftablenonempty.test index 611b283c5..b405c1e6d 100644 --- a/hledger/test/errors/csviftablenonempty.test +++ b/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 diff --git a/hledger/test/errors/csviftablevaluecount.test b/hledger/test/errors/csviftablevaluecount.test index ec890c172..de0bc6c6d 100644 --- a/hledger/test/errors/csviftablevaluecount.test +++ b/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 diff --git a/hledger/test/errors/csvstatusparse.test b/hledger/test/errors/csvstatusparse.test index 17022c5aa..5b1e9968c 100644 --- a/hledger/test/errors/csvstatusparse.test +++ b/hledger/test/errors/csvstatusparse.test @@ -6,7 +6,5 @@ the parse error is: 1:1: \| \^ unexpected 'b' expecting '!', '\*', or end of input - - / >>>= 1 diff --git a/hledger/test/errors/parseable-dates.test b/hledger/test/errors/parseable-dates.test index c76cb9119..17260314e 100644 --- a/hledger/test/errors/parseable-dates.test +++ b/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 diff --git a/hledger/test/errors/parseable-regexps.test b/hledger/test/errors/parseable-regexps.test index e1382d86b..f0835eea4 100644 --- a/hledger/test/errors/parseable-regexps.test +++ b/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 diff --git a/hledger/test/errors/parseable.test b/hledger/test/errors/parseable.test index 648860fd0..6ff30877f 100644 --- a/hledger/test/errors/parseable.test +++ b/hledger/test/errors/parseable.test @@ -5,6 +5,5 @@ $$$ hledger check -f parseable.j \| \^ unexpected newline expecting date separator or digit - / >>>= 1 diff --git a/hledger/test/errors/payees.test b/hledger/test/errors/payees.test index 5dc44aeed..4c0ef0d3f 100644 --- a/hledger/test/errors/payees.test +++ b/hledger/test/errors/payees.test @@ -9,6 +9,5 @@ payee "p" has not been declared. Consider adding a payee directive. Examples: payee p - / >>>= 1 diff --git a/hledger/test/journal/directive-account.test b/hledger/test/journal/directive-account.test index 43b40be8a..8d31bd356 100644 --- a/hledger/test/journal/directive-account.test +++ b/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 diff --git a/hledger/test/journal/parse-errors.test b/hledger/test/journal/parse-errors.test index f9eb88f3e..417079127 100644 --- a/hledger/test/journal/parse-errors.test +++ b/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 diff --git a/hledger/test/run.test b/hledger/test/run.test index 54f7384fb..0565cc87f 100644 --- a/hledger/test/run.test +++ b/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