mirror of
https://github.com/simonmichael/hledger.git
synced 2024-12-29 13:22:27 +03:00
299 lines
9.9 KiB
Haskell
299 lines
9.9 KiB
Haskell
{- |
|
|
Helpers for pretty-printing haskell values, reading command line arguments,
|
|
working with ANSI colours, files, and time.
|
|
Uses unsafePerformIO.
|
|
|
|
Limitations:
|
|
When running in GHCI, this module must be reloaded to see environmental changes.
|
|
The colour scheme may be somewhat hard-coded.
|
|
|
|
-}
|
|
|
|
{-# LANGUAGE LambdaCase #-}
|
|
|
|
module Hledger.Utils.IO (
|
|
|
|
-- * Pretty showing/printing
|
|
pshow,
|
|
pshow',
|
|
pprint,
|
|
pprint',
|
|
|
|
-- * Command line arguments
|
|
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 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.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
|
|
(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 =
|
|
(if useColorOnStderr then defaultOutputOptionsDarkBg else defaultOutputOptionsNoColor)
|
|
{ outputOptionsIndentAmount=2
|
|
, outputOptionsCompact=True
|
|
}
|
|
|
|
-- | pretty-simple options with colour disabled.
|
|
prettyopts' =
|
|
defaultOutputOptionsNoColor
|
|
{ outputOptionsIndentAmount=2
|
|
, outputOptionsCompact=True
|
|
}
|
|
|
|
-- | Pretty show. Easier alias for pretty-simple's pShow.
|
|
pshow :: Show a => a -> String
|
|
pshow = TL.unpack . pShowOpt prettyopts
|
|
|
|
-- | Monochrome version of pshow.
|
|
pshow' :: Show a => a -> String
|
|
pshow' = TL.unpack . pShowOpt prettyopts'
|
|
|
|
-- | Pretty print. Easier alias for pretty-simple's pPrint.
|
|
pprint :: Show a => a -> IO ()
|
|
pprint = pPrintOpt CheckColorTty prettyopts
|
|
|
|
-- | Monochrome version of pprint.
|
|
pprint' :: Show a => a -> IO ()
|
|
pprint' = pPrintOpt CheckColorTty prettyopts'
|
|
|
|
-- "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.
|
|
{-# NOINLINE progArgs #-}
|
|
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
|
|
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.
|
|
-- The logic is: use color if
|
|
-- the program was started with --color=yes|always
|
|
-- or (
|
|
-- the program was not started with --color=no|never
|
|
-- and a NO_COLOR environment variable is not defined
|
|
-- and stdout supports ANSI color
|
|
-- and -o/--output-file was not used, or its value is "-"
|
|
-- ).
|
|
useColorOnStdout :: Bool
|
|
useColorOnStdout = not hasOutputFile && useColorOnHandle stdout
|
|
|
|
-- | Like useColorOnStdout, but checks for ANSI color support on stderr,
|
|
-- and is not affected by -o/--output-file.
|
|
useColorOnStderr :: Bool
|
|
useColorOnStderr = useColorOnHandle stderr
|
|
|
|
useColorOnHandle :: Handle -> Bool
|
|
useColorOnHandle h = unsafePerformIO $ do
|
|
no_color <- isJust <$> lookupEnv "NO_COLOR"
|
|
supports_color <- hSupportsANSIColor h
|
|
let coloroption = colorOption
|
|
return $ coloroption `elem` ["always","yes"]
|
|
|| (coloroption `notElem` ["never","no"] && not no_color && supports_color)
|
|
|
|
-- | 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
|
|
|
|
-- 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
|
|
|