dev: lib: consolidate some utils in Hledger.Utils.IO
This commit is contained in:
Simon Michael
parent
fc8aa5253a
commit
79047ccc43
@ -1,10 +1,8 @@
|
||||
{-|
|
||||
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 (
|
||||
|
||||
-- * Currying
|
||||
@ -15,30 +13,9 @@ module Hledger.Utils (
|
||||
curry4,
|
||||
uncurry4,
|
||||
|
||||
-- * Console
|
||||
color,
|
||||
bgColor,
|
||||
colorB,
|
||||
bgColorB,
|
||||
|
||||
-- * IO
|
||||
error',
|
||||
usageError,
|
||||
embedFileRelative,
|
||||
expandHomePath,
|
||||
expandPath,
|
||||
readFileOrStdinPortably,
|
||||
readFilePortably,
|
||||
readHandlePortably,
|
||||
-- hereFileRelative,
|
||||
|
||||
-- * Lists
|
||||
splitAtElement,
|
||||
|
||||
-- * Time
|
||||
getCurrentLocalTime,
|
||||
getCurrentZonedTime,
|
||||
|
||||
-- * Trees
|
||||
treeLeaves,
|
||||
|
||||
@ -65,14 +42,19 @@ module Hledger.Utils (
|
||||
-- * Misc
|
||||
applyN,
|
||||
mapM',
|
||||
numDigitsInt,
|
||||
maximum',
|
||||
maximumStrict,
|
||||
minimumStrict,
|
||||
numDigitsInt,
|
||||
sequence',
|
||||
sumStrict,
|
||||
|
||||
makeHledgerClassyLenses,
|
||||
|
||||
-- * Tests
|
||||
tests_Utils,
|
||||
module Hledger.Utils.Test,
|
||||
|
||||
-- * Other
|
||||
module Hledger.Utils.Debug,
|
||||
module Hledger.Utils.Parse,
|
||||
@ -81,34 +63,16 @@ module Hledger.Utils (
|
||||
module Hledger.Utils.String,
|
||||
module Hledger.Utils.Text,
|
||||
|
||||
-- * Tests
|
||||
tests_Utils,
|
||||
module Hledger.Utils.Test,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad (when)
|
||||
import Data.Char (toLower)
|
||||
import Data.FileEmbed (makeRelativeToProject, embedStringFile)
|
||||
import Data.List.Extra (foldl', foldl1', uncons, unsnoc)
|
||||
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 Language.Haskell.TH (DecsQ, Name, mkName, nameBase)
|
||||
import Language.Haskell.TH.Syntax (Q, Exp)
|
||||
import Lens.Micro ((&), (.~))
|
||||
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.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 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
|
||||
|
||||
splitAtElement :: Eq a => a -> [a] -> [[a]]
|
||||
@ -232,20 +115,6 @@ splitAtElement x l =
|
||||
split es = let (first,rest) = break (x==) es
|
||||
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
|
||||
|
||||
-- | Get the leaves of this tree as a list.
|
||||
|
||||
@ -9,33 +9,78 @@ The colour scheme may be somewhat hard-coded.
|
||||
|
||||
-}
|
||||
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module Hledger.Utils.IO (
|
||||
-- * Pretty showing as a string
|
||||
pshow
|
||||
,pshow'
|
||||
-- * Pretty printing to stdout
|
||||
,pprint
|
||||
,pprint'
|
||||
|
||||
-- * Pretty showing/printing
|
||||
pshow,
|
||||
pshow',
|
||||
pprint,
|
||||
pprint',
|
||||
|
||||
-- * Command line arguments
|
||||
,progArgs
|
||||
-- * Detecting --color/--colour/NO_COLOR
|
||||
,colorOption
|
||||
,useColorOnStdout
|
||||
,useColorOnStderr
|
||||
-- * Detecting -o/--output-file
|
||||
,outputFileOption
|
||||
,hasOutputFile
|
||||
progArgs,
|
||||
outputFileOption,
|
||||
hasOutputFile,
|
||||
|
||||
-- * ANSI color
|
||||
colorOption,
|
||||
useColorOnStdout,
|
||||
useColorOnStderr,
|
||||
color,
|
||||
bgColor,
|
||||
colorB,
|
||||
bgColorB,
|
||||
|
||||
-- * Errors
|
||||
error',
|
||||
usageError,
|
||||
|
||||
-- * Files
|
||||
embedFileRelative,
|
||||
expandHomePath,
|
||||
expandPath,
|
||||
readFileOrStdinPortably,
|
||||
readFilePortably,
|
||||
readHandlePortably,
|
||||
-- hereFileRelative,
|
||||
|
||||
-- * Time
|
||||
getCurrentLocalTime,
|
||||
getCurrentZonedTime,
|
||||
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad (when)
|
||||
import Data.FileEmbed (makeRelativeToProject, embedStringFile)
|
||||
import Data.List hiding (uncons)
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text.IO as T
|
||||
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.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 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.
|
||||
prettyopts =
|
||||
@ -67,7 +112,9 @@ pprint = pPrintOpt CheckColorTty prettyopts
|
||||
pprint' :: Show a => a -> IO ()
|
||||
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.
|
||||
-- Uses unsafePerformIO.
|
||||
@ -75,6 +122,34 @@ pprint' = pPrintOpt CheckColorTty prettyopts'
|
||||
progArgs :: [String]
|
||||
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
|
||||
-- using unsafePerformIO. If this option was not provided, returns the empty string.
|
||||
colorOption :: String
|
||||
@ -126,29 +201,98 @@ useColorOnHandle h = unsafePerformIO $ do
|
||||
return $ coloroption `elem` ["always","yes"]
|
||||
|| (coloroption `notElem` ["never","no"] && not no_color && supports_color)
|
||||
|
||||
-- | 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
|
||||
-- | 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 []
|
||||
|
||||
-- | 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 "-"]
|
||||
-- | 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
|
||||
|
||||
-- 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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user