Mode.hs

{- |
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
        ( Show
          -- ^ @since 0.0.0.0
        , Eq
          -- ^ @since 0.0.0.0
        , Ord
          -- ^ @since 0.0.0.0
        , Enum
          -- ^ @since 0.0.0.0
        , 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 = do
    supportsANSI <- hSupportsANSIColor handle
    pure $ if supportsANSI then EnableColour else 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 colour maybeAppName = case colour of
    Never -> pure DisableColour
    Always -> pure EnableColour
    Auto -> autoDetectColour
  where
    autoDetectColour :: IO ColourMode
    autoDetectColour = disabledToMode <$> checkIfDisabled

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

    checkIfDisabled :: IO Bool
    checkIfDisabled =
        orM
            [ isHandleColouringDisabled
            , hasNoColourEnvVars
            , isTermDumb
            ]

    isHandleColouringDisabled :: IO Bool
    isHandleColouringDisabled = (== DisableColour) <$> handleColourMode handle

    hasNoColourEnvVars :: IO Bool
    hasNoColourEnvVars = orM $ map hasEnvVar allVarNames

    isTermDumb :: IO Bool
    isTermDumb =
        lookupEnv "TERM" >>= \mVal -> pure $ case mVal of
            Nothing -> False
            Just val -> map toLower val == "dumb"

    hasEnvVar :: String -> IO Bool
    hasEnvVar var = isJust <$> lookupEnv var

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

    prepend :: String -> String -> String
    prepend appName envName = map toUpper appName <> "_" <> envName

    allVarNames :: [String]
    allVarNames = case maybeAppName of
        Nothing -> noColourVarNames
        Just appName -> noColourVarNames <> map (prepend appName) noColourVarNames

(||^) :: Monad m => m Bool -> m Bool -> m Bool
mx ||^ my = do
    x <- mx
    if x
        then pure True
        else my

orM :: Monad m => [m Bool] -> m Bool
orM = foldr (||^) (pure False)