{- | 
General and hledger-specific input/output-related helpers for
pretty-printing haskell values, error reporting, time, files, command line parsing,
terminals, pager output, ANSI colour/styles, etc.
-}

{-# LANGUAGE ImplicitParams      #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE PackageImports      #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Hledger.Utils.IO (

  -- * Pretty showing/printing
  pshow,
  pshow',
  pprint,
  pprint',

  -- * Errors
  error',
  usageError,
  warn,

  -- * Time
  getCurrentLocalTime,
  getCurrentZonedTime,

  -- * Files
  embedFileRelative,
  expandHomePath,
  expandPath,
  expandGlob,
  sortByModTime,
  openFileOrStdin,
  readFileOrStdinPortably,
  readFileOrStdinPortably',
  readFileStrictly,
  readFilePortably,
  readHandlePortably,
  readHandlePortably',
  -- hereFileRelative,
  inputToHandle,

  -- * Command line parsing
  progArgs,
  getOpt,
  parseYN,
  parseYNA,
  YNA(..),
  -- hasOutputFile,
  -- outputFileOption,

  -- * Terminal size
  getTerminalHeightWidth,
  getTerminalHeight,
  getTerminalWidth,

  -- * Pager output
  setupPager,
  runPager,

  -- * ANSI colour/styles

  -- ** hledger-specific

  colorOption,
  useColorOnStdout,
  useColorOnStderr,
  useColorOnStdoutUnsafe,
  useColorOnStderrUnsafe,
  bold',
  faint',
  black',
  red',
  green',
  yellow',
  blue',
  magenta',
  cyan',
  white',
  brightBlack',
  brightRed',
  brightGreen',
  brightYellow',
  brightBlue',
  brightMagenta',
  brightCyan',
  brightWhite',
  rgb',
  sgrresetall,

  -- ** Generic

  color,
  bgColor,
  colorB,
  bgColorB,
  -- XXX Types used with color/bgColor/colorB/bgColorB,
  -- not re-exported because clashing with UIUtils:
  -- Color(..),
  -- ColorIntensity(..),

  terminalIsLight,
  terminalLightness,
  terminalFgColor,
  terminalBgColor,

  )
where

import           Control.Concurrent (forkIO)
import           Control.Exception (catch, evaluate, throwIO)
import           Control.Monad (when, forM, guard, void)
import           Data.Char (toLower)
import           Data.Colour.RGBSpace (RGB(RGB))
import           Data.Colour.RGBSpace.HSL (lightness)
import           Data.Colour.SRGB (sRGB)
import           Data.Encoding (DynEncoding)
import           Data.FileEmbed (makeRelativeToProject, embedStringFile)
import           Data.Functor ((<&>))
import           Data.List hiding (uncons)
import           Data.Maybe (isJust, catMaybes)
import           Data.Ord (comparing, Down (Down))
import qualified Data.Text as T
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           Data.Word (Word16)
import           Debug.Trace (trace)
import           Foreign.C.Error (Errno(..), ePIPE)
import           GHC.IO.Exception (IOException(..), IOErrorType (ResourceVanished))
import           Language.Haskell.TH.Syntax (Q, Exp)
import           Safe (headMay, maximumDef)
import           System.Console.ANSI (Color(..),ColorIntensity(..), ConsoleLayer(..), SGR(..), hSupportsANSIColor, setSGRCode, getLayerColor, ConsoleIntensity (..))
import           System.Console.Terminal.Size (Window (Window), size)
import           System.Directory (getHomeDirectory, getModificationTime, findExecutable)
import           System.Environment (getArgs, lookupEnv, setEnv)
import           System.FilePath (isRelative, (</>))
import "Glob"    System.FilePath.Glob (glob)
import           System.Info (os)
import           System.IO (Handle, IOMode (..), hGetEncoding, hSetEncoding, hSetNewlineMode, openFile, stdin, stdout, stderr, universalNewlineMode, utf8_bom, hIsTerminalDevice, hPutStr, hClose)
import qualified System.IO.Encoding as Enc
import           System.IO.Unsafe (unsafePerformIO)
import           System.Process (CreateProcess(..), StdStream(CreatePipe), createPipe, shell, waitForProcess, withCreateProcess)
import           Text.Pretty.Simple (CheckColorTty(..), OutputOptions(..), defaultOutputOptionsDarkBg, defaultOutputOptionsNoColor, pShowOpt, pPrintOpt)

import Hledger.Utils.Text (WideBuilder(WideBuilder))



-- Pretty showing/printing
-- using pretty-simple

-- https://hackage.haskell.org/package/pretty-simple/docs/Text-Pretty-Simple.html#t:OutputOptions

-- | pretty-simple options with colour enabled if allowed.
prettyopts :: OutputOptions
prettyopts =
  (if Bool
useColorOnStderrUnsafe then OutputOptions
defaultOutputOptionsDarkBg else OutputOptions
defaultOutputOptionsNoColor)
    { outputOptionsIndentAmount = 2
    -- , outputOptionsCompact      = True  -- fills lines, but does not respect page width (https://github.com/cdepillabout/pretty-simple/issues/126)
    -- , outputOptionsPageWidth    = fromMaybe 80 $ unsafePerformIO getTerminalWidth
    }

-- | pretty-simple options with colour disabled.
prettyoptsNoColor :: OutputOptions
prettyoptsNoColor =
  OutputOptions
defaultOutputOptionsNoColor
    { outputOptionsIndentAmount=2
    }

-- | Pretty show. An easier alias for pretty-simple's pShow.
-- This will probably show in colour if useColorOnStderrUnsafe is true.
pshow :: Show a => a -> String
pshow :: forall a. Show a => a -> String
pshow = Text -> String
TL.unpack (Text -> String) -> (a -> Text) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutputOptions -> a -> Text
forall a. Show a => OutputOptions -> a -> Text
pShowOpt OutputOptions
prettyopts

-- | Monochrome version of pshow. This will never show in colour.
pshow' :: Show a => a -> String
pshow' :: forall a. Show a => a -> String
pshow' = Text -> String
TL.unpack (Text -> String) -> (a -> Text) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutputOptions -> a -> Text
forall a. Show a => OutputOptions -> a -> Text
pShowOpt OutputOptions
prettyoptsNoColor

-- | Pretty print a showable value. An easier alias for pretty-simple's pPrint.
-- This will print in colour if useColorOnStderrUnsafe is true.
pprint :: Show a => a -> IO ()
pprint :: forall a. Show a => a -> IO ()
pprint = CheckColorTty -> OutputOptions -> a -> IO ()
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
CheckColorTty -> OutputOptions -> a -> m ()
pPrintOpt (if Bool
useColorOnStderrUnsafe then CheckColorTty
CheckColorTty else CheckColorTty
NoCheckColorTty) OutputOptions
prettyopts

-- | Monochrome version of pprint. This will never print in colour.
pprint' :: Show a => a -> IO ()
pprint' :: forall a. Show a => a -> IO ()
pprint' = CheckColorTty -> OutputOptions -> a -> IO ()
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
CheckColorTty -> OutputOptions -> a -> m ()
pPrintOpt CheckColorTty
NoCheckColorTty OutputOptions
prettyoptsNoColor

-- "Avoid using pshow, pprint, dbg* in the code below to prevent infinite loops." (?)



-- Errors

-- | Call errorWithoutStackTrace, prepending a "Error:" label.
-- Also do some ANSI styling of the first line when allowed (using unsafe IO).
error' :: String -> a
error' :: forall a. String -> a
error' =
  if Bool
useColorOnStderrUnsafe
  then  -- color the program name as well
    IO (String -> a) -> String -> a
forall a. IO a -> a
unsafePerformIO (IO (String -> a) -> String -> a)
-> IO (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ do
      String -> IO ()
putStr String
fmt
      (String -> a) -> IO (String -> a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((String -> a) -> IO (String -> a))
-> (String -> a) -> IO (String -> a)
forall a b. (a -> b) -> a -> b
$ String -> a
forall a. String -> a
errorWithoutStackTrace (String -> a) -> (String -> String) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> String -> String
modifyFirstLine ((String -> String -> String
forall a. Semigroup a => a -> a -> a
<>String
sgrresetall) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
labelString -> String -> String
forall a. Semigroup a => a -> a -> a
<>))
  else
    String -> a
forall a. String -> a
errorWithoutStackTrace (String -> a) -> (String -> String) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> String -> String
modifyFirstLine (String
labelString -> String -> String
forall a. Semigroup a => a -> a -> a
<>)
  where
    label :: String
label = String
"Error: "
    fmt :: String
fmt = String
sgrbrightred String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
sgrbold

-- | Like error', but add a hint about using -h.
usageError :: String -> a
usageError :: forall a. String -> a
usageError = String -> a
forall a. String -> a
error' (String -> a) -> (String -> String) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (use -h to see usage)")

-- | Show a message, with "Warning:" label, on stderr before returning the given value.
-- Also do some ANSI styling of the first line when we detect that's supported (using unsafe IO).
-- Currently we use this very sparingly in hledger; we prefer to either quietly work,
-- or loudly raise an error. (Varying output can make scripting harder.)
warn :: String -> a -> a
warn :: forall a. String -> a -> a
warn String
msg = String -> a -> a
forall a. String -> a -> a
trace ((String -> String) -> String -> String
modifyFirstLine String -> String
f (String
label String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg))
  where
    label :: String
label = String
"Warning: "
    f :: String -> String
f = if Bool
useColorOnStderrUnsafe then ((String -> String -> String
forall a. Semigroup a => a -> a -> a
<>String
sgrresetall)(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(String
fmtString -> String -> String
forall a. Semigroup a => a -> a -> a
<>)) else String -> String
forall a. a -> a
id
      where
        fmt :: String
fmt = String
sgrbrightyellow String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
sgrbold

-- Transform a string's first line.
modifyFirstLine :: (String -> String) -> String -> String
modifyFirstLine String -> String
f String
s = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
f [String]
l [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
ls where ([String]
l,[String]
ls) = Int -> [String] -> ([String], [String])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
1 ([String] -> ([String], [String]))
-> [String] -> ([String], [String])
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
s  -- total

-- Time

getCurrentLocalTime :: IO LocalTime
getCurrentLocalTime :: IO LocalTime
getCurrentLocalTime = do
  UTCTime
t <- IO UTCTime
getCurrentTime
  TimeZone
tz <- IO TimeZone
getCurrentTimeZone
  LocalTime -> IO LocalTime
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalTime -> IO LocalTime) -> LocalTime -> IO LocalTime
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
  ZonedTime -> IO ZonedTime
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ZonedTime -> IO ZonedTime) -> ZonedTime -> IO ZonedTime
forall a b. (a -> b) -> a -> b
$ TimeZone -> UTCTime -> ZonedTime
utcToZonedTime TimeZone
tz UTCTime
t



-- Files

-- | Expand a tilde (representing home directory) at the start of a file path.
-- ~username is not supported. Can raise an error.
expandHomePath :: FilePath -> IO FilePath
expandHomePath :: String -> IO String
expandHomePath = \case
    (Char
'~':Char
'/':String
p)  -> (String -> String -> String
</> String
p) (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getHomeDirectory
    (Char
'~':Char
'\\':String
p) -> (String -> String -> String
</> String
p) (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getHomeDirectory
    (Char
'~':String
_)      -> IOException -> IO String
forall a. IOException -> IO a
ioError (IOException -> IO String) -> IOException -> IO String
forall a b. (a -> b) -> a -> b
$ String -> IOException
userError String
"~USERNAME in paths is not supported"
    String
p            -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
p

-- | Given a current directory, convert a possibly relative, possibly tilde-containing
-- file path to an absolute one.
-- ~username is not supported. Leaves "-" 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
"-" = String -> IO String
forall a. a -> IO a
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 String -> String
forall a. a -> a
id) (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
expandHomePath String
p  -- PARTIAL:

-- | Like expandPath, but treats the expanded path as a glob, and returns
-- zero or more matched absolute file paths, alphabetically sorted.
-- Can raise an error.
expandGlob :: FilePath -> FilePath -> IO [FilePath]
expandGlob :: String -> String -> IO [String]
expandGlob String
curdir String
p = String -> String -> IO String
expandPath String
curdir String
p IO String -> (String -> IO [String]) -> IO [String]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO [String]
glob IO [String] -> ([String] -> [String]) -> IO [String]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [String] -> [String]
forall a. Ord a => [a] -> [a]
sort  -- PARTIAL:

-- | Given a list of existing file paths, sort them by modification time, most recent first.
sortByModTime :: [FilePath] -> IO [FilePath]
sortByModTime :: [String] -> IO [String]
sortByModTime [String]
fs = do
  [(UTCTime, String)]
ftimes <- [String]
-> (String -> IO (UTCTime, String)) -> IO [(UTCTime, String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
fs ((String -> IO (UTCTime, String)) -> IO [(UTCTime, String)])
-> (String -> IO (UTCTime, String)) -> IO [(UTCTime, String)]
forall a b. (a -> b) -> a -> b
$ \String
f -> do {UTCTime
t <- String -> IO UTCTime
getModificationTime String
f; (UTCTime, String) -> IO (UTCTime, String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
t,String
f)}
  [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ ((UTCTime, String) -> String) -> [(UTCTime, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (UTCTime, String) -> String
forall a b. (a, b) -> b
snd ([(UTCTime, String)] -> [String])
-> [(UTCTime, String)] -> [String]
forall a b. (a -> b) -> a -> b
$ ((UTCTime, String) -> (UTCTime, String) -> Ordering)
-> [(UTCTime, String)] -> [(UTCTime, String)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((UTCTime, String) -> Down (UTCTime, String))
-> (UTCTime, String) -> (UTCTime, String) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (UTCTime, String) -> Down (UTCTime, String)
forall a. a -> Down a
Data.Ord.Down) [(UTCTime, String)]
ftimes

-- | Like readFilePortably, but read all of the file before proceeding.
readFileStrictly :: FilePath -> IO T.Text
readFileStrictly :: String -> IO Text
readFileStrictly String
f = String -> IO Text
readFilePortably String
f IO Text -> (Text -> IO Text) -> IO Text
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
t -> Int -> IO Int
forall a. a -> IO a
evaluate (Text -> Int
T.length Text
t) IO Int -> IO Text -> IO Text
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> IO Text
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
t

-- | 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 T.Text
readFilePortably :: String -> IO Text
readFilePortably String
f =  String -> IOMode -> IO Handle
openFile String
f IOMode
ReadMode IO Handle -> (Handle -> IO Text) -> IO Text
forall a b. IO a -> (a -> IO b) -> IO b
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 T.Text
readFileOrStdinPortably :: String -> IO Text
readFileOrStdinPortably = Maybe DynEncoding -> String -> IO Text
readFileOrStdinPortably' Maybe DynEncoding
forall a. Maybe a
Nothing

-- | Like readFileOrStdinPortably, but take an optional converter.
readFileOrStdinPortably' :: Maybe DynEncoding -> String -> IO T.Text
readFileOrStdinPortably' :: Maybe DynEncoding -> String -> IO Text
readFileOrStdinPortably' Maybe DynEncoding
c String
f = String -> IO Handle
openFileOrStdin String
f IO Handle -> (Handle -> IO Text) -> IO Text
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe DynEncoding -> Handle -> IO Text
readHandlePortably' Maybe DynEncoding
c

openFileOrStdin :: String -> IO Handle
openFileOrStdin :: String -> IO Handle
openFileOrStdin String
"-" = Handle -> IO Handle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdin
openFileOrStdin String
f' = String -> IOMode -> IO Handle
openFile String
f' IOMode
ReadMode

readHandlePortably :: Handle -> IO T.Text
readHandlePortably :: Handle -> IO Text
readHandlePortably = Maybe DynEncoding -> Handle -> IO Text
readHandlePortably' Maybe DynEncoding
forall a. Maybe a
Nothing

readHandlePortably' :: Maybe DynEncoding -> Handle -> IO T.Text
readHandlePortably' :: Maybe DynEncoding -> Handle -> IO Text
readHandlePortably' Maybe DynEncoding
Nothing Handle
h = do
  Handle -> NewlineMode -> IO ()
hSetNewlineMode Handle
h NewlineMode
universalNewlineMode
  Maybe TextEncoding
menc <- Handle -> IO (Maybe TextEncoding)
hGetEncoding Handle
h
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((TextEncoding -> String) -> Maybe TextEncoding -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TextEncoding -> String
forall a. Show a => a -> String
show Maybe TextEncoding
menc Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
"UTF-8") (IO () -> IO ()) -> IO () -> IO ()
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
readHandlePortably' (Just DynEncoding
e) Handle
h =
  -- We need to manually apply the newline mode
  -- Since we already have a Text
  HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\r\n" Text
"\n" (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> IO String -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> let ?enc = ?enc::DynEncoding
DynEncoding
e in Handle -> IO String
forall e. (Encoding e, ?enc::e) => Handle -> IO String
Enc.hGetContents Handle
h

inputToHandle :: T.Text -> IO Handle
inputToHandle :: Text -> IO Handle
inputToHandle Text
t = do
  (Handle
r, Handle
w) <- IO (Handle, Handle)
createPipe
  Handle -> TextEncoding -> IO ()
hSetEncoding Handle
r TextEncoding
utf8_bom
  Handle -> TextEncoding -> IO ()
hSetEncoding Handle
w TextEncoding
utf8_bom
  Handle -> Text -> IO ()
T.hPutStr Handle
w Text
t
  Handle -> IO ()
hClose Handle
w
  Handle -> IO Handle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
r

-- | Like embedFile, but takes a path relative to the package directory.
embedFileRelative :: FilePath -> Q Exp
embedFileRelative :: String -> Q Exp
embedFileRelative String
f = String -> Q String
makeRelativeToProject String
f Q String -> (String -> Q Exp) -> Q Exp
forall a b. Q a -> (a -> Q b) -> Q b
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



-- Command line parsing

-- | The program's command line arguments.
-- Uses unsafePerformIO; tends to stick in GHCI until reloaded,
-- and may or may not detect args provided by a hledger config file.
{-# NOINLINE progArgs #-}
progArgs :: [String]
progArgs :: [String]
progArgs = IO [String] -> [String]
forall a. IO a -> a
unsafePerformIO IO [String]
getArgs
-- XX currently this affects:
--  the enabling of orderdates and assertions checks in journalFinalise
--  a few cases involving --color (see useColorOnStdoutUnsafe)
--  --debug

-- | Given one or more long or short option names, read the rightmost value of this option from the command line arguments.
-- If the value is missing raise an error.
-- Concatenated short flags (-a -b written as -ab) are not supported.
getOpt :: [String] -> IO (Maybe String)
getOpt :: [String] -> IO (Maybe String)
getOpt [String]
names = do
  [String]
rargs <- [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
splitFlagsAndVals ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String]
getArgs
  let flags :: [String]
flags = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
toFlag [String]
names
  Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$
    case (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
flags)) [String]
rargs of
      ([String]
_,[])        -> Maybe String
forall a. Maybe a
Nothing
      ([],String
flag:[String]
_)   -> String -> Maybe String
forall a. String -> a
error' (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
flag String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" requires a value"
      ([String]
argsafter,[String]
_) -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. HasCallStack => [a] -> a
last [String]
argsafter

-- | Given a list of command line arguments, split any of the form --flag=VAL or -fVAL into two list items.
-- Concatenated short flags (-a -b written as -ab) are not supported.
splitFlagsAndVals :: [String] -> [String]
splitFlagsAndVals :: [String] -> [String]
splitFlagsAndVals = (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String -> [String]) -> [String] -> [String])
-> (String -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
  \case
    a :: String
a@(Char
'-':Char
'-':String
_) | Char
'=' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
a -> let (String
x,String
y) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'=') String
a in [String
x, Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 String
y]
    a :: String
a@(Char
'-':Char
f:Char
_:String
_) | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char
fChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'-' -> [Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
2 String
a, Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
2 String
a]
    String
a -> [String
a]

-- | Convert a short or long flag name to a flag with leading hyphen(s).
toFlag :: String -> String
toFlag [Char
c] = [Char
'-',Char
c]
toFlag String
s   = Char
'-'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
'-'Char -> String -> String
forall a. a -> [a] -> [a]
:String
s

-- | Parse y/yes/always or n/no/never to true or false, or with any other value raise an error.
parseYN :: String -> Bool
parseYN :: String -> Bool
parseYN String
s
  | String
l String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"y",String
"yes",String
"always"] = Bool
True
  | String
l String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"n",String
"no",String
"never"]   = Bool
False
  | Bool
otherwise = String -> Bool
forall a. String -> a
error' (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
"value should be one of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String
"y",String
"yes",String
"n",String
"no"])
  where l :: String
l = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s

data YNA = Yes | No | Auto deriving (YNA -> YNA -> Bool
(YNA -> YNA -> Bool) -> (YNA -> YNA -> Bool) -> Eq YNA
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: YNA -> YNA -> Bool
== :: YNA -> YNA -> Bool
$c/= :: YNA -> YNA -> Bool
/= :: YNA -> YNA -> Bool
Eq,Int -> YNA -> String -> String
[YNA] -> String -> String
YNA -> String
(Int -> YNA -> String -> String)
-> (YNA -> String) -> ([YNA] -> String -> String) -> Show YNA
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> YNA -> String -> String
showsPrec :: Int -> YNA -> String -> String
$cshow :: YNA -> String
show :: YNA -> String
$cshowList :: [YNA] -> String -> String
showList :: [YNA] -> String -> String
Show)

-- | Parse y/yes/always or n/no/never or a/auto to a YNA choice, or with any other value raise an error.
parseYNA :: String -> YNA
parseYNA :: String -> YNA
parseYNA String
s
  | String
l String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"y",String
"yes",String
"always"] = YNA
Yes
  | String
l String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"n",String
"no",String
"never"]   = YNA
No
  | String
l String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"a",String
"auto"]         = YNA
Auto
  | Bool
otherwise = String -> YNA
forall a. String -> a
error' (String -> YNA) -> String -> YNA
forall a b. (a -> b) -> a -> b
$ String
"value should be one of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String
"y",String
"yes",String
"n",String
"no",String
"a",String
"auto"])
  where l :: String
l = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s

-- | Is there a --output-file or -o option in the command line arguments ?
-- Uses getOpt; sticky in GHCI until reloaded, may not always be affected by a hledger config file, etc.
hasOutputFile :: IO Bool
hasOutputFile :: IO Bool
hasOutputFile = do
  Maybe String
mv <- [String] -> IO (Maybe String)
getOpt [String
"output-file",String
"o"]
  Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
    case Maybe String
mv of
      Maybe String
Nothing  -> Bool
False
      Just String
"-" -> Bool
False
      Maybe String
_        -> Bool
True

-- -- | Get the -o/--output-file option's value, if any, from the command line arguments.
-- -- Uses getOpt; sticky in GHCI until reloaded, may not always be affected by a hledger config file, etc.
-- outputFileOption :: IO (Maybe String)
-- outputFileOption = getOpt ["output-file","o"]



-- Terminal size

-- [NOTE: Alternative methods of getting the terminal size]
-- terminal-size uses the TIOCGWINSZ ioctl to get the window size on Unix
-- systems, which may not be completely portable according to people in
-- #linux@liberachat.
--
-- If this turns out to be the case, supplementary coverage can be given by
-- using the terminfo package.
--
-- Conversely, terminfo on its own is not a full solution, firstly because it
-- only works on Unix (not Windows), and secondly since in some scenarios (eg
-- stripped-down build systems) the terminfo database may be limited and lack
-- the correct entries. (A hack that sometimes works but which isn't robust
-- enough to be relied upon is to set TERM=dumb -- while this advice does appear
-- in some places, it's not guaranteed to work)
--
-- In any case, $LINES/$COLUMNS should not be used as a source for the terminal
-- size - they are not available or do not update reliably in all shells.
--
-- See #2332 for details

-- | An alternative to ansi-terminal's getTerminalSize, based on
-- the more robust-looking terminal-size package.
--
-- Tries to get stdout's terminal's current height and width.
getTerminalHeightWidth :: IO (Maybe (Int,Int))
getTerminalHeightWidth :: IO (Maybe (Int, Int))
getTerminalHeightWidth = (Maybe (Window Int) -> Maybe (Int, Int))
-> IO (Maybe (Window Int)) -> IO (Maybe (Int, Int))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Window Int -> (Int, Int))
-> Maybe (Window Int) -> Maybe (Int, Int)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Window Int -> (Int, Int)
forall {b}. Window b -> (b, b)
unwindow) IO (Maybe (Window Int))
forall n. Integral n => IO (Maybe (Window n))
size
  where unwindow :: Window b -> (b, b)
unwindow (Window b
h b
w) = (b
h,b
w)

getTerminalHeight :: IO (Maybe Int)
getTerminalHeight :: IO (Maybe Int)
getTerminalHeight = ((Int, Int) -> Int) -> Maybe (Int, Int) -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Int) -> Int
forall a b. (a, b) -> a
fst (Maybe (Int, Int) -> Maybe Int)
-> IO (Maybe (Int, Int)) -> IO (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe (Int, Int))
getTerminalHeightWidth

getTerminalWidth :: IO (Maybe Int)
getTerminalWidth :: IO (Maybe Int)
getTerminalWidth  = ((Int, Int) -> Int) -> Maybe (Int, Int) -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Int) -> Int
forall a b. (a, b) -> b
snd (Maybe (Int, Int) -> Maybe Int)
-> IO (Maybe (Int, Int)) -> IO (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe (Int, Int))
getTerminalHeightWidth



-- Pager output
-- somewhat hledger-specific

-- Configure some preferred options for the `less` pager,
-- by modifying the LESS environment variable in this program's environment.
-- If you are using some other pager, this will have no effect.
-- By default, this sets the following options, appending them to LESS's current value:
--
--   --chop-long-lines
--   --hilite-unread
--   --ignore-case
--   --mouse
--   --no-init
--   --quit-at-eof
--   --quit-if-one-screen
--   --RAW-CONTROL-CHARS
--   --shift=8
--   --squeeze-blank-lines
--   --use-backslash
--
-- You can choose different options by setting the HLEDGER_LESS variable;
-- if set, its value will be used instead of LESS.
-- Or you can force hledger to use your exact LESS settings,
-- by setting HLEDGER_LESS equal to LESS.
--
setupPager :: IO ()
setupPager :: IO ()
setupPager = do
  let
    -- keep synced with doc above
    deflessopts :: String
deflessopts = [String] -> String
unwords [
       String
"--chop-long-lines"
      ,String
"--hilite-unread"
      ,String
"--ignore-case"
      ,String
"--mouse"
      ,String
"--no-init"
      ,String
"--quit-at-eof"
      ,String
"--quit-if-one-screen"
      ,String
"--RAW-CONTROL-CHARS"
      ,String
"--shift=8"
      ,String
"--squeeze-blank-lines"
      ,String
"--use-backslash"
      -- ,"--use-color"  #2335 rejected by older less versions (eg 551)
      ]
  Maybe String
mhledgerless <- String -> IO (Maybe String)
lookupEnv String
"HLEDGER_LESS"
  Maybe String
mless        <- String -> IO (Maybe String)
lookupEnv String
"LESS"
  String -> String -> IO ()
setEnv String
"LESS" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
    case (Maybe String
mhledgerless, Maybe String
mless) of
      (Just String
hledgerless, Maybe String
_) -> String
hledgerless
      (Maybe String
_, Just String
less)        -> [String] -> String
unwords [String
less, String
deflessopts]
      (Maybe String, Maybe String)
_                     -> String
deflessopts

-- | Display the given text on the terminal, trying to use a pager ($PAGER, less, or more)
-- when appropriate, otherwise printing to standard output. Uses maybePagerFor.
--
-- hledger's output may contain ANSI style/color codes
-- (if the terminal supports them and they are not disabled by --color=no or NO_COLOR),
-- so the pager should be configured to handle these.
-- setupPager tries to configure that automatically when using the `less` pager.
--
runPager :: String -> IO ()
runPager :: String -> IO ()
runPager String
s = do
  Maybe String
mpager <- String -> IO (Maybe String)
maybePagerFor String
s
  case Maybe String
mpager of
    Maybe String
Nothing -> String -> IO ()
putStr String
s
    Just String
pager -> do
      CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
-> IO ()
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess (String -> CreateProcess
shell String
pager){std_in=CreatePipe} ((Maybe Handle
  -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
 -> IO ())
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$
        \Maybe Handle
mhin Maybe Handle
_ Maybe Handle
_ ProcessHandle
p -> do
          -- Pipe in the text on stdin.
          case Maybe Handle
mhin of
            Maybe Handle
Nothing  -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- shouldn't happen
            Just Handle
hin -> IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$   -- Write from another thread to avoid deadlock ? Maybe unneeded, but just in case.
              (Handle -> String -> IO ()
hPutStr Handle
hin String
s IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
hin)  -- Be sure to close the pipe so the pager knows we're done.
                -- If the pager quits early, we'll receive an EPIPE error; hide that.
                IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
e::IOException) -> case IOException
e of
                  IOError{ioe_type :: IOException -> IOErrorType
ioe_type=IOErrorType
ResourceVanished, ioe_errno :: IOException -> Maybe CInt
ioe_errno=Just CInt
ioe, ioe_handle :: IOException -> Maybe Handle
ioe_handle=Just Handle
hdl} | CInt -> Errno
Errno CInt
ioeErrno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
==Errno
ePIPE, Handle
hdlHandle -> Handle -> Bool
forall a. Eq a => a -> a -> Bool
==Handle
hin
                    -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  IOException
_ -> IOException -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOException
e
          IO ExitCode -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ExitCode -> IO ()) -> IO ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
p

-- | Should a pager be used for displaying the given text on stdout, and if so, which one ?
-- Uses a pager if findPager finds one and none of the following conditions are true:
-- We're running in a native MS Windows environment like cmd or powershell.
-- Or the --pager=n|no option is in effect.
-- Or the -o/--output-file option is in effect.
-- Or INSIDE_EMACS is set, to something other than "vterm".
-- Or the terminal's current height and width can't be detected.
-- Or the output text is less wide and less tall than the terminal.
maybePagerFor :: String -> IO (Maybe String)
maybePagerFor :: String -> IO (Maybe String)
maybePagerFor String
output = do
  let
    ls :: [String]
ls = String -> [String]
lines String
output
    oh :: Int
oh = [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ls
    ow :: Int
ow = Int -> [Int] -> Int
forall a. Ord a => a -> [a] -> a
maximumDef Int
0 ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ls
    windows :: Bool
windows = String
os String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"mingw32"
  Bool
pagerno    <- Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> Bool
not(Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> Bool
parseYN) (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> IO (Maybe String)
getOpt [String
"pager"]
  Bool
outputfile <- IO Bool
hasOutputFile
  Bool
emacsterm  <- String -> IO (Maybe String)
lookupEnv String
"INSIDE_EMACS" IO (Maybe String) -> (Maybe String -> Bool) -> IO Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Maybe String -> [Maybe String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Maybe String
forall a. Maybe a
Nothing, String -> Maybe String
forall a. a -> Maybe a
Just String
"vterm"])
  Maybe (Int, Int)
mhw        <- IO (Maybe (Int, Int))
getTerminalHeightWidth
  Maybe String
mpager     <- IO (Maybe String)
findPager
  Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bool
windows Bool -> Bool -> Bool
|| Bool
pagerno Bool -> Bool -> Bool
|| Bool
outputfile Bool -> Bool -> Bool
|| Bool
emacsterm
    (Int
th,Int
tw) <- Maybe (Int, Int)
mhw
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Int
oh Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
th Bool -> Bool -> Bool
|| Int
ow Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
tw
    Maybe String
mpager

-- | Try to find a pager executable robustly, safely handling various error conditions
-- like an unset PATH var or the specified pager not being found as an executable.
-- The pager can be specified by a path or program name in the PAGER environment variable.
-- If that is unset or has a problem, "less" is tried, then "more".
-- If successful, the pager's path or program name is returned.
findPager :: IO (Maybe String)  -- XXX probably a ByteString in fact ?
findPager :: IO (Maybe String)
findPager = do
  Maybe String
mpagervar <- String -> IO (Maybe String)
lookupEnv String
"PAGER"
  let pagers :: [String]
pagers = [String
p | Just String
p <- [Maybe String
mpagervar]] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
"less", String
"more"]
  [String] -> Maybe String
forall a. [a] -> Maybe a
headMay ([String] -> Maybe String)
-> ([Maybe String] -> [String]) -> [Maybe String] -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe String] -> Maybe String)
-> IO [Maybe String] -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO (Maybe String)) -> [String] -> IO [Maybe String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IO (Maybe String)
findExecutable [String]
pagers



-- ANSI colour/styles
-- Some of these use unsafePerformIO to read info.

-- hledger-specific:

-- | Get the value of the rightmost --color or --colour option from the program's command line arguments.
colorOption :: IO YNA
colorOption :: IO YNA
colorOption = YNA -> (String -> YNA) -> Maybe String -> YNA
forall b a. b -> (a -> b) -> Maybe a -> b
maybe YNA
Auto String -> YNA
parseYNA (Maybe String -> YNA) -> IO (Maybe String) -> IO YNA
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> IO (Maybe String)
getOpt [String
"color",String
"colour"]

-- | Should ANSI color and styles be used with this output handle ?
-- Considers colorOption, the NO_COLOR environment variable, and hSupportsANSIColor.
useColorOnHandle :: Handle -> IO Bool
useColorOnHandle :: Handle -> IO Bool
useColorOnHandle Handle
h = do
  Bool
no_color       <- Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
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
  YNA
yna            <- IO YNA
colorOption
  Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ YNA
ynaYNA -> YNA -> Bool
forall a. Eq a => a -> a -> Bool
==YNA
Yes Bool -> Bool -> Bool
|| (YNA
ynaYNA -> YNA -> Bool
forall a. Eq a => a -> a -> Bool
==YNA
Auto Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
no_color Bool -> Bool -> Bool
&& Bool
supports_color)

-- | Should ANSI color and styles be used for standard output ?
-- Considers useColorOnHandle stdout and hasOutputFile.
useColorOnStdout :: IO Bool
useColorOnStdout :: IO Bool
useColorOnStdout = do
  Bool
nooutputfile <- Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Bool
hasOutputFile
  Bool
usecolor <- Handle -> IO Bool
useColorOnHandle Handle
stdout
  Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool
nooutputfile Bool -> Bool -> Bool
&& Bool
usecolor

-- | Should ANSI color and styles be used for standard error output ?
-- Considers useColorOnHandle stderr; is not affected by an --output-file option.
useColorOnStderr :: IO Bool
useColorOnStderr :: IO Bool
useColorOnStderr = Handle -> IO Bool
useColorOnHandle Handle
stderr

-- | Like useColorOnStdout, but using unsafePerformIO. Useful eg for low-level debug code.
-- Sticky in GHCI until reloaded, may not always be affected by --color in a hledger config file, etc.
useColorOnStdoutUnsafe :: Bool
useColorOnStdoutUnsafe :: Bool
useColorOnStdoutUnsafe = IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO IO Bool
useColorOnStdout

-- | Like useColorOnStdoutUnsafe, but for stderr.
useColorOnStderrUnsafe :: Bool
useColorOnStderrUnsafe :: Bool
useColorOnStderrUnsafe = IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO IO Bool
useColorOnStderr

-- | Detect whether ANSI should be used on stdout using useColorOnStdoutUnsafe,
-- and if so prepend and append the given SGR codes to a string.
-- Currently used in a few places (the commands list, the demo command, the recentassertions error message);
-- see useColorOnStdoutUnsafe's limitations.
ansiWrapUnsafe :: SGRString -> SGRString -> String -> String
ansiWrapUnsafe :: String -> String -> String -> String
ansiWrapUnsafe String
pre String
post String
s = if Bool
useColorOnStdoutUnsafe then String
preString -> String -> String
forall a. Semigroup a => a -> a -> a
<>String
sString -> String -> String
forall a. Semigroup a => a -> a -> a
<>String
post else String
s

type SGRString = String

sgrbold :: String
sgrbold          = [SGR] -> String
setSGRCode [ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity]
sgrfaint :: String
sgrfaint         = [SGR] -> String
setSGRCode [ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
FaintIntensity]
sgrnormal :: String
sgrnormal        = [SGR] -> String
setSGRCode [ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
NormalIntensity]
sgrresetfg :: String
sgrresetfg       = [SGR] -> String
setSGRCode [ConsoleLayer -> SGR
SetDefaultColor ConsoleLayer
Foreground]
sgrresetbg :: String
sgrresetbg       = [SGR] -> String
setSGRCode [ConsoleLayer -> SGR
SetDefaultColor ConsoleLayer
Background]
sgrresetall :: String
sgrresetall      = String
sgrresetfg String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
sgrresetbg String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
sgrnormal
sgrblack :: String
sgrblack         = [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Black]
sgrred :: String
sgrred           = [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Red]
sgrgreen :: String
sgrgreen         = [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Green]
sgryellow :: String
sgryellow        = [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Yellow]
sgrblue :: String
sgrblue          = [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Blue]
sgrmagenta :: String
sgrmagenta       = [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Magenta]
sgrcyan :: String
sgrcyan          = [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Cyan]
sgrwhite :: String
sgrwhite         = [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
White]
sgrbrightblack :: String
sgrbrightblack   = [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Black]
sgrbrightred :: String
sgrbrightred     = [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Red]
sgrbrightgreen :: String
sgrbrightgreen   = [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Green]
sgrbrightyellow :: String
sgrbrightyellow  = [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Yellow]
sgrbrightblue :: String
sgrbrightblue    = [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Blue]
sgrbrightmagenta :: String
sgrbrightmagenta = [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Magenta]
sgrbrightcyan :: String
sgrbrightcyan    = [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Cyan]
sgrbrightwhite :: String
sgrbrightwhite   = [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
White]
sgrrgb :: Float -> Float -> Float -> String
sgrrgb Float
r Float
g Float
b     = [SGR] -> String
setSGRCode [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground (Colour Float -> SGR) -> Colour Float -> SGR
forall a b. (a -> b) -> a -> b
$ Float -> Float -> Float -> Colour Float
forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB Float
r Float
g Float
b]

-- | Set various ANSI styles/colours in a string, only if useColorOnStdoutUnsafe says we should.
bold' :: String -> String
bold' :: String -> String
bold'  = String -> String -> String -> String
ansiWrapUnsafe String
sgrbold String
sgrnormal

faint' :: String -> String
faint' :: String -> String
faint'  = String -> String -> String -> String
ansiWrapUnsafe String
sgrfaint String
sgrnormal

black' :: String -> String
black' :: String -> String
black'  = String -> String -> String -> String
ansiWrapUnsafe String
sgrblack String
sgrresetfg

red' :: String -> String
red' :: String -> String
red'  = String -> String -> String -> String
ansiWrapUnsafe String
sgrred String
sgrresetfg

green' :: String -> String
green' :: String -> String
green'  = String -> String -> String -> String
ansiWrapUnsafe String
sgrgreen String
sgrresetfg

yellow' :: String -> String
yellow' :: String -> String
yellow'  = String -> String -> String -> String
ansiWrapUnsafe String
sgryellow String
sgrresetfg

blue' :: String -> String
blue' :: String -> String
blue'  = String -> String -> String -> String
ansiWrapUnsafe String
sgrblue String
sgrresetfg

magenta' :: String -> String
magenta' :: String -> String
magenta'  = String -> String -> String -> String
ansiWrapUnsafe String
sgrmagenta String
sgrresetfg

cyan' :: String -> String
cyan' :: String -> String
cyan'  = String -> String -> String -> String
ansiWrapUnsafe String
sgrcyan String
sgrresetfg

white' :: String -> String
white' :: String -> String
white'  = String -> String -> String -> String
ansiWrapUnsafe String
sgrwhite String
sgrresetfg

brightBlack' :: String -> String
brightBlack' :: String -> String
brightBlack'  = String -> String -> String -> String
ansiWrapUnsafe String
sgrbrightblack String
sgrresetfg

brightRed' :: String -> String
brightRed' :: String -> String
brightRed'  = String -> String -> String -> String
ansiWrapUnsafe String
sgrbrightred String
sgrresetfg

brightGreen' :: String -> String
brightGreen' :: String -> String
brightGreen'  = String -> String -> String -> String
ansiWrapUnsafe String
sgrbrightgreen String
sgrresetfg

brightYellow' :: String -> String
brightYellow' :: String -> String
brightYellow'  = String -> String -> String -> String
ansiWrapUnsafe String
sgrbrightyellow String
sgrresetfg

brightBlue' :: String -> String
brightBlue' :: String -> String
brightBlue'  = String -> String -> String -> String
ansiWrapUnsafe String
sgrbrightblue String
sgrresetfg

brightMagenta' :: String -> String
brightMagenta' :: String -> String
brightMagenta'  = String -> String -> String -> String
ansiWrapUnsafe String
sgrbrightmagenta String
sgrresetfg

brightCyan' :: String -> String
brightCyan' :: String -> String
brightCyan'  = String -> String -> String -> String
ansiWrapUnsafe String
sgrbrightcyan String
sgrresetfg

brightWhite' :: String -> String
brightWhite' :: String -> String
brightWhite'  = String -> String -> String -> String
ansiWrapUnsafe String
sgrbrightwhite String
sgrresetfg

rgb' :: Float -> Float -> Float -> String -> String
rgb' :: Float -> Float -> Float -> String -> String
rgb' Float
r Float
g Float
b  = String -> String -> String -> String
ansiWrapUnsafe (Float -> Float -> Float -> String
sgrrgb Float
r Float
g Float
b) String
sgrresetfg

-- Generic:

-- | Wrap a string in ANSI codes to set and reset foreground colour.
-- ColorIntensity is @Dull@ or @Vivid@ (ie normal and bold).
-- Color is one of @Black@, @Red@, @Green@, @Yellow@, @Blue@, @Magenta@, @Cyan@, @White@.
-- Eg: @color Dull Red "text"@.
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] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
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] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
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]) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
s Builder -> Builder -> Builder
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]) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
TB.fromString ([SGR] -> String
setSGRCode [])) Int
w


-- | Detect whether the terminal currently has a light background colour,
-- if possible, using unsafePerformIO.
-- If the terminal is transparent, its apparent light/darkness may be different.
terminalIsLight :: Maybe Bool
terminalIsLight :: Maybe Bool
terminalIsLight = (Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0.5) (Float -> Bool) -> Maybe Float -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Float
terminalLightness

-- | Detect the terminal's current background lightness (0..1), if possible, using unsafePerformIO.
-- If the terminal is transparent, its apparent lightness may be different.
terminalLightness :: Maybe Float
terminalLightness :: Maybe Float
terminalLightness = RGB Float -> Float
forall a. (Fractional a, Ord a) => RGB a -> a
lightness (RGB Float -> Float) -> Maybe (RGB Float) -> Maybe Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConsoleLayer -> Maybe (RGB Float)
terminalColor ConsoleLayer
Background

-- | Detect the terminal's current background colour, if possible, using unsafePerformIO.
terminalBgColor :: Maybe (RGB Float)
terminalBgColor :: Maybe (RGB Float)
terminalBgColor = ConsoleLayer -> Maybe (RGB Float)
terminalColor ConsoleLayer
Background

-- | Detect the terminal's current foreground colour, if possible, using unsafePerformIO.
terminalFgColor :: Maybe (RGB Float)
terminalFgColor :: Maybe (RGB Float)
terminalFgColor = ConsoleLayer -> Maybe (RGB Float)
terminalColor ConsoleLayer
Foreground

-- | Detect the terminal's current foreground or background colour, if possible, using unsafePerformIO.
{-# NOINLINE terminalColor #-}
terminalColor :: ConsoleLayer -> Maybe (RGB Float)
terminalColor :: ConsoleLayer -> Maybe (RGB Float)
terminalColor = IO (Maybe (RGB Float)) -> Maybe (RGB Float)
forall a. IO a -> a
unsafePerformIO (IO (Maybe (RGB Float)) -> Maybe (RGB Float))
-> (ConsoleLayer -> IO (Maybe (RGB Float)))
-> ConsoleLayer
-> Maybe (RGB Float)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConsoleLayer -> IO (Maybe (RGB Float))
getLayerColor'

-- A version of ansi-terminal's getLayerColor that is less likely to leak escape sequences to output,
-- and that returns a RGB of Floats (0..1) that is more compatible with the colour package.
-- This does nothing in a non-interactive context (eg when piping stdout to another command),
-- inside emacs (emacs shell buffers show the escape sequence for some reason),
-- or in a non-colour-supporting terminal.
getLayerColor' :: ConsoleLayer -> IO (Maybe (RGB Float))
getLayerColor' :: ConsoleLayer -> IO (Maybe (RGB Float))
getLayerColor' ConsoleLayer
l = do
  Bool
inemacs       <- Bool -> Bool
not(Bool -> Bool) -> (Maybe String -> Bool) -> Maybe String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Maybe String -> Bool
forall a. Maybe a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"INSIDE_EMACS"
  Bool
interactive   <- Handle -> IO Bool
hIsTerminalDevice Handle
stdout
  Bool
supportscolor <- Handle -> IO Bool
hSupportsANSIColor Handle
stdout
  if Bool
inemacs Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
interactive Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
supportscolor then Maybe (RGB Float) -> IO (Maybe (RGB Float))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (RGB Float)
forall a. Maybe a
Nothing
  else (RGB Word16 -> RGB Float)
-> Maybe (RGB Word16) -> Maybe (RGB Float)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RGB Word16 -> RGB Float
forall a. Fractional a => RGB Word16 -> RGB a
fractionalRGB (Maybe (RGB Word16) -> Maybe (RGB Float))
-> IO (Maybe (RGB Word16)) -> IO (Maybe (RGB Float))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConsoleLayer -> IO (Maybe (RGB Word16))
getLayerColor ConsoleLayer
l
  where
    fractionalRGB :: (Fractional a) => RGB Word16 -> RGB a
    fractionalRGB :: forall a. Fractional a => RGB Word16 -> RGB a
fractionalRGB (RGB Word16
r Word16
g Word16
b) = a -> a -> a -> RGB a
forall a. a -> a -> a -> RGB a
RGB (Word16 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
r a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
65535) (Word16 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
g a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
65535) (Word16 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
b a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
65535)  -- chatgpt