{- | 
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 #-}
{-# LANGUAGE MultiWayIf #-}

module Hledger.Utils.IO (

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

  -- * Errors
  error',
  usageError,
  warn,
  ansiFormatError,
  ansiFormatWarning,
  printError,
  exitWithErrorMessage,
  handleExit,

  -- * Time
  getCurrentLocalTime,
  getCurrentZonedTime,

  -- * Files
  getHomeSafe,
  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,
  findPager,
  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
import           Control.Monad (when, forM, guard, void)
import           Data.Char (toLower, isSpace)
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           Data.Text.Encoding.Error (UnicodeException)
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
import           Foreign.C.Error (Errno(..), ePIPE)
import           GHC.IO.Encoding (getLocaleEncoding, textEncodingName)
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, getProgName)
import           System.Exit (exitFailure)
import           System.FilePath (isRelative, (</>))
import "Glob"    System.FilePath.Glob (glob)
import           System.Info (os)
import           System.IO (Handle, IOMode (..), hClose, hGetEncoding, hIsTerminalDevice, hPutStr, hPutStrLn, hSetNewlineMode, hSetEncoding, openFile, stderr, stdin, stdout, universalNewlineMode, utf8_bom)
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 -> [Char]
pshow = Text -> [Char]
TL.unpack (Text -> [Char]) -> (a -> Text) -> a -> [Char]
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 -> [Char]
pshow' = Text -> [Char]
TL.unpack (Text -> [Char]) -> (a -> Text) -> a -> [Char]
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.
error' :: String -> a
error' :: forall a. [Char] -> a
error' = [Char] -> a
forall a. [Char] -> a
errorWithoutStackTrace ([Char] -> a) -> ([Char] -> [Char]) -> [Char] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"Error: "[Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>)

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

-- | Apply standard ANSI SGR formatting (red, bold) suitable for console error text.
ansiFormatError :: String -> String
ansiFormatError :: [Char] -> [Char]
ansiFormatError = ([Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
sgrresetall) ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char]
sgrbrightred [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
sgrbold) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>)

-- | Show a message, with "Warning:" label, on stderr before returning the given value.
-- Also do some ANSI styling of the first line when allowed (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. [Char] -> a -> a
warn [Char]
msg = [Char] -> a -> a
forall a. [Char] -> a -> a
trace [Char]
msg'
  where
    msg' :: [Char]
msg' =
      (if Bool
useColorOnStderrUnsafe then ([Char] -> [Char]) -> [Char] -> [Char]
modifyFirstLine [Char] -> [Char]
ansiFormatWarning else [Char] -> [Char]
forall a. a -> a
id) ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$
      [Char]
"Warning: "[Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
msg

-- | Apply standard ANSI SGR formatting (yellow, bold) suitable for console warning text.
ansiFormatWarning :: String -> String
ansiFormatWarning :: [Char] -> [Char]
ansiFormatWarning = ([Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
sgrresetall) ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char]
sgrbrightyellow [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
sgrbold) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>)

-- Transform a string's first line.
-- Note, this won't add a trailing newline if there isn't one,
-- and it will remove one if there is one or more.
modifyFirstLine :: (String -> String) -> String -> String
modifyFirstLine :: ([Char] -> [Char]) -> [Char] -> [Char]
modifyFirstLine [Char] -> [Char]
f [Char]
s = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
f [[Char]]
l [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
ls where ([[Char]]
l,[[Char]]
ls) = Int -> [[Char]] -> ([[Char]], [[Char]])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
1 ([[Char]] -> ([[Char]], [[Char]]))
-> [[Char]] -> ([[Char]], [[Char]])
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
lines [Char]
s  -- total

{- | Print an error message to stderr, with a consistent "programname: " prefix,
and applying ANSI styling (bold bright red) to the first line if that is supported and allowed.
-}
printError :: String -> IO ()
printError :: [Char] -> IO ()
printError [Char]
msg = do
  [Char]
progname <- IO [Char]
getProgName
  Bool
usecolor <- IO Bool
useColorOnStderr
  let
    style :: [Char] -> [Char]
style = if Bool
usecolor then ([Char] -> [Char]) -> [Char] -> [Char]
modifyFirstLine [Char] -> [Char]
ansiFormatError else [Char] -> [Char]
forall a. a -> a
id
    prefix :: [Char]
prefix =
      [Char]
progname
        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
": "
        -- error' prepends an "Error: " prefix. But that seems to have been removed when I catch the ErrorCall exception - unless I'm running in GHCI.
        -- Is it possible something in GHC or base is removing it ?
        -- Use a stupid heuristic for now: add it again unless already there.
        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> (if [Char]
"Error:" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
msg then [Char]
"" else [Char]
"Error: ")
  Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
style ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
prefix [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
msg

{- | Print an error message with printError,
then exit the program with a non-zero exit code.
-}
exitWithErrorMessage :: String -> IO ()
exitWithErrorMessage :: [Char] -> IO ()
exitWithErrorMessage [Char]
msg = [Char] -> IO ()
printError [Char]
msg IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitFailure

-- | This wraps a program's main routine so as to display more consistent,
-- useful, and GHC-version-independent error output when the program exits
-- because of certain common exceptions. It
--
-- 1. disables SIGPIPE errors, which are usually harmless,
--    caused when our output is truncated in a piped command.
--
-- 2. catches these common exceptions:
--
--    - UnicodeException, caused eg by text decoding errors in pure code
--
--    - IOException, caused by I/O errors, including text decoding errors during I/O
--
--    - ErrorCall - @error@ / @errorWithoutStackTrace@ calls
--
-- 3. compensates for GHC output bugs:
--
--    - removes the trailing newlines added by some GHC 9.10.* versions
--
--    - removes "uncaught exception" output added by some GHC 9.12.* versions
--
--    - ensures a consistent "PROGNAME: " prefix
--
-- 4. applies bold bright red ANSI styling to the first line of error output,
--    if that is supported and allowed
--
-- 5. for unicode exceptions and I/O exceptions which look like they were
--    unicode-related, it adds a message (in english) explaining the problem and what to do.
--
-- Some exceptions this does not catch are ExitCode (exitSuccess/exitFailure/exitWith)
-- and UserInterrupt (control-C).
--
handleExit :: IO () -> IO ()
handleExit :: IO () -> IO ()
handleExit = (IO () -> [Handler ()] -> IO ()) -> [Handler ()] -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> [Handler ()] -> IO ()
forall a. IO a -> [Handler a] -> IO a
catches [
   -- Handler (\(e::SomeException) -> error' $ pshow e),  -- debug
   (UnicodeException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(UnicodeException
e::UnicodeException) -> UnicodeException -> IO ()
forall e. Exception e => e -> IO ()
exitUnicode UnicodeException
e)
  ,(IOException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(IOException
e::IOException) -> if
    | IOException -> Bool
forall e. Exception e => e -> Bool
isUnicodeError IOException
e    -> IOException -> IO ()
forall e. Exception e => e -> IO ()
exitUnicode IOException
e
    | Bool
otherwise           -> IOException -> IO ()
forall e. Exception e => e -> IO ()
exitOther IOException
e)
  ,(ErrorCall -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(ErrorCall
e::ErrorCall) -> ErrorCall -> IO ()
forall e. Exception e => e -> IO ()
exitOther ErrorCall
e)
  ] (IO () -> IO ()) -> (IO () -> IO ()) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
ignoreSigPipe

  where
    -- | Ignore SIGPIPE errors.
    -- This is copied from System.Process.Internals in process 1.6.20.0+,
    -- since that version of process comes only with ghc 9.10.2+.
    ignoreSigPipe :: IO () -> IO ()
    ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe = (IOException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle ((IOException -> IO ()) -> IO () -> IO ())
-> (IOException -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ \IOException
e -> case IOException
e of
      IOError { ioe_type :: IOException -> IOErrorType
ioe_type  = IOErrorType
ResourceVanished
              , ioe_errno :: IOException -> Maybe CInt
ioe_errno = Just CInt
ioe }
        | CInt -> Errno
Errno CInt
ioe Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
ePIPE -> () -> 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

    -- Many decoding failures do not produce a UnicodeException, unfortunately.
    -- So this fragile hack detects them from the error message.
    -- But there are many variant wordings and they probably change over time.
    -- It's not ideal.
    isUnicodeError :: Exception e => e -> Bool
    isUnicodeError :: forall e. Exception e => e -> Bool
isUnicodeError e
ex =
      let msg :: [Char]
msg = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (e -> [Char]
forall a. Show a => a -> [Char]
show e
ex) in ([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
msg) [
          [Char]
"illegal byte sequence"
        , [Char]
"invalid byte sequence"
        , [Char]
"cannot decode byte sequence"
        , [Char]
"invalid character"
        , [Char]
"invalid or incomplete multibyte"
        , [Char]
"mkTextEncoding: invalid argument"
        ]

    exitUnicode :: Exception e => e -> IO ()
    exitUnicode :: forall e. Exception e => e -> IO ()
exitUnicode e
ex = do
      [Char]
enc <- IO [Char]
getSystemEncoding
      let
        noencoding :: Bool
noencoding = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
enc [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"ascii"
        msg :: [Char]
msg = [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [
            [Char] -> [Char]
rstrip ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ e -> [Char]
forall a. Show a => a -> [Char]
show e
ex
          , [Char]
"Some text could not be decoded with the system text encoding, " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
enc [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"."
          ] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++
          if Bool
noencoding
          then [
            [Char]
"Please configure a system locale which can decode this text."
          ]
          else [
            [Char]
"Please either convert the text to this encoding,"
          , [Char]
"or configure a system locale which can decode this text."
          ]
      [Char] -> IO ()
exitWithErrorMessage [Char]
msg

    exitOther :: Exception e => e -> IO ()
    exitOther :: forall e. Exception e => e -> IO ()
exitOther = [Char] -> IO ()
exitWithErrorMessage ([Char] -> IO ()) -> (e -> [Char]) -> e -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
rstrip ([Char] -> [Char]) -> (e -> [Char]) -> e -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> [Char]
forall a. Show a => a -> [Char]
show

    rstrip :: [Char] -> [Char]
rstrip = [Char] -> [Char]
forall a. [a] -> [a]
reverse ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
forall a. [a] -> [a]
reverse

-- I18n

-- encoding has a similar getSystemEncoding :: IO (Maybe DynEncoding)
-- but it returns Nothing on Windows or if there's an error.

-- | Get the name of the text encoding used by the current locale, using GHC's API.
getSystemEncoding :: IO String
getSystemEncoding :: IO [Char]
getSystemEncoding = do
  TextEncoding
localeEncoding <- IO TextEncoding
getLocaleEncoding
  [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ TextEncoding -> [Char]
textEncodingName TextEncoding
localeEncoding

-- -- | Get the name of the text encoding currently configured for stdout, using GHC's API.
-- getStdoutEncoding :: IO (Maybe String)
-- getStdoutEncoding = do
--   mEncoding <- hGetEncoding stdout
--   return $ fmap textEncodingName mEncoding

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

-- | Like getHomeDirectory, but in case of IO error (home directory not found, not understood, etc.), returns "".
getHomeSafe :: IO (Maybe FilePath)
getHomeSafe :: IO (Maybe [Char])
getHomeSafe = ([Char] -> Maybe [Char]) -> IO [Char] -> IO (Maybe [Char])
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just IO [Char]
getHomeDirectory IO (Maybe [Char])
-> (IOException -> IO (Maybe [Char])) -> IO (Maybe [Char])
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(IOException
_ :: IOException) -> Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Char]
forall a. Maybe a
Nothing)

-- | 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 :: [Char] -> IO [Char]
expandHomePath = \case
    (Char
'~':Char
'/':[Char]
p)  -> ([Char] -> [Char] -> [Char]
</> [Char]
p) ([Char] -> [Char]) -> IO [Char] -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Char]
getHomeDirectory
    (Char
'~':Char
'\\':[Char]
p) -> ([Char] -> [Char] -> [Char]
</> [Char]
p) ([Char] -> [Char]) -> IO [Char] -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Char]
getHomeDirectory
    (Char
'~':[Char]
_)      -> IOException -> IO [Char]
forall a. IOException -> IO a
ioError (IOException -> IO [Char]) -> IOException -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> IOException
userError [Char]
"~USERNAME in paths is not supported"
    [Char]
p            -> [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
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 :: [Char] -> [Char] -> IO [Char]
expandPath [Char]
_ [Char]
"-" = [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"-"
expandPath [Char]
curdir [Char]
p = (if [Char] -> Bool
isRelative [Char]
p then ([Char]
curdir [Char] -> [Char] -> [Char]
</>) else [Char] -> [Char]
forall a. a -> a
id) ([Char] -> [Char]) -> IO [Char] -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [Char]
expandHomePath [Char]
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 :: [Char] -> [Char] -> IO [[Char]]
expandGlob [Char]
curdir [Char]
p = [Char] -> [Char] -> IO [Char]
expandPath [Char]
curdir [Char]
p IO [Char] -> ([Char] -> IO [[Char]]) -> IO [[Char]]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> IO [[Char]]
glob IO [[Char]] -> ([[Char]] -> [[Char]]) -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [[Char]] -> [[Char]]
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 :: [[Char]] -> IO [[Char]]
sortByModTime [[Char]]
fs = do
  [(UTCTime, [Char])]
ftimes <- [[Char]]
-> ([Char] -> IO (UTCTime, [Char])) -> IO [(UTCTime, [Char])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Char]]
fs (([Char] -> IO (UTCTime, [Char])) -> IO [(UTCTime, [Char])])
-> ([Char] -> IO (UTCTime, [Char])) -> IO [(UTCTime, [Char])]
forall a b. (a -> b) -> a -> b
$ \[Char]
f -> do {UTCTime
t <- [Char] -> IO UTCTime
getModificationTime [Char]
f; (UTCTime, [Char]) -> IO (UTCTime, [Char])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
t,[Char]
f)}
  [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Char]] -> IO [[Char]]) -> [[Char]] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ ((UTCTime, [Char]) -> [Char]) -> [(UTCTime, [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (UTCTime, [Char]) -> [Char]
forall a b. (a, b) -> b
snd ([(UTCTime, [Char])] -> [[Char]])
-> [(UTCTime, [Char])] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ((UTCTime, [Char]) -> (UTCTime, [Char]) -> Ordering)
-> [(UTCTime, [Char])] -> [(UTCTime, [Char])]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((UTCTime, [Char]) -> Down (UTCTime, [Char]))
-> (UTCTime, [Char]) -> (UTCTime, [Char]) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (UTCTime, [Char]) -> Down (UTCTime, [Char])
forall a. a -> Down a
Data.Ord.Down) [(UTCTime, [Char])]
ftimes

-- | Like readFilePortably, but read all of the file before proceeding.
readFileStrictly :: FilePath -> IO T.Text
readFileStrictly :: [Char] -> IO Text
readFileStrictly [Char]
f = [Char] -> IO Text
readFilePortably [Char]
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 :: [Char] -> IO Text
readFilePortably [Char]
f =  [Char] -> IOMode -> IO Handle
openFile [Char]
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 :: [Char] -> IO Text
readFileOrStdinPortably = Maybe DynEncoding -> [Char] -> 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 -> [Char] -> IO Text
readFileOrStdinPortably' Maybe DynEncoding
c [Char]
f = [Char] -> IO Handle
openFileOrStdin [Char]
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

-- | Open a file for reading, using the standard System.IO.openFile.
-- This opens the handle in text mode, using the initial system locale's text encoding.
openFileOrStdin :: String -> IO Handle
openFileOrStdin :: [Char] -> IO Handle
openFileOrStdin [Char]
"-" = Handle -> IO Handle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdin
openFileOrStdin [Char]
f' = [Char] -> IOMode -> IO Handle
openFile [Char]
f' IOMode
ReadMode

-- readHandlePortably' with no text encoding specified.
readHandlePortably :: Handle -> IO T.Text
readHandlePortably :: Handle -> IO Text
readHandlePortably = Maybe DynEncoding -> Handle -> IO Text
readHandlePortably' Maybe DynEncoding
forall a. Maybe a
Nothing

-- | Read text from a handle with a specified encoding, using the encoding package.
-- Or if no encoding is specified, it uses the handle's current encoding,
-- after first changing it to UTF-8BOM if it was UTF-8, to allow a Byte Order Mark at the start.
-- Also it converts Windows line endings to newlines.
-- If decoding fails, this throws an IOException (or possibly a UnicodeException or something else from the encoding package).
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 -> [Char]) -> Maybe TextEncoding -> Maybe [Char]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TextEncoding -> [Char]
forall a. Show a => a -> [Char]
show Maybe TextEncoding
menc Maybe [Char] -> Maybe [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"UTF-8") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8_bom
  Handle -> IO Text
T.hGetContents Handle
h
readHandlePortably' (Just DynEncoding
e) Handle
h =
  -- convert newlines manually, because Enc.hGetContents uses bytestring's hGetContents
  HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\r\n" Text
"\n" (Text -> Text) -> ([Char] -> Text) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack ([Char] -> Text) -> IO [Char] -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> let ?enc = ?enc::DynEncoding
DynEncoding
e in Handle -> IO [Char]
forall e. (Encoding e, ?enc::e) => Handle -> IO [Char]
Enc.hGetContents Handle
h

-- | Create a handle from which the given text can be read.
-- Its encoding will be UTF-8BOM.
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
  -- use a separate thread so that we don't deadlock if we can't write all of the text at once
  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
T.hPutStr Handle
w Text
t 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
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 :: [Char] -> Q Exp
embedFileRelative [Char]
f = [Char] -> Q [Char]
makeRelativeToProject [Char]
f Q [Char] -> ([Char] -> 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
>>= [Char] -> 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 :: [[Char]]
progArgs = IO [[Char]] -> [[Char]]
forall a. IO a -> a
unsafePerformIO IO [[Char]]
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 :: [[Char]] -> IO (Maybe [Char])
getOpt [[Char]]
names = do
  [[Char]]
rargs <- [[Char]] -> [[Char]]
forall a. [a] -> [a]
reverse ([[Char]] -> [[Char]])
-> ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [[Char]]
splitFlagsAndVals ([[Char]] -> [[Char]]) -> IO [[Char]] -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [[Char]]
getArgs
  let flags :: [[Char]]
flags = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
toFlag [[Char]]
names
  Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> IO (Maybe [Char]))
-> Maybe [Char] -> IO (Maybe [Char])
forall a b. (a -> b) -> a -> b
$
    case ([Char] -> Bool) -> [[Char]] -> ([[Char]], [[Char]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (([Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
flags)) [[Char]]
rargs of
      ([[Char]]
_,[])        -> Maybe [Char]
forall a. Maybe a
Nothing
      ([],[Char]
flag:[[Char]]
_)   -> [Char] -> Maybe [Char]
forall a. [Char] -> a
error' ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
flag [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" requires a value"
      ([[Char]]
argsafter,[[Char]]
_) -> [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall a. HasCallStack => [a] -> a
last [[Char]]
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 :: [[Char]] -> [[Char]]
splitFlagsAndVals = ([Char] -> [[Char]]) -> [[Char]] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([Char] -> [[Char]]) -> [[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$
  \case
    a :: [Char]
a@(Char
'-':Char
'-':[Char]
_) | Char
'=' Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
a -> let ([Char]
x,[Char]
y) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'=') [Char]
a in [[Char]
x, Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
1 [Char]
y]
    a :: [Char]
a@(Char
'-':Char
f:Char
_:[Char]
_) | 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 -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take Int
2 [Char]
a, Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
2 [Char]
a]
    [Char]
a -> [[Char]
a]

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

-- | Parse y/yes/always or n/no/never to true or false, or return an error message.
parseYN :: String -> Either String Bool
parseYN :: [Char] -> Either [Char] Bool
parseYN [Char]
s
  | [Char]
l [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
"y",[Char]
"yes",[Char]
"always"] = Bool -> Either [Char] Bool
forall a b. b -> Either a b
Right Bool
True
  | [Char]
l [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
"n",[Char]
"no",[Char]
"never"]   = Bool -> Either [Char] Bool
forall a b. b -> Either a b
Right Bool
False
  | Bool
otherwise = [Char] -> Either [Char] Bool
forall a b. a -> Either a b
Left ([Char] -> Either [Char] Bool) -> [Char] -> Either [Char] Bool
forall a b. (a -> b) -> a -> b
$ [Char]
"value should be one of " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " [[Char]
"y",[Char]
"yes",[Char]
"n",[Char]
"no"])
  where l :: [Char]
l = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
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 -> [Char] -> [Char]
[YNA] -> [Char] -> [Char]
YNA -> [Char]
(Int -> YNA -> [Char] -> [Char])
-> (YNA -> [Char]) -> ([YNA] -> [Char] -> [Char]) -> Show YNA
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> YNA -> [Char] -> [Char]
showsPrec :: Int -> YNA -> [Char] -> [Char]
$cshow :: YNA -> [Char]
show :: YNA -> [Char]
$cshowList :: [YNA] -> [Char] -> [Char]
showList :: [YNA] -> [Char] -> [Char]
Show)

-- | Parse y/yes/always or n/no/never or a/auto to a YNA choice, or return an error message.
parseYNA :: String -> Either String YNA
parseYNA :: [Char] -> Either [Char] YNA
parseYNA [Char]
s
  | [Char]
l [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
"y",[Char]
"yes",[Char]
"always"] = YNA -> Either [Char] YNA
forall a b. b -> Either a b
Right YNA
Yes
  | [Char]
l [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
"n",[Char]
"no",[Char]
"never"]   = YNA -> Either [Char] YNA
forall a b. b -> Either a b
Right YNA
No
  | [Char]
l [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
"a",[Char]
"auto"]         = YNA -> Either [Char] YNA
forall a b. b -> Either a b
Right YNA
Auto
  | Bool
otherwise = [Char] -> Either [Char] YNA
forall a b. a -> Either a b
Left ([Char] -> Either [Char] YNA) -> [Char] -> Either [Char] YNA
forall a b. (a -> b) -> a -> b
$ [Char]
"value should be one of " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " [[Char]
"y",[Char]
"yes",[Char]
"n",[Char]
"no",[Char]
"a",[Char]
"auto"])
  where l :: [Char]
l = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
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 [Char]
mv <- [[Char]] -> IO (Maybe [Char])
getOpt [[Char]
"output-file",[Char]
"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 [Char]
mv of
      Maybe [Char]
Nothing  -> Bool
False
      Just [Char]
"-" -> Bool
False
      Maybe [Char]
_        -> 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 :: [Char]
deflessopts = [[Char]] -> [Char]
unwords [
       [Char]
"--chop-long-lines"
      ,[Char]
"--hilite-unread"
      ,[Char]
"--ignore-case"
      ,[Char]
"--mouse"
      ,[Char]
"--no-init"
      ,[Char]
"--quit-at-eof"
      ,[Char]
"--quit-if-one-screen"
      ,[Char]
"--RAW-CONTROL-CHARS"
      ,[Char]
"--shift=8"
      ,[Char]
"--squeeze-blank-lines"
      ,[Char]
"--use-backslash"
      -- ,"--use-color"  #2335 rejected by older less versions (eg 551)
      ]
  Maybe [Char]
mhledgerless <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"HLEDGER_LESS"
  Maybe [Char]
mless        <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"LESS"
  [Char] -> [Char] -> IO ()
setEnv [Char]
"LESS" ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
    case (Maybe [Char]
mhledgerless, Maybe [Char]
mless) of
      (Just [Char]
hledgerless, Maybe [Char]
_) -> [Char]
hledgerless
      (Maybe [Char]
_, Just [Char]
less)        -> if [Char]
deflessopts [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
less then [Char]
less else [[Char]] -> [Char]
unwords [[Char]
less, [Char]
deflessopts]
      (Maybe [Char], Maybe [Char])
_                     -> [Char]
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 :: [Char] -> IO ()
runPager [Char]
s = do
  Maybe [Char]
mpager <- [Char] -> IO (Maybe [Char])
maybePagerFor [Char]
s
  case Maybe [Char]
mpager of
    Maybe [Char]
Nothing -> [Char] -> IO ()
putStr [Char]
s
    Just [Char]
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 ([Char] -> CreateProcess
shell [Char]
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 -> [Char] -> IO ()
hPutStr Handle
hin [Char]
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.
-- Throws an error if the --pager option's value could not be parsed.
maybePagerFor :: String -> IO (Maybe String)
maybePagerFor :: [Char] -> IO (Maybe [Char])
maybePagerFor [Char]
output = do
  let
    ls :: [[Char]]
ls = [Char] -> [[Char]]
lines [Char]
output
    oh :: Int
oh = [[Char]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
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
$ ([Char] -> Int) -> [[Char]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
ls
    windows :: Bool
windows = [Char]
os [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"mingw32"
  Bool
pagerno    <- Bool -> ([Char] -> Bool) -> Maybe [Char] -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> Bool
not (Bool -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Bool) -> (Bool -> Bool) -> Either [Char] Bool -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> Bool
forall a. [Char] -> a
error' Bool -> Bool
forall a. a -> a
id (Either [Char] Bool -> Bool)
-> ([Char] -> Either [Char] Bool) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Either [Char] Bool
parseYN) (Maybe [Char] -> Bool) -> IO (Maybe [Char]) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]] -> IO (Maybe [Char])
getOpt [[Char]
"pager"]
  Bool
outputfile <- IO Bool
hasOutputFile
  Bool
emacsterm  <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"INSIDE_EMACS" IO (Maybe [Char]) -> (Maybe [Char] -> Bool) -> IO Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Maybe [Char] -> [Maybe [Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Maybe [Char]
forall a. Maybe a
Nothing, [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"vterm"])
  Maybe (Int, Int)
mhw        <- IO (Maybe (Int, Int))
getTerminalHeightWidth
  Maybe [Char]
mpager     <- IO (Maybe [Char])
findPager
  Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> IO (Maybe [Char]))
-> Maybe [Char] -> IO (Maybe [Char])
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 [Char]
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 [Char])
findPager = do
  Maybe [Char]
mpagervar <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"PAGER"
  let pagers :: [[Char]]
pagers = [[Char]
p | Just [Char]
p <- [Maybe [Char]
mpagervar]] [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]
"less", [Char]
"more"]
  [[Char]] -> Maybe [Char]
forall a. [a] -> Maybe a
headMay ([[Char]] -> Maybe [Char])
-> ([Maybe [Char]] -> [[Char]]) -> [Maybe [Char]] -> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe [Char]] -> [[Char]]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe [Char]] -> Maybe [Char])
-> IO [Maybe [Char]] -> IO (Maybe [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> IO (Maybe [Char])) -> [[Char]] -> IO [Maybe [Char]]
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 [Char] -> IO (Maybe [Char])
findExecutable [[Char]]
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.
-- Throws an error if the option's value could not be parsed.
colorOption :: IO YNA
colorOption :: IO YNA
colorOption = YNA -> ([Char] -> YNA) -> Maybe [Char] -> YNA
forall b a. b -> (a -> b) -> Maybe a -> b
maybe YNA
Auto (([Char] -> YNA) -> (YNA -> YNA) -> Either [Char] YNA -> YNA
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> YNA
forall a. [Char] -> a
error' YNA -> YNA
forall a. a -> a
id (Either [Char] YNA -> YNA)
-> ([Char] -> Either [Char] YNA) -> [Char] -> YNA
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Either [Char] YNA
parseYNA) (Maybe [Char] -> YNA) -> IO (Maybe [Char]) -> IO YNA
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]] -> IO (Maybe [Char])
getOpt [[Char]
"color",[Char]
"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 [Char] -> Bool
forall a. Maybe a -> Bool
isJust (Maybe [Char] -> Bool) -> IO (Maybe [Char]) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"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 :: [Char] -> [Char] -> [Char] -> [Char]
ansiWrapUnsafe [Char]
pre [Char]
post [Char]
s = if Bool
useColorOnStdoutUnsafe then [Char]
pre[Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>[Char]
s[Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>[Char]
post else [Char]
s

type SGRString = String

sgrbold :: [Char]
sgrbold          = [SGR] -> [Char]
setSGRCode [ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity]
sgrfaint :: [Char]
sgrfaint         = [SGR] -> [Char]
setSGRCode [ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
FaintIntensity]
sgrnormal :: [Char]
sgrnormal        = [SGR] -> [Char]
setSGRCode [ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
NormalIntensity]
sgrresetfg :: [Char]
sgrresetfg       = [SGR] -> [Char]
setSGRCode [ConsoleLayer -> SGR
SetDefaultColor ConsoleLayer
Foreground]
sgrresetbg :: [Char]
sgrresetbg       = [SGR] -> [Char]
setSGRCode [ConsoleLayer -> SGR
SetDefaultColor ConsoleLayer
Background]
sgrresetall :: [Char]
sgrresetall      = [Char]
sgrresetfg [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
sgrresetbg [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
sgrnormal
sgrblack :: [Char]
sgrblack         = [SGR] -> [Char]
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Black]
sgrred :: [Char]
sgrred           = [SGR] -> [Char]
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Red]
sgrgreen :: [Char]
sgrgreen         = [SGR] -> [Char]
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Green]
sgryellow :: [Char]
sgryellow        = [SGR] -> [Char]
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Yellow]
sgrblue :: [Char]
sgrblue          = [SGR] -> [Char]
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Blue]
sgrmagenta :: [Char]
sgrmagenta       = [SGR] -> [Char]
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Magenta]
sgrcyan :: [Char]
sgrcyan          = [SGR] -> [Char]
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Cyan]
sgrwhite :: [Char]
sgrwhite         = [SGR] -> [Char]
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
White]
sgrbrightblack :: [Char]
sgrbrightblack   = [SGR] -> [Char]
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Black]
sgrbrightred :: [Char]
sgrbrightred     = [SGR] -> [Char]
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Red]
sgrbrightgreen :: [Char]
sgrbrightgreen   = [SGR] -> [Char]
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Green]
sgrbrightyellow :: [Char]
sgrbrightyellow  = [SGR] -> [Char]
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Yellow]
sgrbrightblue :: [Char]
sgrbrightblue    = [SGR] -> [Char]
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Blue]
sgrbrightmagenta :: [Char]
sgrbrightmagenta = [SGR] -> [Char]
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Magenta]
sgrbrightcyan :: [Char]
sgrbrightcyan    = [SGR] -> [Char]
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Cyan]
sgrbrightwhite :: [Char]
sgrbrightwhite   = [SGR] -> [Char]
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
White]
sgrrgb :: Float -> Float -> Float -> [Char]
sgrrgb Float
r Float
g Float
b     = [SGR] -> [Char]
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' :: [Char] -> [Char]
bold'  = [Char] -> [Char] -> [Char] -> [Char]
ansiWrapUnsafe [Char]
sgrbold [Char]
sgrnormal

faint' :: String -> String
faint' :: [Char] -> [Char]
faint'  = [Char] -> [Char] -> [Char] -> [Char]
ansiWrapUnsafe [Char]
sgrfaint [Char]
sgrnormal

black' :: String -> String
black' :: [Char] -> [Char]
black'  = [Char] -> [Char] -> [Char] -> [Char]
ansiWrapUnsafe [Char]
sgrblack [Char]
sgrresetfg

red' :: String -> String
red' :: [Char] -> [Char]
red'  = [Char] -> [Char] -> [Char] -> [Char]
ansiWrapUnsafe [Char]
sgrred [Char]
sgrresetfg

green' :: String -> String
green' :: [Char] -> [Char]
green'  = [Char] -> [Char] -> [Char] -> [Char]
ansiWrapUnsafe [Char]
sgrgreen [Char]
sgrresetfg

yellow' :: String -> String
yellow' :: [Char] -> [Char]
yellow'  = [Char] -> [Char] -> [Char] -> [Char]
ansiWrapUnsafe [Char]
sgryellow [Char]
sgrresetfg

blue' :: String -> String
blue' :: [Char] -> [Char]
blue'  = [Char] -> [Char] -> [Char] -> [Char]
ansiWrapUnsafe [Char]
sgrblue [Char]
sgrresetfg

magenta' :: String -> String
magenta' :: [Char] -> [Char]
magenta'  = [Char] -> [Char] -> [Char] -> [Char]
ansiWrapUnsafe [Char]
sgrmagenta [Char]
sgrresetfg

cyan' :: String -> String
cyan' :: [Char] -> [Char]
cyan'  = [Char] -> [Char] -> [Char] -> [Char]
ansiWrapUnsafe [Char]
sgrcyan [Char]
sgrresetfg

white' :: String -> String
white' :: [Char] -> [Char]
white'  = [Char] -> [Char] -> [Char] -> [Char]
ansiWrapUnsafe [Char]
sgrwhite [Char]
sgrresetfg

brightBlack' :: String -> String
brightBlack' :: [Char] -> [Char]
brightBlack'  = [Char] -> [Char] -> [Char] -> [Char]
ansiWrapUnsafe [Char]
sgrbrightblack [Char]
sgrresetfg

brightRed' :: String -> String
brightRed' :: [Char] -> [Char]
brightRed'  = [Char] -> [Char] -> [Char] -> [Char]
ansiWrapUnsafe [Char]
sgrbrightred [Char]
sgrresetfg

brightGreen' :: String -> String
brightGreen' :: [Char] -> [Char]
brightGreen'  = [Char] -> [Char] -> [Char] -> [Char]
ansiWrapUnsafe [Char]
sgrbrightgreen [Char]
sgrresetfg

brightYellow' :: String -> String
brightYellow' :: [Char] -> [Char]
brightYellow'  = [Char] -> [Char] -> [Char] -> [Char]
ansiWrapUnsafe [Char]
sgrbrightyellow [Char]
sgrresetfg

brightBlue' :: String -> String
brightBlue' :: [Char] -> [Char]
brightBlue'  = [Char] -> [Char] -> [Char] -> [Char]
ansiWrapUnsafe [Char]
sgrbrightblue [Char]
sgrresetfg

brightMagenta' :: String -> String
brightMagenta' :: [Char] -> [Char]
brightMagenta'  = [Char] -> [Char] -> [Char] -> [Char]
ansiWrapUnsafe [Char]
sgrbrightmagenta [Char]
sgrresetfg

brightCyan' :: String -> String
brightCyan' :: [Char] -> [Char]
brightCyan'  = [Char] -> [Char] -> [Char] -> [Char]
ansiWrapUnsafe [Char]
sgrbrightcyan [Char]
sgrresetfg

brightWhite' :: String -> String
brightWhite' :: [Char] -> [Char]
brightWhite'  = [Char] -> [Char] -> [Char] -> [Char]
ansiWrapUnsafe [Char]
sgrbrightwhite [Char]
sgrresetfg

rgb' :: Float -> Float -> Float -> String -> String
rgb' :: Float -> Float -> Float -> [Char] -> [Char]
rgb' Float
r Float
g Float
b  = [Char] -> [Char] -> [Char] -> [Char]
ansiWrapUnsafe (Float -> Float -> Float -> [Char]
sgrrgb Float
r Float
g Float
b) [Char]
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 -> [Char] -> [Char]
color ColorIntensity
int Color
col [Char]
s = [SGR] -> [Char]
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
int Color
col] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [SGR] -> [Char]
setSGRCode []

-- | Wrap a string in ANSI codes to set and reset background colour.
bgColor :: ColorIntensity -> Color -> String -> String
bgColor :: ColorIntensity -> Color -> [Char] -> [Char]
bgColor ColorIntensity
int Color
col [Char]
s = [SGR] -> [Char]
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Background ColorIntensity
int Color
col] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [SGR] -> [Char]
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 ([Char] -> Builder
TB.fromString ([SGR] -> [Char]
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
<> [Char] -> Builder
TB.fromString ([SGR] -> [Char]
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 ([Char] -> Builder
TB.fromString ([SGR] -> [Char]
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
<> [Char] -> Builder
TB.fromString ([SGR] -> [Char]
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 [Char] -> Bool) -> Maybe [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Maybe [Char] -> Bool
forall a. Maybe a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Maybe [Char] -> Bool) -> IO (Maybe [Char]) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"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