{- | 
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 :: OutputOptions
prettyopts = 
  (if Bool
useColorOnStderr then OutputOptions
defaultOutputOptionsDarkBg else OutputOptions
defaultOutputOptionsNoColor)
    { outputOptionsIndentAmount :: Int
outputOptionsIndentAmount=Int
2
    , outputOptionsCompact :: Bool
outputOptionsCompact=Bool
True
    }

-- | pretty-simple options with colour disabled.
prettyopts' :: OutputOptions
prettyopts' =
  OutputOptions
defaultOutputOptionsNoColor
    { outputOptionsIndentAmount :: Int
outputOptionsIndentAmount=Int
2
    , outputOptionsCompact :: Bool
outputOptionsCompact=Bool
True
    }

-- | Pretty show. Easier alias for pretty-simple's pShow.
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

-- | Monochrome version of pshow.
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'

-- | Pretty print. Easier alias for pretty-simple's pPrint.
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

-- | Monochrome version of pprint.
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'

-- "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 :: [String]
progArgs = forall a. IO a -> a
unsafePerformIO IO [String]
getArgs

-- | Read the value of the -o/--output-file command line option provided at program startup,
-- if any, using unsafePerformIO.
outputFileOption :: Maybe String
outputFileOption :: Maybe String
outputFileOption = 
  -- keep synced with output-file flag definition in hledger:CliOptions.
  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
    -- -oARG
    (Char
'-':Char
'o':v :: String
v@(Char
_:String
_)):[String]
_ -> forall a. a -> Maybe a
Just String
v
    -- -o ARG
    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
        -- --output-file ARG
        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
            -- --output=file=ARG
            [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

-- | Check whether the -o/--output-file option has been used at program startup
-- with an argument other than "-", using unsafePerformIO.
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
"-"]

-- 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 :: String
colorOption = 
  -- similar to debugLevel
  -- keep synced with color/colour flag definition in hledger:CliOptions
  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
    -- --color ARG
    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
        -- --color=ARG
        [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
            -- --colour ARG
            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
                -- --colour=ARG
                [Char
'-':Char
'-':Char
'c':Char
'o':Char
'l':Char
'o':Char
'u':Char
'r':Char
'=':String
v] -> String
v
                [String]
_ -> String
""

-- | 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 :: Bool
useColorOnStdout = Bool -> Bool
not Bool
hasOutputFile Bool -> Bool -> Bool
&& Handle -> Bool
useColorOnHandle Handle
stdout

-- | Like useColorOnStdout, but checks for ANSI color support on stderr,
-- and is not affected by -o/--output-file.
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)

-- | Wrap a string in ANSI codes to set and reset foreground colour.
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 []

-- | Wrap a string in ANSI codes to set and reset background colour.
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 []

-- | Wrap a WideBuilder in ANSI codes to set and reset foreground colour.
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

-- | Wrap a WideBuilder in ANSI codes to set and reset background colour.
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

-- Errors

-- | Simpler alias for errorWithoutStackTrace
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
<>)

-- | A version of errorWithoutStackTrace that adds a usage hint.
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)")

-- 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 :: 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
-- PARTIAL:

-- | Expand user home path indicated by tilde prefix
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

-- | 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 :: 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

-- | Like readFilePortably, but read from standard input if the path is "-".
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
$  -- XXX no Eq instance, rely on Show
    Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8_bom
  Handle -> IO Text
T.hGetContents Handle
h

-- | Like embedFile, but takes a path relative to the package directory.
-- Similar to embedFileRelative ?
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

-- -- | 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 :: 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