dev: lib: extract progArgs, minimise unsafe IO

It is exported from the increasingly-inaccurately-named
Hledger.Utils.Print for now.

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 "<interactive>".
+-- 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 "<interactive>" 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

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