{-# LANGUAGE LambdaCase #-}
module Hledger.Utils.IO (
pshow,
pshow',
pprint,
pprint',
progArgs,
outputFileOption,
hasOutputFile,
colorOption,
useColorOnStdout,
useColorOnStderr,
color,
bgColor,
colorB,
bgColorB,
error',
usageError,
embedFileRelative,
expandHomePath,
expandPath,
readFileOrStdinPortably,
readFilePortably,
readHandlePortably,
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))
prettyopts :: OutputOptions
prettyopts =
(if Bool
useColorOnStderr then OutputOptions
defaultOutputOptionsDarkBg else OutputOptions
defaultOutputOptionsNoColor)
{ outputOptionsIndentAmount :: Int
outputOptionsIndentAmount=Int
2
, outputOptionsCompact :: Bool
outputOptionsCompact=Bool
True
}
prettyopts' :: OutputOptions
prettyopts' =
OutputOptions
defaultOutputOptionsNoColor
{ outputOptionsIndentAmount :: Int
outputOptionsIndentAmount=Int
2
, outputOptionsCompact :: Bool
outputOptionsCompact=Bool
True
}
pshow :: Show a => a -> String
pshow :: forall a. Show a => a -> String
pshow = Text -> String
TL.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => OutputOptions -> a -> Text
pShowOpt OutputOptions
prettyopts
pshow' :: Show a => a -> String
pshow' :: forall a. Show a => a -> String
pshow' = Text -> String
TL.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => OutputOptions -> a -> Text
pShowOpt OutputOptions
prettyopts'
pprint :: Show a => a -> IO ()
pprint :: forall a. Show a => a -> IO ()
pprint = forall (m :: * -> *) a.
(MonadIO m, Show a) =>
CheckColorTty -> OutputOptions -> a -> m ()
pPrintOpt CheckColorTty
CheckColorTty OutputOptions
prettyopts
pprint' :: Show a => a -> IO ()
pprint' :: forall a. Show a => a -> IO ()
pprint' = forall (m :: * -> *) a.
(MonadIO m, Show a) =>
CheckColorTty -> OutputOptions -> a -> m ()
pPrintOpt CheckColorTty
CheckColorTty OutputOptions
prettyopts'
{-# NOINLINE progArgs #-}
progArgs :: [String]
progArgs :: [String]
progArgs = forall a. IO a -> a
unsafePerformIO IO [String]
getArgs
outputFileOption :: Maybe String
outputFileOption :: Maybe String
outputFileOption =
let args :: [String]
args = [String]
progArgs in
case forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"-o" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)) [String]
args of
(Char
'-':Char
'o':v :: String
v@(Char
_:String
_)):[String]
_ -> forall a. a -> Maybe a
Just String
v
String
"-o":String
v:[String]
_ -> forall a. a -> Maybe a
Just String
v
[String]
_ ->
case forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/=String
"--output-file") [String]
args of
String
"--output-file":String
v:[String]
_ -> forall a. a -> Maybe a
Just String
v
[String]
_ ->
case forall a. Int -> [a] -> [a]
take Int
1 forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--output-file=" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
args of
[Char
'-':Char
'-':Char
'o':Char
'u':Char
't':Char
'p':Char
'u':Char
't':Char
'-':Char
'f':Char
'i':Char
'l':Char
'e':Char
'=':String
v] -> forall a. a -> Maybe a
Just String
v
[String]
_ -> forall a. Maybe a
Nothing
hasOutputFile :: Bool
hasOutputFile :: Bool
hasOutputFile = Maybe String
outputFileOption forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just String
"-"]
colorOption :: String
colorOption :: String
colorOption =
let args :: [String]
args = [String]
progArgs in
case forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/=String
"--color") [String]
args of
String
"--color":String
v:[String]
_ -> String
v
[String]
_ ->
case forall a. Int -> [a] -> [a]
take Int
1 forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--color=" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
args of
[Char
'-':Char
'-':Char
'c':Char
'o':Char
'l':Char
'o':Char
'r':Char
'=':String
v] -> String
v
[String]
_ ->
case forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/=String
"--colour") [String]
args of
String
"--colour":String
v:[String]
_ -> String
v
[String]
_ ->
case forall a. Int -> [a] -> [a]
take Int
1 forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--colour=" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
args of
[Char
'-':Char
'-':Char
'c':Char
'o':Char
'l':Char
'o':Char
'u':Char
'r':Char
'=':String
v] -> String
v
[String]
_ -> String
""
useColorOnStdout :: Bool
useColorOnStdout :: Bool
useColorOnStdout = Bool -> Bool
not Bool
hasOutputFile Bool -> Bool -> Bool
&& Handle -> Bool
useColorOnHandle Handle
stdout
useColorOnStderr :: Bool
useColorOnStderr :: Bool
useColorOnStderr = Handle -> Bool
useColorOnHandle Handle
stderr
useColorOnHandle :: Handle -> Bool
useColorOnHandle :: Handle -> Bool
useColorOnHandle Handle
h = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
Bool
no_color <- forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"NO_COLOR"
Bool
supports_color <- Handle -> IO Bool
hSupportsANSIColor Handle
h
let coloroption :: String
coloroption = String
colorOption
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
coloroption forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"always",String
"yes"]
Bool -> Bool -> Bool
|| (String
coloroption forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
"never",String
"no"] Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
no_color Bool -> Bool -> Bool
&& Bool
supports_color)
color :: ColorIntensity -> Color -> String -> String
color :: ColorIntensity -> Color -> String -> String
color ColorIntensity
int Color
col String
s = [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
int Color
col] forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ [SGR] -> String
setSGRCode []
bgColor :: ColorIntensity -> Color -> String -> String
bgColor :: ColorIntensity -> Color -> String -> String
bgColor ColorIntensity
int Color
col String
s = [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Background ColorIntensity
int Color
col] forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ [SGR] -> String
setSGRCode []
colorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder
colorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder
colorB ColorIntensity
int Color
col (WideBuilder Builder
s Int
w) =
Builder -> Int -> WideBuilder
WideBuilder (String -> Builder
TB.fromString ([SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
int Color
col]) forall a. Semigroup a => a -> a -> a
<> Builder
s forall a. Semigroup a => a -> a -> a
<> String -> Builder
TB.fromString ([SGR] -> String
setSGRCode [])) Int
w
bgColorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder
bgColorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder
bgColorB ColorIntensity
int Color
col (WideBuilder Builder
s Int
w) =
Builder -> Int -> WideBuilder
WideBuilder (String -> Builder
TB.fromString ([SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Background ColorIntensity
int Color
col]) forall a. Semigroup a => a -> a -> a
<> Builder
s forall a. Semigroup a => a -> a -> a
<> String -> Builder
TB.fromString ([SGR] -> String
setSGRCode [])) Int
w
error' :: String -> a
error' :: forall a. String -> a
error' = forall a. String -> a
errorWithoutStackTrace forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Error: " forall a. Semigroup a => a -> a -> a
<>)
usageError :: String -> a
usageError :: forall a. String -> a
usageError = forall a. String -> a
error' forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ String
" (use -h to see usage)")
expandPath :: FilePath -> FilePath -> IO FilePath
expandPath :: String -> String -> IO String
expandPath String
_ String
"-" = forall (m :: * -> *) a. Monad m => a -> m a
return String
"-"
expandPath String
curdir String
p = (if String -> Bool
isRelative String
p then (String
curdir String -> String -> String
</>) else forall a. a -> a
id) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
expandHomePath String
p
expandHomePath :: FilePath -> IO FilePath
expandHomePath :: String -> IO String
expandHomePath = \case
(Char
'~':Char
'/':String
p) -> (String -> String -> String
</> String
p) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getHomeDirectory
(Char
'~':Char
'\\':String
p) -> (String -> String -> String
</> String
p) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getHomeDirectory
(Char
'~':String
_) -> forall a. IOError -> IO a
ioError forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"~USERNAME in paths is not supported"
String
p -> forall (m :: * -> *) a. Monad m => a -> m a
return String
p
readFilePortably :: FilePath -> IO Text
readFilePortably :: String -> IO Text
readFilePortably String
f = String -> IOMode -> IO Handle
openFile String
f IOMode
ReadMode forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> IO Text
readHandlePortably
readFileOrStdinPortably :: String -> IO Text
readFileOrStdinPortably :: String -> IO Text
readFileOrStdinPortably String
f = String -> IOMode -> IO Handle
openFileOrStdin String
f IOMode
ReadMode forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> IO Text
readHandlePortably
where
openFileOrStdin :: String -> IOMode -> IO Handle
openFileOrStdin :: String -> IOMode -> IO Handle
openFileOrStdin String
"-" IOMode
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdin
openFileOrStdin String
f' IOMode
m = String -> IOMode -> IO Handle
openFile String
f' IOMode
m
readHandlePortably :: Handle -> IO Text
readHandlePortably :: Handle -> IO Text
readHandlePortably Handle
h = do
Handle -> NewlineMode -> IO ()
hSetNewlineMode Handle
h NewlineMode
universalNewlineMode
Maybe TextEncoding
menc <- Handle -> IO (Maybe TextEncoding)
hGetEncoding Handle
h
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Show a => a -> String
show Maybe TextEncoding
menc forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just String
"UTF-8") forall a b. (a -> b) -> a -> b
$
Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8_bom
Handle -> IO Text
T.hGetContents Handle
h
embedFileRelative :: FilePath -> Q Exp
embedFileRelative :: String -> Q Exp
embedFileRelative String
f = String -> Q String
makeRelativeToProject String
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Q Exp
embedStringFile
getCurrentLocalTime :: IO LocalTime
getCurrentLocalTime :: IO LocalTime
getCurrentLocalTime = do
UTCTime
t <- IO UTCTime
getCurrentTime
TimeZone
tz <- IO TimeZone
getCurrentTimeZone
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TimeZone -> UTCTime -> LocalTime
utcToLocalTime TimeZone
tz UTCTime
t
getCurrentZonedTime :: IO ZonedTime
getCurrentZonedTime :: IO ZonedTime
getCurrentZonedTime = do
UTCTime
t <- IO UTCTime
getCurrentTime
TimeZone
tz <- IO TimeZone
getCurrentTimeZone
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TimeZone -> UTCTime -> ZonedTime
utcToZonedTime TimeZone
tz UTCTime
t