{- |
Module                  : Iris.Colour.Mode
Copyright               : 2022 Dmitrii Kovanikov
SPDX-License-Identifier : MPL-2.0
Maintainer              : Dmitrii Kovanikov <kovanikov@gmail.com>
Stability               : Experimental
Portability             : Portable

The 'ColourMode' data type that allows disabling and enabling of
colouring.

@since 0.0.0.0
-}
module Iris.Colour.Mode (
    ColourMode (..),
    detectColourMode,

    -- * Internal
    handleColourMode,
) where

import Data.Char (toLower, toUpper)
import Data.Maybe (isJust)
import System.Console.ANSI (hSupportsANSIColor)
import System.Environment (lookupEnv)
import System.IO (Handle)

import Iris.Cli.Colour (ColourOption (..))

{- | Data type that tells whether the colouring is enabled or
disabled. Its value is detected automatically on application start and
stored in 'Iris.Env.CliEnv'.

@since 0.0.0.0
-}
data ColourMode
    = -- | @since 0.0.0.0
      DisableColour
    | -- | @since 0.0.0.0
      EnableColour
    deriving stock
        ( Int -> ColourMode -> ShowS
[ColourMode] -> ShowS
ColourMode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ColourMode] -> ShowS
$cshowList :: [ColourMode] -> ShowS
show :: ColourMode -> String
$cshow :: ColourMode -> String
showsPrec :: Int -> ColourMode -> ShowS
$cshowsPrec :: Int -> ColourMode -> ShowS
Show
          -- ^ @since 0.0.0.0
        , ColourMode -> ColourMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ColourMode -> ColourMode -> Bool
$c/= :: ColourMode -> ColourMode -> Bool
== :: ColourMode -> ColourMode -> Bool
$c== :: ColourMode -> ColourMode -> Bool
Eq
          -- ^ @since 0.0.0.0
        , Eq ColourMode
ColourMode -> ColourMode -> Bool
ColourMode -> ColourMode -> Ordering
ColourMode -> ColourMode -> ColourMode
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ColourMode -> ColourMode -> ColourMode
$cmin :: ColourMode -> ColourMode -> ColourMode
max :: ColourMode -> ColourMode -> ColourMode
$cmax :: ColourMode -> ColourMode -> ColourMode
>= :: ColourMode -> ColourMode -> Bool
$c>= :: ColourMode -> ColourMode -> Bool
> :: ColourMode -> ColourMode -> Bool
$c> :: ColourMode -> ColourMode -> Bool
<= :: ColourMode -> ColourMode -> Bool
$c<= :: ColourMode -> ColourMode -> Bool
< :: ColourMode -> ColourMode -> Bool
$c< :: ColourMode -> ColourMode -> Bool
compare :: ColourMode -> ColourMode -> Ordering
$ccompare :: ColourMode -> ColourMode -> Ordering
Ord
          -- ^ @since 0.0.0.0
        , Int -> ColourMode
ColourMode -> Int
ColourMode -> [ColourMode]
ColourMode -> ColourMode
ColourMode -> ColourMode -> [ColourMode]
ColourMode -> ColourMode -> ColourMode -> [ColourMode]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ColourMode -> ColourMode -> ColourMode -> [ColourMode]
$cenumFromThenTo :: ColourMode -> ColourMode -> ColourMode -> [ColourMode]
enumFromTo :: ColourMode -> ColourMode -> [ColourMode]
$cenumFromTo :: ColourMode -> ColourMode -> [ColourMode]
enumFromThen :: ColourMode -> ColourMode -> [ColourMode]
$cenumFromThen :: ColourMode -> ColourMode -> [ColourMode]
enumFrom :: ColourMode -> [ColourMode]
$cenumFrom :: ColourMode -> [ColourMode]
fromEnum :: ColourMode -> Int
$cfromEnum :: ColourMode -> Int
toEnum :: Int -> ColourMode
$ctoEnum :: Int -> ColourMode
pred :: ColourMode -> ColourMode
$cpred :: ColourMode -> ColourMode
succ :: ColourMode -> ColourMode
$csucc :: ColourMode -> ColourMode
Enum
          -- ^ @since 0.0.0.0
        , ColourMode
forall a. a -> a -> Bounded a
maxBound :: ColourMode
$cmaxBound :: ColourMode
minBound :: ColourMode
$cminBound :: ColourMode
Bounded
          -- ^ @since 0.0.0.0
        )

{- | Returns 'ColourMode' of a 'Handle' ignoring environment and CLI options.
You can use this function on output 'Handle's to find out whether they support
colouring or not.

Use a function like this to check whether you can print with colour
to terminal:

@
'handleColourMode' 'System.IO.stdout'
@

@since 0.0.0.0
-}
handleColourMode :: Handle -> IO ColourMode
handleColourMode :: Handle -> IO ColourMode
handleColourMode Handle
handle = do
    Bool
supportsANSI <- Handle -> IO Bool
hSupportsANSIColor Handle
handle
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Bool
supportsANSI then ColourMode
EnableColour else ColourMode
DisableColour

{- | This function performs a full check of the 'Handle' colouring support, env
variables and user-specified settings to detect whether the given handle
supports colouring.

Per CLI Guidelines, the algorithm for detecting the colouring support is the
following:

__Disable color if your program is not in a terminal or the user requested it.
These things should disable colors:__

* @stdout@ or @stderr@ is not an interactive terminal (a TTY). It’s best to
  individually check—if you’re piping stdout to another program, it’s still
  useful to get colors on stderr.
* The @NO_COLOR@ environment variable is set.
* The @TERM@ environment variable has the value @dumb@.
* The user passes the option @--no-color@.
* You may also want to add a @MYAPP_NO_COLOR@ environment variable in case users
  want to disable color specifically for your program.

ℹ️ Iris performs this check on the application start automatically so you don't
need to call this function manually.

@since 0.1.0.0
-}
detectColourMode
    :: Handle
    -- ^ A terminal handle (e.g. 'System.IO.stderr')
    -> ColourOption
    -- ^ User settings
    -> Maybe String
    -- ^ Application name
    -> IO ColourMode
detectColourMode :: Handle -> ColourOption -> Maybe String -> IO ColourMode
detectColourMode Handle
handle ColourOption
colour Maybe String
maybeAppName = case ColourOption
colour of
    ColourOption
Never -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ColourMode
DisableColour
    ColourOption
Always -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ColourMode
EnableColour
    ColourOption
Auto -> IO ColourMode
autoDetectColour
  where
    autoDetectColour :: IO ColourMode
    autoDetectColour :: IO ColourMode
autoDetectColour = Bool -> ColourMode
disabledToMode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Bool
checkIfDisabled

    disabledToMode :: Bool -> ColourMode
    disabledToMode :: Bool -> ColourMode
disabledToMode Bool
isDisabled =
        if Bool
isDisabled then ColourMode
DisableColour else ColourMode
EnableColour

    checkIfDisabled :: IO Bool
    checkIfDisabled :: IO Bool
checkIfDisabled =
        forall (m :: * -> *). Monad m => [m Bool] -> m Bool
orM
            [ IO Bool
isHandleColouringDisabled
            , IO Bool
hasNoColourEnvVars
            , IO Bool
isTermDumb
            ]

    isHandleColouringDisabled :: IO Bool
    isHandleColouringDisabled :: IO Bool
isHandleColouringDisabled = (forall a. Eq a => a -> a -> Bool
== ColourMode
DisableColour) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO ColourMode
handleColourMode Handle
handle

    hasNoColourEnvVars :: IO Bool
    hasNoColourEnvVars :: IO Bool
hasNoColourEnvVars = forall (m :: * -> *). Monad m => [m Bool] -> m Bool
orM forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> IO Bool
hasEnvVar [String]
allVarNames

    isTermDumb :: IO Bool
    isTermDumb :: IO Bool
isTermDumb =
        String -> IO (Maybe String)
lookupEnv String
"TERM" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe String
mVal -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Maybe String
mVal of
            Maybe String
Nothing -> Bool
False
            Just String
val -> forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
val forall a. Eq a => a -> a -> Bool
== String
"dumb"

    hasEnvVar :: String -> IO Bool
    hasEnvVar :: String -> IO Bool
hasEnvVar String
var = forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
var

    noColourVarNames :: [String]
    noColourVarNames :: [String]
noColourVarNames = [String
"NO_COLOR", String
"NO_COLOUR"]

    prepend :: String -> String -> String
    prepend :: String -> ShowS
prepend String
appName String
envName = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
appName forall a. Semigroup a => a -> a -> a
<> String
"_" forall a. Semigroup a => a -> a -> a
<> String
envName

    allVarNames :: [String]
    allVarNames :: [String]
allVarNames = case Maybe String
maybeAppName of
        Maybe String
Nothing -> [String]
noColourVarNames
        Just String
appName -> [String]
noColourVarNames forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map (String -> ShowS
prepend String
appName) [String]
noColourVarNames

(||^) :: Monad m => m Bool -> m Bool -> m Bool
m Bool
mx ||^ :: forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
||^ m Bool
my = do
    Bool
x <- m Bool
mx
    if Bool
x
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        else m Bool
my

orM :: Monad m => [m Bool] -> m Bool
orM :: forall (m :: * -> *). Monad m => [m Bool] -> m Bool
orM = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
(||^) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)