dev: Hledger.Utils.IO: cleanup

hledger-lib/Hledger/Utils/IO.hs

@@ -21,16 +21,27 @@ module Hledger.Utils.IO (
   pprint,
   pprint',
 
-  -- * Viewing with pager
+  -- * Errors
-  setupPager,
+  error',
-  runPager,
+  usageError,
 
-  -- * Terminal size
+  -- * Time
-  getTerminalHeightWidth,
+  getCurrentLocalTime,
-  getTerminalHeight,
+  getCurrentZonedTime,
-  getTerminalWidth,
 
-  -- * Command line arguments
+  -- * Files
+  embedFileRelative,
+  expandHomePath,
+  expandPath,
+  expandGlob,
+  sortByModTime,
+  readFileOrStdinPortably,
+  readFileStrictly,
+  readFilePortably,
+  readHandlePortably,
+  -- hereFileRelative,
+
+  -- * Command line parsing
   progArgs,
   outputFileOption,
   hasOutputFile,
@@ -40,8 +51,19 @@ module Hledger.Utils.IO (
   parseYNA,
   YNA(..),
 
-  -- * ANSI color/styles
+  -- * Terminal size
+  getTerminalHeightWidth,
+  getTerminalHeight,
+  getTerminalWidth,
+
+  -- * Pager output
+  setupPager,
+  runPager,
+
+  -- * ANSI colour/styles
+
   -- ** hledger-specific
+
   colorOption,
   useColorOnStdout,
   useColorOnStderr,
@@ -68,39 +90,21 @@ module Hledger.Utils.IO (
   rgb',
 
   -- ** Generic
-  -- XXX Types used with color/bgColor/colorB/bgColorB,
+
-  -- not re-exported because clashing with UIUtils:
-  -- Color(..),
-  -- ColorIntensity(..),
   color,
   bgColor,
   colorB,
   bgColorB,
+  -- XXX Types used with color/bgColor/colorB/bgColorB,
+  -- not re-exported because clashing with UIUtils:
+  -- Color(..),
+  -- ColorIntensity(..),
+
   terminalIsLight,
   terminalLightness,
   terminalFgColor,
   terminalBgColor,
 
-  -- * Errors
-  error',
-  usageError,
-
-  -- * Files
-  embedFileRelative,
-  expandHomePath,
-  expandPath,
-  expandGlob,
-  sortByModTime,
-  readFileOrStdinPortably,
-  readFileStrictly,
-  readFilePortably,
-  readHandlePortably,
-  -- hereFileRelative,
-
-  -- * Time
-  getCurrentLocalTime,
-  getCurrentZonedTime,
-
   )
 where
 
@@ -142,7 +146,9 @@ import           Text.Pretty.Simple (CheckColorTty(..), OutputOptions(..), defau
 import Hledger.Utils.Text (WideBuilder(WideBuilder))
 
 
--- Pretty showing/printing with pretty-simple
+
+-- Pretty showing/printing
+-- using pretty-simple
 
 -- https://hackage.haskell.org/package/pretty-simple/docs/Text-Pretty-Simple.html#t:OutputOptions
 
@@ -181,6 +187,181 @@ pprint' = pPrintOpt NoCheckColorTty prettyoptsNoColor
 
 -- "Avoid using pshow, pprint, dbg* in the code below to prevent infinite loops." (?)
 
+
+
+-- Errors
+
+-- | Simpler alias for errorWithoutStackTrace
+error' :: String -> a
+error' = errorWithoutStackTrace . ("Error: " <>)
+
+-- | A version of errorWithoutStackTrace that adds a usage hint.
+usageError :: String -> a
+usageError = error' . (++ " (use -h to see usage)")
+
+
+
+-- Time
+
+getCurrentLocalTime :: IO LocalTime
+getCurrentLocalTime = do
+  t <- getCurrentTime
+  tz <- getCurrentTimeZone
+  return $ utcToLocalTime tz t
+
+getCurrentZonedTime :: IO ZonedTime
+getCurrentZonedTime = do
+  t <- getCurrentTime
+  tz <- getCurrentTimeZone
+  return $ utcToZonedTime tz t
+
+
+
+-- Files
+
+-- | Expand a tilde (representing home directory) at the start of a file path.
+-- ~username is not supported. Can raise an error.
+expandHomePath :: FilePath -> IO FilePath
+expandHomePath = \case
+    ('~':'/':p)  -> (</> p) <$> getHomeDirectory
+    ('~':'\\':p) -> (</> p) <$> getHomeDirectory
+    ('~':_)      -> ioError $ userError "~USERNAME in paths is not supported"
+    p            -> return p
+
+-- | Given a current directory, convert a possibly relative, possibly tilde-containing
+-- file path to an absolute one.
+-- ~username is not supported. Leaves "-" unchanged. Can raise an error.
+expandPath :: FilePath -> FilePath -> IO FilePath -- general type sig for use in reader parsers
+expandPath _ "-" = return "-"
+expandPath curdir p = (if isRelative p then (curdir </>) else id) <$> expandHomePath p  -- PARTIAL:
+
+-- | Like expandPath, but treats the expanded path as a glob, and returns
+-- zero or more matched absolute file paths, alphabetically sorted.
+-- Can raise an error.
+expandGlob :: FilePath -> FilePath -> IO [FilePath]
+expandGlob curdir p = expandPath curdir p >>= glob <&> sort  -- PARTIAL:
+
+-- | Given a list of existing file paths, sort them by modification time, most recent first.
+sortByModTime :: [FilePath] -> IO [FilePath]
+sortByModTime fs = do
+  ftimes <- forM fs $ \f -> do {t <- getModificationTime f; return (t,f)}
+  return $ map snd $ sortBy (comparing Data.Ord.Down) ftimes
+
+-- | Like readFilePortably, but read all of the file before proceeding.
+readFileStrictly :: FilePath -> IO T.Text
+readFileStrictly f = readFilePortably f >>= \t -> evaluate (T.length t) >> return t
+
+-- | Read text from a file,
+-- converting any \r\n line endings to \n,,
+-- using the system locale's text encoding,
+-- ignoring any utf8 BOM prefix (as seen in paypal's 2018 CSV, eg) if that encoding is utf8.
+readFilePortably :: FilePath -> IO T.Text
+readFilePortably f =  openFile f ReadMode >>= readHandlePortably
+
+-- | Like readFilePortably, but read from standard input if the path is "-".
+readFileOrStdinPortably :: String -> IO T.Text
+readFileOrStdinPortably f = openFileOrStdin f ReadMode >>= readHandlePortably
+  where
+    openFileOrStdin :: String -> IOMode -> IO Handle
+    openFileOrStdin "-" _ = return stdin
+    openFileOrStdin f' m   = openFile f' m
+
+readHandlePortably :: Handle -> IO T.Text
+readHandlePortably h = do
+  hSetNewlineMode h universalNewlineMode
+  menc <- hGetEncoding h
+  when (fmap show menc == Just "UTF-8") $  -- XXX no Eq instance, rely on Show
+    hSetEncoding h utf8_bom
+  T.hGetContents h
+
+-- | Like embedFile, but takes a path relative to the package directory.
+embedFileRelative :: FilePath -> Q Exp
+embedFileRelative f = makeRelativeToProject f >>= embedStringFile
+
+-- -- | Like hereFile, but takes a path relative to the package directory.
+-- -- Similar to embedFileRelative ?
+-- hereFileRelative :: FilePath -> Q Exp
+-- hereFileRelative f = makeRelativeToProject f >>= hereFileExp
+--   where
+--     QuasiQuoter{quoteExp=hereFileExp} = hereFile
+
+
+
+-- Command line parsing
+
+-- | Given one or more long or short option names, read the rightmost value of this option from the command line arguments.
+-- If the value is missing raise an error.
+getOpt :: [String] -> IO (Maybe String)
+getOpt names = do
+  rargs <- reverse . splitFlagsAndVals <$> getArgs
+  let flags = map toFlag names
+  return $
+    case break ((`elem` flags)) rargs of
+      (_,[])        -> Nothing
+      ([],flag:_)   -> error' $ flag <> " requires a value"
+      (argsafter,_) -> Just $ last argsafter
+
+-- | Given a list of arguments, split any of the form --flag=VAL or -fVAL
+-- into separate list items. Multiple valueless short flags joined together is not supported.
+splitFlagsAndVals :: [String] -> [String]
+splitFlagsAndVals = concatMap $
+  \case
+    a@('-':'-':_) | '=' `elem` a -> let (x,y) = break (=='=') a in [x, drop 1 y]
+    a@('-':f:_:_) | not $ f=='-' -> [take 2 a, drop 2 a]
+    a -> [a]
+
+-- | Convert a short or long flag name to a flag with leading hyphen(s).
+toFlag [c] = ['-',c]
+toFlag s   = '-':'-':s
+
+-- | Parse y/yes/always or n/no/never to true or false, or with any other value raise an error.
+parseYN :: String -> Bool
+parseYN s
+  | l `elem` ["y","yes","always"] = True
+  | l `elem` ["n","no","never"]   = False
+  | otherwise = error' $ "value should be one of " <> (intercalate ", " ["y","yes","n","no"])
+  where l = map toLower s
+
+data YNA = Yes | No | Auto deriving (Eq,Show)
+
+-- | Parse y/yes/always or n/no/never or a/auto to a YNA choice, or with any other value raise an error.
+parseYNA :: String -> YNA
+parseYNA s
+  | l `elem` ["y","yes","always"] = Yes
+  | l `elem` ["n","no","never"]   = No
+  | l `elem` ["a","auto"]         = Auto
+  | otherwise = error' $ "value should be one of " <> (intercalate ", " ["y","yes","n","no","a","auto"])
+  where l = map toLower s
+
+-- | The command line arguments that were used at program startup.
+-- Uses unsafePerformIO.
+{-# NOINLINE progArgs #-}
+progArgs :: [String]
+progArgs = unsafePerformIO getArgs
+-- XXX While convenient, using this has the following problem:
+-- it detects flags/options/arguments from the command line, but not from a config file.
+-- Currently this affects:
+--  --debug
+--  --color
+--  the enabling of orderdates and assertions checks in journalFinalise
+-- Separate these into unsafe and safe variants and try to use the latter more
+
+outputFileOption :: IO (Maybe String)
+outputFileOption = getOpt ["output-file","o"]
+
+hasOutputFile :: IO Bool
+hasOutputFile = do
+  mv <- getOpt ["output-file","o"]
+  return $
+    case mv of
+      Nothing  -> False
+      Just "-" -> False
+      _        -> True
+
+
+
+-- Terminal size
+
 -- | An alternative to ansi-terminal's getTerminalSize, based on
 -- the more robust-looking terminal-size package.
 -- Tries to get stdout's terminal's current height and width.
@@ -196,7 +377,8 @@ getTerminalWidth  = fmap snd <$> getTerminalHeightWidth
 
 
 
--- Pager helpers, somewhat hledger-specific.
+-- Pager output
+-- somewhat hledger-specific
 
 -- Configure some preferred options for the `less` pager,
 -- by modifying the LESS environment variable in this program's environment.
@@ -315,80 +497,8 @@ findPager = do
 
 
 
--- Command line parsing
+-- ANSI colour/styles
-
+-- Some of these use unsafePerformIO to read info.
--- | Given one or more long or short option names, read the rightmost value of this option from the command line arguments.
--- If the value is missing raise an error.
-getOpt :: [String] -> IO (Maybe String)
-getOpt names = do
-  rargs <- reverse . splitFlagsAndVals <$> getArgs
-  let flags = map toFlag names
-  return $
-    case break ((`elem` flags)) rargs of
-      (_,[])        -> Nothing
-      ([],flag:_)   -> error' $ flag <> " requires a value"
-      (argsafter,_) -> Just $ last argsafter
-
--- | Given a list of arguments, split any of the form --flag=VAL or -fVAL
--- into separate list items. Multiple valueless short flags joined together is not supported.
-splitFlagsAndVals :: [String] -> [String]
-splitFlagsAndVals = concatMap $
-  \case
-    a@('-':'-':_) | '=' `elem` a -> let (x,y) = break (=='=') a in [x, drop 1 y]
-    a@('-':f:_:_) | not $ f=='-' -> [take 2 a, drop 2 a]
-    a -> [a]
-
--- | Convert a short or long flag name to a flag with leading hyphen(s).
-toFlag [c] = ['-',c]
-toFlag s   = '-':'-':s
-
--- | Parse y/yes/always or n/no/never to true or false, or with any other value raise an error.
-parseYN :: String -> Bool
-parseYN s
-  | l `elem` ["y","yes","always"] = True
-  | l `elem` ["n","no","never"]   = False
-  | otherwise = error' $ "value should be one of " <> (intercalate ", " ["y","yes","n","no"])
-  where l = map toLower s
-
-data YNA = Yes | No | Auto deriving (Eq,Show)
-
--- | Parse y/yes/always or n/no/never or a/auto to a YNA choice, or with any other value raise an error.
-parseYNA :: String -> YNA
-parseYNA s
-  | l `elem` ["y","yes","always"] = Yes
-  | l `elem` ["n","no","never"]   = No
-  | l `elem` ["a","auto"]         = Auto
-  | otherwise = error' $ "value should be one of " <> (intercalate ", " ["y","yes","n","no","a","auto"])
-  where l = map toLower s
-
--- | The command line arguments that were used at program startup.
--- Uses unsafePerformIO.
-{-# NOINLINE progArgs #-}
-progArgs :: [String]
-progArgs = unsafePerformIO getArgs
--- XXX While convenient, using this has the following problem:
--- it detects flags/options/arguments from the command line, but not from a config file.
--- Currently this affects:
---  --debug
---  --color
---  the enabling of orderdates and assertions checks in journalFinalise
--- Separate these into unsafe and safe variants and try to use the latter more
-
-outputFileOption :: IO (Maybe String)
-outputFileOption = getOpt ["output-file","o"]
-
-hasOutputFile :: IO Bool
-hasOutputFile = do
-  mv <- getOpt ["output-file","o"]
-  return $
-    case mv of
-      Nothing  -> False
-      Just "-" -> False
-      _        -> True
-
-
-
--- ANSI colour/style helpers. Some of these use unsafePerformIO to read info.
 
 -- hledger-specific:
 
@@ -541,6 +651,7 @@ bgColorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder
 bgColorB int col (WideBuilder s w) =
     WideBuilder (TB.fromString (setSGRCode [SetColor Background int col]) <> s <> TB.fromString (setSGRCode [])) w
 
+
 -- | Detect whether the terminal currently has a light background colour,
 -- if possible, using unsafePerformIO.
 -- If the terminal is transparent, its apparent light/darkness may be different.
@@ -581,100 +692,3 @@ getLayerColor' l = do
     fractionalRGB :: (Fractional a) => RGB Word16 -> RGB a
     fractionalRGB (RGB r g b) = RGB (fromIntegral r / 65535) (fromIntegral g / 65535) (fromIntegral b / 65535)  -- chatgpt
 
-
-
--- Errors
-
--- | Simpler alias for errorWithoutStackTrace
-error' :: String -> a
-error' = errorWithoutStackTrace . ("Error: " <>)
-
--- | A version of errorWithoutStackTrace that adds a usage hint.
-usageError :: String -> a
-usageError = error' . (++ " (use -h to see usage)")
-
-
-
--- Files
-
--- | Expand a tilde (representing home directory) at the start of a file path.
--- ~username is not supported. Can raise an error.
-expandHomePath :: FilePath -> IO FilePath
-expandHomePath = \case
-    ('~':'/':p)  -> (</> p) <$> getHomeDirectory
-    ('~':'\\':p) -> (</> p) <$> getHomeDirectory
-    ('~':_)      -> ioError $ userError "~USERNAME in paths is not supported"
-    p            -> return p
-
--- | Given a current directory, convert a possibly relative, possibly tilde-containing
--- file path to an absolute one.
--- ~username is not supported. Leaves "-" unchanged. Can raise an error.
-expandPath :: FilePath -> FilePath -> IO FilePath -- general type sig for use in reader parsers
-expandPath _ "-" = return "-"
-expandPath curdir p = (if isRelative p then (curdir </>) else id) <$> expandHomePath p  -- PARTIAL:
-
--- | Like expandPath, but treats the expanded path as a glob, and returns
--- zero or more matched absolute file paths, alphabetically sorted.
--- Can raise an error.
-expandGlob :: FilePath -> FilePath -> IO [FilePath]
-expandGlob curdir p = expandPath curdir p >>= glob <&> sort  -- PARTIAL:
-
--- | Given a list of existing file paths, sort them by modification time, most recent first.
-sortByModTime :: [FilePath] -> IO [FilePath]
-sortByModTime fs = do
-  ftimes <- forM fs $ \f -> do {t <- getModificationTime f; return (t,f)}
-  return $ map snd $ sortBy (comparing Data.Ord.Down) ftimes
-
--- | Like readFilePortably, but read all of the file before proceeding.
-readFileStrictly :: FilePath -> IO T.Text
-readFileStrictly f = readFilePortably f >>= \t -> evaluate (T.length t) >> return t
-
--- | Read text from a file,
--- converting any \r\n line endings to \n,,
--- using the system locale's text encoding,
--- ignoring any utf8 BOM prefix (as seen in paypal's 2018 CSV, eg) if that encoding is utf8.
-readFilePortably :: FilePath -> IO T.Text
-readFilePortably f =  openFile f ReadMode >>= readHandlePortably
-
--- | Like readFilePortably, but read from standard input if the path is "-".
-readFileOrStdinPortably :: String -> IO T.Text
-readFileOrStdinPortably f = openFileOrStdin f ReadMode >>= readHandlePortably
-  where
-    openFileOrStdin :: String -> IOMode -> IO Handle
-    openFileOrStdin "-" _ = return stdin
-    openFileOrStdin f' m   = openFile f' m
-
-readHandlePortably :: Handle -> IO T.Text
-readHandlePortably h = do
-  hSetNewlineMode h universalNewlineMode
-  menc <- hGetEncoding h
-  when (fmap show menc == Just "UTF-8") $  -- XXX no Eq instance, rely on Show
-    hSetEncoding h utf8_bom
-  T.hGetContents h
-
--- | Like embedFile, but takes a path relative to the package directory.
-embedFileRelative :: FilePath -> Q Exp
-embedFileRelative f = makeRelativeToProject f >>= embedStringFile
-
--- -- | Like hereFile, but takes a path relative to the package directory.
--- -- Similar to embedFileRelative ?
--- hereFileRelative :: FilePath -> Q Exp
--- hereFileRelative f = makeRelativeToProject f >>= hereFileExp
---   where
---     QuasiQuoter{quoteExp=hereFileExp} = hereFile
-
--- Time
-
-getCurrentLocalTime :: IO LocalTime
-getCurrentLocalTime = do
-  t <- getCurrentTime
-  tz <- getCurrentTimeZone
-  return $ utcToLocalTime tz t
-
-getCurrentZonedTime :: IO ZonedTime
-getCurrentZonedTime = do
-  t <- getCurrentTime
-  tz <- getCurrentTimeZone
-  return $ utcToZonedTime tz t
-
-