slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

dev: lib: consolidate some utils in Hledger.Utils.IO

Browse Source
This commit is contained in:
Simon Michael 2022-11-04 19:04:15 -10:00
parent fc8aa5253a
commit 79047ccc43
2 changed files with 193 additions and 180 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

145
hledger-lib/Hledger/Utils.hs
View File

@ -1,10 +1,8 @@
{-| {-|
Utilities used throughout hledger, or needed low in the module hierarchy. Utilities used throughout hledger, or needed low in the module hierarchy.
This is the bottom of hledger's module graph. These are the bottom of hledger's module graph.
-} -}
{-# LANGUAGE LambdaCase #-}
module Hledger.Utils ( module Hledger.Utils (
-- * Currying -- * Currying
@ -15,30 +13,9 @@ module Hledger.Utils (
curry4, curry4,
uncurry4, uncurry4,
-- * Console
color,
bgColor,
colorB,
bgColorB,
-- * IO
error',
usageError,
embedFileRelative,
expandHomePath,
expandPath,
readFileOrStdinPortably,
readFilePortably,
readHandlePortably,
-- hereFileRelative,
-- * Lists -- * Lists
splitAtElement, splitAtElement,
-- * Time
getCurrentLocalTime,
getCurrentZonedTime,
-- * Trees -- * Trees
treeLeaves, treeLeaves,
@ -65,14 +42,19 @@ module Hledger.Utils (
-- * Misc -- * Misc
applyN, applyN,
mapM', mapM',
numDigitsInt,
maximum', maximum',
maximumStrict, maximumStrict,
minimumStrict, minimumStrict,
numDigitsInt,
sequence', sequence',
sumStrict, sumStrict,
makeHledgerClassyLenses, makeHledgerClassyLenses,
-- * Tests
tests_Utils,
module Hledger.Utils.Test,
-- * Other -- * Other
module Hledger.Utils.Debug, module Hledger.Utils.Debug,
module Hledger.Utils.Parse, module Hledger.Utils.Parse,
@ -81,34 +63,16 @@ module Hledger.Utils (
module Hledger.Utils.String, module Hledger.Utils.String,
module Hledger.Utils.Text, module Hledger.Utils.Text,
-- * Tests
tests_Utils,
module Hledger.Utils.Test,
) )
where where
import Control.Monad (when)
import Data.Char (toLower) import Data.Char (toLower)
import Data.FileEmbed (makeRelativeToProject, embedStringFile)
import Data.List.Extra (foldl', foldl1', uncons, unsnoc) import Data.List.Extra (foldl', foldl1', uncons, unsnoc)
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy.Builder as TB
import Data.Time.Clock (getCurrentTime)
import Data.Time.LocalTime (LocalTime, ZonedTime, getCurrentTimeZone,
utcToLocalTime, utcToZonedTime)
import Data.Tree (foldTree, Tree (Node, subForest)) import Data.Tree (foldTree, Tree (Node, subForest))
import Language.Haskell.TH (DecsQ, Name, mkName, nameBase) import Language.Haskell.TH (DecsQ, Name, mkName, nameBase)
import Language.Haskell.TH.Syntax (Q, Exp)
import Lens.Micro ((&), (.~)) import Lens.Micro ((&), (.~))
import Lens.Micro.TH (DefName(TopName), lensClass, lensField, makeLensesWith, classyRules) import Lens.Micro.TH (DefName(TopName), lensClass, lensField, makeLensesWith, classyRules)
import System.Console.ANSI (Color,ColorIntensity,ConsoleLayer(..), SGR(..), setSGRCode)
import System.Directory (getHomeDirectory)
import System.FilePath (isRelative, (</>))
import System.IO
(Handle, IOMode (..), hGetEncoding, hSetEncoding, hSetNewlineMode,
openFile, stdin, universalNewlineMode, utf8_bom)
import Hledger.Utils.Debug import Hledger.Utils.Debug
import Hledger.Utils.Parse import Hledger.Utils.Parse
@ -139,87 +103,6 @@ curry4 f w x y z = f (w, x, y, z)
uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
uncurry4 f (w, x, y, z) = f w x y z uncurry4 f (w, x, y, z) = f w x y z
-- Console
-- | Wrap a string in ANSI codes to set and reset foreground colour.
color :: ColorIntensity -> Color -> String -> String
color int col s = setSGRCode [SetColor Foreground int col] ++ s ++ setSGRCode []
-- | Wrap a string in ANSI codes to set and reset background colour.
bgColor :: ColorIntensity -> Color -> String -> String
bgColor int col s = setSGRCode [SetColor Background int col] ++ s ++ setSGRCode []
-- | Wrap a WideBuilder in ANSI codes to set and reset foreground colour.
colorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder
colorB int col (WideBuilder s w) =
WideBuilder (TB.fromString (setSGRCode [SetColor Foreground int col]) <> s <> TB.fromString (setSGRCode [])) w
-- | Wrap a WideBuilder in ANSI codes to set and reset background colour.
bgColorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder
bgColorB int col (WideBuilder s w) =
WideBuilder (TB.fromString (setSGRCode [SetColor Background int col]) <> s <> TB.fromString (setSGRCode [])) w
-- IO
-- | Convert a possibly relative, possibly tilde-containing file path to an absolute one,
-- given the current directory. ~username is not supported. Leave "-" 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:
-- | Expand user home path indicated by tilde prefix
expandHomePath :: FilePath -> IO FilePath
expandHomePath = \case
('~':'/':p) -> (</> p) <$> getHomeDirectory
('~':'\\':p) -> (</> p) <$> getHomeDirectory
('~':_) -> ioError $ userError "~USERNAME in paths is not supported"
p -> return p
-- | 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 Text
readFilePortably f = openFile f ReadMode >>= readHandlePortably
-- | Like readFilePortably, but read from standard input if the path is "-".
readFileOrStdinPortably :: String -> IO 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 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
-- | 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)")
-- | Like embedFile, but takes a path relative to the package directory.
-- Similar to embedFileRelative ?
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
-- Lists -- Lists
splitAtElement :: Eq a => a -> [a] -> [[a]] splitAtElement :: Eq a => a -> [a] -> [[a]]
@ -232,20 +115,6 @@ splitAtElement x l =
split es = let (first,rest) = break (x==) es split es = let (first,rest) = break (x==) es
in first : splitAtElement x rest in first : splitAtElement x rest
-- 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
-- Trees -- Trees
-- | Get the leaves of this tree as a list. -- | Get the leaves of this tree as a list.

228
hledger-lib/Hledger/Utils/IO.hs
View File

@ -9,33 +9,78 @@ The colour scheme may be somewhat hard-coded.
-} -}
{-# LANGUAGE LambdaCase #-}
module Hledger.Utils.IO ( module Hledger.Utils.IO (
-- * Pretty showing as a string
pshow -- * Pretty showing/printing
,pshow' pshow,
-- * Pretty printing to stdout pshow',
,pprint pprint,
,pprint' pprint',
-- * Command line arguments -- * Command line arguments
,progArgs progArgs,
-- * Detecting --color/--colour/NO_COLOR outputFileOption,
,colorOption hasOutputFile,
,useColorOnStdout
,useColorOnStderr -- * ANSI color
-- * Detecting -o/--output-file colorOption,
,outputFileOption useColorOnStdout,
,hasOutputFile useColorOnStderr,
color,
bgColor,
colorB,
bgColorB,
-- * Errors
error',
usageError,
-- * Files
embedFileRelative,
expandHomePath,
expandPath,
readFileOrStdinPortably,
readFilePortably,
readHandlePortably,
-- hereFileRelative,
-- * Time
getCurrentLocalTime,
getCurrentZonedTime,
) )
where where
import Control.Monad (when)
import Data.FileEmbed (makeRelativeToProject, embedStringFile)
import Data.List hiding (uncons) import Data.List hiding (uncons)
import Data.Maybe (isJust) import Data.Maybe (isJust)
import Data.Text (Text)
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import System.Console.ANSI (hSupportsANSIColor) import qualified Data.Text.Lazy.Builder as TB
import Data.Time.Clock (getCurrentTime)
import Data.Time.LocalTime
(LocalTime, ZonedTime, getCurrentTimeZone, utcToLocalTime, utcToZonedTime)
import Language.Haskell.TH.Syntax (Q, Exp)
import System.Console.ANSI
(Color,ColorIntensity,ConsoleLayer(..), SGR(..), hSupportsANSIColor, setSGRCode)
import System.Directory (getHomeDirectory)
import System.Environment (getArgs, lookupEnv) import System.Environment (getArgs, lookupEnv)
import System.IO (stdout, Handle, stderr) import System.FilePath (isRelative, (</>))
import System.IO
(Handle, IOMode (..), hGetEncoding, hSetEncoding, hSetNewlineMode,
openFile, stdin, stdout, stderr, universalNewlineMode, utf8_bom)
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
import Text.Pretty.Simple -- (defaultOutputOptionsDarkBg, OutputOptions(..), pShowOpt, pPrintOpt) import Text.Pretty.Simple
(CheckColorTty(CheckColorTty), OutputOptions(..),
defaultOutputOptionsDarkBg, defaultOutputOptionsNoColor, pShowOpt, pPrintOpt)
import Hledger.Utils.Text (WideBuilder(WideBuilder))
-- Pretty showing/printing with pretty-simple
-- | pretty-simple options with colour enabled if allowed. -- | pretty-simple options with colour enabled if allowed.
prettyopts = prettyopts =
@ -67,7 +112,9 @@ pprint = pPrintOpt CheckColorTty prettyopts
pprint' :: Show a => a -> IO () pprint' :: Show a => a -> IO ()
pprint' = pPrintOpt CheckColorTty prettyopts' pprint' = pPrintOpt CheckColorTty prettyopts'
-- Avoid using pshow, pprint, dbg* in the code below to prevent infinite loops. -- "Avoid using pshow, pprint, dbg* in the code below to prevent infinite loops." (?)
-- Command line arguments
-- | The command line arguments that were used at program startup. -- | The command line arguments that were used at program startup.
-- Uses unsafePerformIO. -- Uses unsafePerformIO.
@ -75,6 +122,34 @@ pprint' = pPrintOpt CheckColorTty prettyopts'
progArgs :: [String] progArgs :: [String]
progArgs = unsafePerformIO getArgs progArgs = unsafePerformIO getArgs
-- | Read the value of the -o/--output-file command line option provided at program startup,
-- if any, using unsafePerformIO.
outputFileOption :: Maybe String
outputFileOption =
-- keep synced with output-file flag definition in hledger:CliOptions.
let args = progArgs in
case dropWhile (not . ("-o" `isPrefixOf`)) args of
-- -oARG
('-':'o':v@(_:_)):_ -> Just v
-- -o ARG
"-o":v:_ -> Just v
_ ->
case dropWhile (/="--output-file") args of
-- --output-file ARG
"--output-file":v:_ -> Just v
_ ->
case take 1 $ filter ("--output-file=" `isPrefixOf`) args of
-- --output=file=ARG
['-':'-':'o':'u':'t':'p':'u':'t':'-':'f':'i':'l':'e':'=':v] -> Just v
_ -> Nothing
-- | Check whether the -o/--output-file option has been used at program startup
-- with an argument other than "-", using unsafePerformIO.
hasOutputFile :: Bool
hasOutputFile = outputFileOption `notElem` [Nothing, Just "-"]
-- ANSI colour
-- | Read the value of the --color or --colour command line option provided at program startup -- | 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. -- using unsafePerformIO. If this option was not provided, returns the empty string.
colorOption :: String colorOption :: String
@ -126,29 +201,98 @@ useColorOnHandle h = unsafePerformIO $ do
return $ coloroption `elem` ["always","yes"] return $ coloroption `elem` ["always","yes"]
|| (coloroption `notElem` ["never","no"] && not no_color && supports_color) || (coloroption `notElem` ["never","no"] && not no_color && supports_color)
-- | Read the value of the -o/--output-file command line option provided at program startup, -- | Wrap a string in ANSI codes to set and reset foreground colour.
-- if any, using unsafePerformIO. color :: ColorIntensity -> Color -> String -> String
outputFileOption :: Maybe String color int col s = setSGRCode [SetColor Foreground int col] ++ s ++ setSGRCode []
outputFileOption =
-- keep synced with output-file flag definition in hledger:CliOptions.
let args = progArgs in
case dropWhile (not . ("-o" `isPrefixOf`)) args of
-- -oARG
('-':'o':v@(_:_)):_ -> Just v
-- -o ARG
"-o":v:_ -> Just v
_ ->
case dropWhile (/="--output-file") args of
-- --output-file ARG
"--output-file":v:_ -> Just v
_ ->
case take 1 $ filter ("--output-file=" `isPrefixOf`) args of
-- --output=file=ARG
['-':'-':'o':'u':'t':'p':'u':'t':'-':'f':'i':'l':'e':'=':v] -> Just v
_ -> Nothing
-- | Check whether the -o/--output-file option has been used at program startup -- | Wrap a string in ANSI codes to set and reset background colour.
-- with an argument other than "-", using unsafePerformIO. bgColor :: ColorIntensity -> Color -> String -> String
hasOutputFile :: Bool bgColor int col s = setSGRCode [SetColor Background int col] ++ s ++ setSGRCode []
hasOutputFile = outputFileOption `notElem` [Nothing, Just "-"]
-- | Wrap a WideBuilder in ANSI codes to set and reset foreground colour.
colorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder
colorB int col (WideBuilder s w) =
WideBuilder (TB.fromString (setSGRCode [SetColor Foreground int col]) <> s <> TB.fromString (setSGRCode [])) w
-- | Wrap a WideBuilder in ANSI codes to set and reset background colour.
bgColorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder
bgColorB int col (WideBuilder s w) =
WideBuilder (TB.fromString (setSGRCode [SetColor Background int col]) <> s <> TB.fromString (setSGRCode [])) w
-- 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
-- | Convert a possibly relative, possibly tilde-containing file path to an absolute one,
-- given the current directory. ~username is not supported. Leave "-" 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:
-- | Expand user home path indicated by tilde prefix
expandHomePath :: FilePath -> IO FilePath
expandHomePath = \case
('~':'/':p) -> (</> p) <$> getHomeDirectory
('~':'\\':p) -> (</> p) <$> getHomeDirectory
('~':_) -> ioError $ userError "~USERNAME in paths is not supported"
p -> return p
-- | 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 Text
readFilePortably f = openFile f ReadMode >>= readHandlePortably
-- | Like readFilePortably, but read from standard input if the path is "-".
readFileOrStdinPortably :: String -> IO 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 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.
-- Similar to embedFileRelative ?
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