diff --git a/hledger-lib/Hledger/Utils/Debug.hs b/hledger-lib/Hledger/Utils/Debug.hs index ee666df2c..44da1864e 100644 --- a/hledger-lib/Hledger/Utils/Debug.hs +++ b/hledger-lib/Hledger/Utils/Debug.hs @@ -142,11 +142,27 @@ import Data.List hiding (uncons) import Debug.Breakpoint import Debug.Trace (trace, traceIO, traceShowId) import Safe (readDef) -import System.Environment (getArgs, getProgName) +import System.Environment (getProgName) import System.Exit (exitFailure) import System.IO.Unsafe (unsafePerformIO) -import Hledger.Utils.Print (pshow, pshow') +import Hledger.Utils.Print (progArgs, pshow, pshow') + +-- | The program name as returned by @getProgName@. +-- It's best to set this explicitly at program startup with @withProgName@, +-- otherwise when running in GHCI (eg) it will change to "". +-- Setting it with a ",logging" suffix causes some functions below +-- to log instead of trace. +{-# NOINLINE modifiedProgName #-} +modifiedProgName :: String +modifiedProgName = unsafePerformIO getProgName + +-- | The progam name, with any ",logging" suffix removed. +progName :: String +progName = + if ",logging" `isSuffixOf` modifiedProgName + then reverse $ drop 8 $ reverse modifiedProgName + else modifiedProgName -- | Global debug output level. This is the requested verbosity of -- debug output printed to stderr. The default is 0 meaning no debug output. @@ -158,15 +174,13 @@ import Hledger.Utils.Print (pshow, pshow') -- {-# OPTIONS_GHC -fno-cse #-} {-# NOINLINE debugLevel #-} debugLevel :: Int -debugLevel = case dropWhile (/="--debug") args of +debugLevel = case dropWhile (/="--debug") progArgs of ["--debug"] -> 1 "--debug":n:_ -> readDef 1 n _ -> - case take 1 $ filter ("--debug" `isPrefixOf`) args of + case take 1 $ filter ("--debug" `isPrefixOf`) progArgs of ['-':'-':'d':'e':'b':'u':'g':'=':v] -> readDef 1 v _ -> 0 - where - args = unsafePerformIO getArgs -- | Trace a value with the given show function before returning it. traceWith :: (a -> String) -> a -> a @@ -217,25 +231,11 @@ ptraceAtIO level label a = then return () else liftIO $ traceIO (labelledPretty True label a) --- | The program name, possibly ending with ",logging". --- This should be set at program startup with @withProgName@, --- otherwise it will vary, eg "" in GHCI. -{-# NOINLINE modifiedProgName #-} -modifiedProgName :: String -modifiedProgName = unsafePerformIO getProgName - -- | Should the "trace or log" functions output to a file instead of stderr ? -- True if the program name ends with ",logging". shouldLog :: Bool shouldLog = ",logging" `isSuffixOf` modifiedProgName --- | The progam name, with any ",logging" suffix removed. -progName :: String -progName = - if ",logging" `isSuffixOf` modifiedProgName - then reverse $ drop 8 $ reverse modifiedProgName - else modifiedProgName - -- | The debug log file: PROGNAME.log in the current directory. -- See modifiedProgName. debugLogFile :: FilePath diff --git a/hledger-lib/Hledger/Utils/Print.hs b/hledger-lib/Hledger/Utils/Print.hs index 28b827f31..0301daa97 100644 --- a/hledger-lib/Hledger/Utils/Print.hs +++ b/hledger-lib/Hledger/Utils/Print.hs @@ -17,6 +17,8 @@ module Hledger.Utils.Print ( -- * Pretty printing to stdout ,pprint ,pprint' + -- * Command line arguments + ,progArgs -- * Detecting --color/--colour/NO_COLOR ,colorOption ,useColorOnStdout @@ -68,6 +70,36 @@ pprint' = pPrintOpt CheckColorTty prettyopts' -- Avoid using pshow, pprint, dbg* in the code below to prevent infinite loops. +-- | The command line arguments that were used at program startup. +-- Uses unsafePerformIO. +{-# NOINLINE progArgs #-} +progArgs :: [String] +progArgs = unsafePerformIO getArgs + +-- | Read the value of the --color or --colour command line option provided at program startup +-- using unsafePerformIO. If this option was not provided, returns the empty string. +colorOption :: String +colorOption = + -- similar to debugLevel + -- keep synced with color/colour flag definition in hledger:CliOptions + let args = progArgs in + case dropWhile (/="--color") args of + -- --color ARG + "--color":v:_ -> v + _ -> + case take 1 $ filter ("--color=" `isPrefixOf`) args of + -- --color=ARG + ['-':'-':'c':'o':'l':'o':'r':'=':v] -> v + _ -> + case dropWhile (/="--colour") args of + -- --colour ARG + "--colour":v:_ -> v + _ -> + case take 1 $ filter ("--colour=" `isPrefixOf`) args of + -- --colour=ARG + ['-':'-':'c':'o':'l':'o':'u':'r':'=':v] -> v + _ -> "" + -- | Check the IO environment to see if ANSI colour codes should be used on stdout. -- This is done using unsafePerformIO so it can be used anywhere, eg in -- low-level debug utilities, which should be ok since we are just reading. @@ -102,40 +134,12 @@ useColorOnHandle h = unsafePerformIO $ do return $ coloroption `elem` ["always","yes"] || (coloroption `notElem` ["never","no"] && not no_color && supports_color) --- | Read the value of the --color or --colour command line option provided at program startup --- using unsafePerformIO. If this option was not provided, returns the empty string. --- {-# OPTIONS_GHC -fno-cse #-} --- {-# NOINLINE colorOption #-} -colorOption :: String -colorOption = - -- similar to debugLevel - -- keep synced with color/colour flag definition in hledger:CliOptions - let args = unsafePerformIO getArgs in - case dropWhile (/="--color") args of - -- --color ARG - "--color":v:_ -> v - _ -> - case take 1 $ filter ("--color=" `isPrefixOf`) args of - -- --color=ARG - ['-':'-':'c':'o':'l':'o':'r':'=':v] -> v - _ -> - case dropWhile (/="--colour") args of - -- --colour ARG - "--colour":v:_ -> v - _ -> - case take 1 $ filter ("--colour=" `isPrefixOf`) args of - -- --colour=ARG - ['-':'-':'c':'o':'l':'o':'u':'r':'=':v] -> v - _ -> "" - -- | Read the value of the -o/--output-file command line option provided at program startup, -- if any, using unsafePerformIO. --- {-# OPTIONS_GHC -fno-cse #-} --- {-# NOINLINE outputFileOption #-} outputFileOption :: Maybe String outputFileOption = -- keep synced with output-file flag definition in hledger:CliOptions. - let args = unsafePerformIO getArgs in + let args = progArgs in case dropWhile (not . ("-o" `isPrefixOf`)) args of -- -oARG ('-':'o':v@(_:_)):_ -> Just v