{- | 
Helpers for pretty-printing haskell values, reading command line arguments,
working with ANSI colours, files, and time.
Uses unsafePerformIO.

Limitations:
When running in GHCI, this module must be reloaded to see environmental changes.
The colour scheme may be somewhat hard-coded.

-}

{-# LANGUAGE CPP, LambdaCase, PackageImports #-}

module Hledger.Utils.IO (

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

  -- * Viewing with pager
  pager,
  setupPager,

  -- * Terminal size
  getTerminalHeightWidth,
  getTerminalHeight,
  getTerminalWidth,

  -- * Command line arguments
  progArgs,
  outputFileOption,
  hasOutputFile,

  -- * ANSI color
  colorOption,
  useColorOnStdout,
  useColorOnStderr,
  -- XXX needed for using color/bgColor/colorB/bgColorB, but clashing with UIUtils:
  -- Color(..),
  -- ColorIntensity(..),
  color,
  bgColor,
  colorB,
  bgColorB,
  --
  bold',
  faint',
  black',
  red',
  green',
  yellow',
  blue',
  magenta',
  cyan',
  white',
  brightBlack',
  brightRed',
  brightGreen',
  brightYellow',
  brightBlue',
  brightMagenta',
  brightCyan',
  brightWhite',
  rgb',
  terminalIsLight,
  terminalLightness,
  terminalFgColor,
  terminalBgColor,

  -- * Errors
  error',
  usageError,

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

  -- * Time
  getCurrentLocalTime,
  getCurrentZonedTime,

  )
where

import qualified Control.Exception as C (evaluate)
import           Control.Monad (when, forM)
import           Data.Colour.RGBSpace (RGB(RGB))
import           Data.Colour.RGBSpace.HSL (lightness)
import           Data.FileEmbed (makeRelativeToProject, embedStringFile)
import           Data.List hiding (uncons)
import           Data.Maybe (isJust)
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 (Word8, Word16)
import           Language.Haskell.TH.Syntax (Q, Exp)
import           String.ANSI
import           System.Console.ANSI (Color(..),ColorIntensity(..),
  ConsoleLayer(..), SGR(..), hSupportsANSIColor, setSGRCode, getLayerColor)
import           System.Console.Terminal.Size (Window (Window), size)
import           System.Directory (getHomeDirectory, getModificationTime)
import           System.Environment (getArgs, lookupEnv, setEnv)
import           System.FilePath (isRelative, (</>))
import           System.IO
  (Handle, IOMode (..), hGetEncoding, hSetEncoding, hSetNewlineMode,
   openFile, stdin, stdout, stderr, universalNewlineMode, utf8_bom, hIsTerminalDevice)
import           System.IO.Unsafe (unsafePerformIO)
#ifndef mingw32_HOST_OS
import           System.Pager (printOrPage)
#endif
import           Text.Pretty.Simple
  (CheckColorTty(..), OutputOptions(..),
  defaultOutputOptionsDarkBg, defaultOutputOptionsNoColor, pShowOpt, pPrintOpt)

import Hledger.Utils.Text (WideBuilder(WideBuilder))
import "Glob" System.FilePath.Glob (glob)
import Data.Functor ((<&>))

-- Pretty showing/printing with 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
useColorOnStderr 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 useColorOnStderr 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 useColorOnStderr 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
useColorOnStderr 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." (?)

-- | Display the given text on the terminal, using the user's $PAGER if the text is taller 
-- than the current terminal and stdout is interactive and TERM is not "dumb"
-- (except on Windows, where a pager will not be used).
-- If the text contains ANSI codes, because hledger thinks the current terminal
-- supports those, the pager should be configured to display those, otherwise
-- users will see junk on screen (#2015).
-- We call "setLessR" at hledger startup to make that less likely.
pager :: String -> IO ()
#ifdef mingw32_HOST_OS
pager = putStrLn
#else
printOrPage' :: String -> IO ()
printOrPage' String
s = do  -- an extra check for Emacs users:
  Bool
dumbterm <- (Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
"dumb") (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
"TERM"
  if Bool
dumbterm then String -> IO ()
putStrLn String
s else Text -> IO ()
printOrPage (String -> Text
T.pack String
s)
pager :: String -> IO ()
pager = String -> IO ()
printOrPage'
#endif

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

-- | Make sure our $LESS and $MORE environment variables contain R,
-- to help ensure the common pager `less` will show our ANSI output properly.
-- less uses $LESS by default, and $MORE when it is invoked as `more`.
-- What the original `more` program does, I'm not sure.
-- If $PAGER is configured to something else, this probably will have no effect.
setupPager :: IO ()
setupPager :: IO ()
setupPager = do
  let
    addR :: String -> IO ()
addR String
var = do
      Maybe String
mv <- String -> IO (Maybe String)
lookupEnv String
var
      String -> String -> IO ()
setEnv String
var (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ case Maybe String
mv of
        Maybe String
Nothing -> String
"R"
        Just String
v  -> (Char
'R'Char -> String -> String
forall a. a -> [a] -> [a]
:String
v)
  String -> IO ()
addR String
"LESS"
  String -> IO ()
addR String
"MORE"

-- Command line arguments

-- | The command line arguments that were used at program startup.
-- Uses unsafePerformIO.
{-# NOINLINE progArgs #-}
progArgs :: [String]
progArgs :: [String]
progArgs = IO [String] -> [String]
forall a. IO a -> a
unsafePerformIO IO [String]
getArgs

-- | Read the value of the -o/--output-file command line option provided at program startup,
-- if any, using unsafePerformIO.
outputFileOption :: Maybe String
outputFileOption :: Maybe String
outputFileOption = 
  -- keep synced with output-file flag definition in hledger:CliOptions.
  let args :: [String]
args = [String]
progArgs in
  case (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"-o" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)) [String]
args of
    -- -oARG
    (Char
'-':Char
'o':v :: String
v@(Char
_:String
_)):[String]
_ -> String -> Maybe String
forall a. a -> Maybe a
Just String
v
    -- -o ARG
    String
"-o":String
v:[String]
_ -> String -> Maybe String
forall a. a -> Maybe a
Just String
v
    [String]
_ ->
      case (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=String
"--output-file") [String]
args of
        -- --output-file ARG
        String
"--output-file":String
v:[String]
_ -> String -> Maybe String
forall a. a -> Maybe a
Just String
v
        [String]
_ ->
          case Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
1 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--output-file=" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
args of
            -- --output=file=ARG
            [Char
'-':Char
'-':Char
'o':Char
'u':Char
't':Char
'p':Char
'u':Char
't':Char
'-':Char
'f':Char
'i':Char
'l':Char
'e':Char
'=':String
v] -> String -> Maybe String
forall a. a -> Maybe a
Just String
v
            [String]
_ -> Maybe String
forall a. Maybe a
Nothing

-- | Check whether the -o/--output-file option has been used at program startup
-- with an argument other than "-", using unsafePerformIO.
hasOutputFile :: Bool
hasOutputFile :: Bool
hasOutputFile = Maybe String
outputFileOption 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
"-"]
-- XXX shouldn't we check that stdout is interactive. instead ?

-- ANSI colour

ifAnsi :: (a -> a) -> a -> a
ifAnsi a -> a
f = if Bool
useColorOnStdout then a -> a
f else a -> a
forall a. a -> a
id

-- | Versions of some of text-ansi's string colors/styles which are more careful
-- to not print junk onscreen. These use our useColorOnStdout.
bold' :: String -> String
bold' :: String -> String
bold'  = (String -> String) -> String -> String
forall {a}. (a -> a) -> a -> a
ifAnsi String -> String
bold

faint' :: String -> String
faint' :: String -> String
faint'  = (String -> String) -> String -> String
forall {a}. (a -> a) -> a -> a
ifAnsi String -> String
faint

black' :: String -> String
black' :: String -> String
black'  = (String -> String) -> String -> String
forall {a}. (a -> a) -> a -> a
ifAnsi String -> String
black

red' :: String -> String
red' :: String -> String
red'  = (String -> String) -> String -> String
forall {a}. (a -> a) -> a -> a
ifAnsi String -> String
red

green' :: String -> String
green' :: String -> String
green'  = (String -> String) -> String -> String
forall {a}. (a -> a) -> a -> a
ifAnsi String -> String
green

yellow' :: String -> String
yellow' :: String -> String
yellow'  = (String -> String) -> String -> String
forall {a}. (a -> a) -> a -> a
ifAnsi String -> String
yellow

blue' :: String -> String
blue' :: String -> String
blue'  = (String -> String) -> String -> String
forall {a}. (a -> a) -> a -> a
ifAnsi String -> String
blue

magenta' :: String -> String
magenta' :: String -> String
magenta'  = (String -> String) -> String -> String
forall {a}. (a -> a) -> a -> a
ifAnsi String -> String
magenta

cyan' :: String -> String
cyan' :: String -> String
cyan'  = (String -> String) -> String -> String
forall {a}. (a -> a) -> a -> a
ifAnsi String -> String
cyan

white' :: String -> String
white' :: String -> String
white'  = (String -> String) -> String -> String
forall {a}. (a -> a) -> a -> a
ifAnsi String -> String
white

brightBlack' :: String -> String
brightBlack' :: String -> String
brightBlack'  = (String -> String) -> String -> String
forall {a}. (a -> a) -> a -> a
ifAnsi String -> String
brightBlack

brightRed' :: String -> String
brightRed' :: String -> String
brightRed'  = (String -> String) -> String -> String
forall {a}. (a -> a) -> a -> a
ifAnsi String -> String
brightRed

brightGreen' :: String -> String
brightGreen' :: String -> String
brightGreen'  = (String -> String) -> String -> String
forall {a}. (a -> a) -> a -> a
ifAnsi String -> String
brightGreen

brightYellow' :: String -> String
brightYellow' :: String -> String
brightYellow'  = (String -> String) -> String -> String
forall {a}. (a -> a) -> a -> a
ifAnsi String -> String
brightYellow

brightBlue' :: String -> String
brightBlue' :: String -> String
brightBlue'  = (String -> String) -> String -> String
forall {a}. (a -> a) -> a -> a
ifAnsi String -> String
brightBlue

brightMagenta' :: String -> String
brightMagenta' :: String -> String
brightMagenta'  = (String -> String) -> String -> String
forall {a}. (a -> a) -> a -> a
ifAnsi String -> String
brightMagenta

brightCyan' :: String -> String
brightCyan' :: String -> String
brightCyan'  = (String -> String) -> String -> String
forall {a}. (a -> a) -> a -> a
ifAnsi String -> String
brightCyan

brightWhite' :: String -> String
brightWhite' :: String -> String
brightWhite'  = (String -> String) -> String -> String
forall {a}. (a -> a) -> a -> a
ifAnsi String -> String
brightWhite

rgb' :: Word8 -> Word8 -> Word8 -> String -> String
rgb' :: Word8 -> Word8 -> Word8 -> String -> String
rgb' Word8
r Word8
g Word8
b  = (String -> String) -> String -> String
forall {a}. (a -> a) -> a -> a
ifAnsi (Word8 -> Word8 -> Word8 -> String -> String
rgb Word8
r Word8
g Word8
b)

-- | Read the value of the --color or --colour command line option provided at program startup
-- using unsafePerformIO. If this option was not provided, returns the empty string.
colorOption :: String
colorOption :: String
colorOption = 
  -- similar to debugLevel
  -- keep synced with color/colour flag definition in hledger:CliOptions
  let args :: [String]
args = [String]
progArgs in
  case (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=String
"--color") [String]
args of
    -- --color ARG
    String
"--color":String
v:[String]
_ -> String
v
    [String]
_ ->
      case Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
1 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--color=" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
args of
        -- --color=ARG
        [Char
'-':Char
'-':Char
'c':Char
'o':Char
'l':Char
'o':Char
'r':Char
'=':String
v] -> String
v
        [String]
_ ->
          case (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=String
"--colour") [String]
args of
            -- --colour ARG
            String
"--colour":String
v:[String]
_ -> String
v
            [String]
_ ->
              case Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
1 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--colour=" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
args of
                -- --colour=ARG
                [Char
'-':Char
'-':Char
'c':Char
'o':Char
'l':Char
'o':Char
'u':Char
'r':Char
'=':String
v] -> String
v
                [String]
_ -> String
""

-- | Check the IO environment to see if ANSI colour codes should be used on stdout.
-- This is done using unsafePerformIO so it can be used anywhere, eg in
-- low-level debug utilities, which should be ok since we are just reading.
-- The logic is: use color if
-- the program was started with --color=yes|always
-- or (
--   the program was not started with --color=no|never
--   and a NO_COLOR environment variable is not defined
--   and stdout supports ANSI color
--   and -o/--output-file was not used, or its value is "-"
-- ).
useColorOnStdout :: Bool
useColorOnStdout :: Bool
useColorOnStdout = Bool -> Bool
not Bool
hasOutputFile Bool -> Bool -> Bool
&& Handle -> Bool
useColorOnHandle Handle
stdout

-- | Like useColorOnStdout, but checks for ANSI color support on stderr,
-- and is not affected by -o/--output-file.
useColorOnStderr :: Bool
useColorOnStderr :: Bool
useColorOnStderr = Handle -> Bool
useColorOnHandle Handle
stderr

useColorOnHandle :: Handle -> Bool
useColorOnHandle :: Handle -> Bool
useColorOnHandle Handle
h = IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$ 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
  let coloroption :: String
coloroption = String
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
$ String
coloroption String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"always",String
"yes"]
       Bool -> Bool -> Bool
|| (String
coloroption String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
"never",String
"no"] Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
no_color Bool -> Bool -> Bool
&& Bool
supports_color)

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

-- Errors

-- | Simpler alias for errorWithoutStackTrace
error' :: String -> a
error' :: forall a. String -> a
error' = String -> a
forall a. String -> a
errorWithoutStackTrace (String -> a) -> (String -> String) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>)

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

-- 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
_)      -> IOError -> IO String
forall a. IOError -> IO a
ioError (IOError -> IO String) -> IOError -> IO String
forall a b. (a -> b) -> a -> b
$ String -> IOError
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)]
forall a. [a] -> [a]
reverse ([(UTCTime, String)] -> [(UTCTime, String)])
-> [(UTCTime, String)] -> [(UTCTime, String)]
forall a b. (a -> b) -> a -> b
$ [(UTCTime, String)] -> [(UTCTime, String)]
forall a. Ord a => [a] -> [a]
sort [(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
C.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 String
f = String -> IOMode -> IO Handle
openFileOrStdin 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
  where
    openFileOrStdin :: String -> IOMode -> IO Handle
    openFileOrStdin :: String -> IOMode -> IO Handle
openFileOrStdin String
"-" IOMode
_ = Handle -> IO Handle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdin
    openFileOrStdin String
f' IOMode
m   = String -> IOMode -> IO Handle
openFile String
f' IOMode
m

readHandlePortably :: Handle -> IO T.Text
readHandlePortably :: Handle -> IO Text
readHandlePortably Handle
h = do
  Handle -> NewlineMode -> IO ()
hSetNewlineMode Handle
h NewlineMode
universalNewlineMode
  Maybe TextEncoding
menc <- Handle -> IO (Maybe TextEncoding)
hGetEncoding Handle
h
  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

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

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