-- Copyright (c) 2016-2020 Lars Kuhtz <lakuhtz@gmail.com>
-- Copyright (c) 2014-2015 PivotCloud, Inc.
--
-- System.Logger.Backend.ColorOption
--
-- Please feel free to contact us at licensing@pivotmail.com with any
-- contributions, additions, or other feedback; we would love to hear from
-- you.
--
-- Licensed under the Apache License, Version 2.0 (the "License"); you may
-- not use this file except in compliance with the License. You may obtain a
-- copy of the License at http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
-- WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
-- License for the specific language governing permissions and limitations
-- under the License.

-- |
-- Module: System.Logger.Backend.ColorOption
-- Copyright:
--     Copyright (c) 2016-2020 Lars Kuhtz <lakuhtz@gmail.com>
--     Copyright (c) 2014-2015 PivotCloud, Inc.
-- License: Apache License, Version 2.0
-- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>
-- Stability: experimental
--
-- An option that indicates whether ANSI color escapes shall
-- be used in textual output.

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}

module System.Logger.Backend.ColorOption
( ColorOption(..)
, readColorOption
, colorOptionText
, defaultColorOption
, pColorOption
, pColorOption_
, useColor
) where

import Configuration.Utils

import Control.DeepSeq
import Control.Monad.Except

import Data.Monoid.Unicode
import Data.String
import qualified Data.Text as T
import Data.Typeable

import GHC.Generics

import qualified Options.Applicative as O

import Prelude.Unicode

import qualified System.Console.ANSI as A
import System.IO (Handle)

-- -------------------------------------------------------------------------- --
-- Color Option

-- | Color Option
--
data ColorOption
    = ColorAuto
    | ColorFalse
    | ColorTrue
    deriving (Int -> ColorOption -> ShowS
[ColorOption] -> ShowS
ColorOption -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ColorOption] -> ShowS
$cshowList :: [ColorOption] -> ShowS
show :: ColorOption -> String
$cshow :: ColorOption -> String
showsPrec :: Int -> ColorOption -> ShowS
$cshowsPrec :: Int -> ColorOption -> ShowS
Show, ReadPrec [ColorOption]
ReadPrec ColorOption
Int -> ReadS ColorOption
ReadS [ColorOption]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ColorOption]
$creadListPrec :: ReadPrec [ColorOption]
readPrec :: ReadPrec ColorOption
$creadPrec :: ReadPrec ColorOption
readList :: ReadS [ColorOption]
$creadList :: ReadS [ColorOption]
readsPrec :: Int -> ReadS ColorOption
$creadsPrec :: Int -> ReadS ColorOption
Read, ColorOption -> ColorOption -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ColorOption -> ColorOption -> Bool
$c/= :: ColorOption -> ColorOption -> Bool
== :: ColorOption -> ColorOption -> Bool
$c== :: ColorOption -> ColorOption -> Bool
Eq, Eq ColorOption
ColorOption -> ColorOption -> Bool
ColorOption -> ColorOption -> Ordering
ColorOption -> ColorOption -> ColorOption
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 :: ColorOption -> ColorOption -> ColorOption
$cmin :: ColorOption -> ColorOption -> ColorOption
max :: ColorOption -> ColorOption -> ColorOption
$cmax :: ColorOption -> ColorOption -> ColorOption
>= :: ColorOption -> ColorOption -> Bool
$c>= :: ColorOption -> ColorOption -> Bool
> :: ColorOption -> ColorOption -> Bool
$c> :: ColorOption -> ColorOption -> Bool
<= :: ColorOption -> ColorOption -> Bool
$c<= :: ColorOption -> ColorOption -> Bool
< :: ColorOption -> ColorOption -> Bool
$c< :: ColorOption -> ColorOption -> Bool
compare :: ColorOption -> ColorOption -> Ordering
$ccompare :: ColorOption -> ColorOption -> Ordering
Ord, Int -> ColorOption
ColorOption -> Int
ColorOption -> [ColorOption]
ColorOption -> ColorOption
ColorOption -> ColorOption -> [ColorOption]
ColorOption -> ColorOption -> ColorOption -> [ColorOption]
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 :: ColorOption -> ColorOption -> ColorOption -> [ColorOption]
$cenumFromThenTo :: ColorOption -> ColorOption -> ColorOption -> [ColorOption]
enumFromTo :: ColorOption -> ColorOption -> [ColorOption]
$cenumFromTo :: ColorOption -> ColorOption -> [ColorOption]
enumFromThen :: ColorOption -> ColorOption -> [ColorOption]
$cenumFromThen :: ColorOption -> ColorOption -> [ColorOption]
enumFrom :: ColorOption -> [ColorOption]
$cenumFrom :: ColorOption -> [ColorOption]
fromEnum :: ColorOption -> Int
$cfromEnum :: ColorOption -> Int
toEnum :: Int -> ColorOption
$ctoEnum :: Int -> ColorOption
pred :: ColorOption -> ColorOption
$cpred :: ColorOption -> ColorOption
succ :: ColorOption -> ColorOption
$csucc :: ColorOption -> ColorOption
Enum, ColorOption
forall a. a -> a -> Bounded a
maxBound :: ColorOption
$cmaxBound :: ColorOption
minBound :: ColorOption
$cminBound :: ColorOption
Bounded, Typeable, forall x. Rep ColorOption x -> ColorOption
forall x. ColorOption -> Rep ColorOption x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ColorOption x -> ColorOption
$cfrom :: forall x. ColorOption -> Rep ColorOption x
Generic)

instance NFData ColorOption

readColorOption
    ∷ (Monad m, IsString e, Monoid e, MonadError e m)
    ⇒ T.Text
    → m ColorOption
readColorOption :: forall (m :: * -> *) e.
(Monad m, IsString e, Monoid e, MonadError e m) =>
Text -> m ColorOption
readColorOption Text
x = case Text -> Text
T.toLower Text
x of
    Text
"auto" → forall (m :: * -> *) a. Monad m => a -> m a
return ColorOption
ColorAuto
    Text
"false" → forall (m :: * -> *) a. Monad m => a -> m a
return ColorOption
ColorFalse
    Text
"true" → forall (m :: * -> *) a. Monad m => a -> m a
return ColorOption
ColorTrue
    Text
e → forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ e
"unexpected color option value: "
        forall α. Monoid α => α -> α -> α
⊕ forall a. IsString a => String -> a
fromString (forall a. Show a => a -> String
show Text
e)
        forall α. Monoid α => α -> α -> α
⊕ e
", expected \"auto\", \"false\", or \"true\""

colorOptionText
    ∷ IsString a
    ⇒ ColorOption
    → a
colorOptionText :: forall a. IsString a => ColorOption -> a
colorOptionText ColorOption
ColorAuto = a
"auto"
colorOptionText ColorOption
ColorFalse = a
"false"
colorOptionText ColorOption
ColorTrue = a
"true"

defaultColorOption ∷ ColorOption
defaultColorOption :: ColorOption
defaultColorOption = ColorOption
ColorAuto

instance ToJSON ColorOption where
    toJSON :: ColorOption -> Value
toJSON = Text -> Value
String forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ forall a. IsString a => ColorOption -> a
colorOptionText

instance FromJSON ColorOption where
    parseJSON :: Value -> Parser ColorOption
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"ColorOption" forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall (m :: * -> *) a. Monad m => a -> m a
return forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ forall (m :: * -> *) e.
(Monad m, IsString e, Monoid e, MonadError e m) =>
Text -> m ColorOption
readColorOption

pColorOption ∷ O.Parser ColorOption
pColorOption :: Parser ColorOption
pColorOption = Text -> Parser ColorOption
pColorOption_ Text
""

-- | A version of 'pColorOption' that takes a prefix for the
-- command line option.
--
-- @since 0.2
--
pColorOption_
    ∷ T.Text
        -- ^ prefix for the command line options.
    → O.Parser ColorOption
pColorOption_ :: Text -> Parser ColorOption
pColorOption_ Text
prefix = forall a. ReadM a -> Mod OptionFields a -> Parser a
option (forall a. (String -> Either String a) -> ReadM a
eitherReader (forall (m :: * -> *) e.
(Monad m, IsString e, Monoid e, MonadError e m) =>
Text -> m ColorOption
readColorOption forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
. String -> Text
T.pack))
   forall a b. (a -> b) -> a -> b
% forall (f :: * -> *) a. HasName f => String -> Mod f a
long (Text -> String
T.unpack Text
prefix forall α. Monoid α => α -> α -> α
⊕ String
"color")
   forall α. Monoid α => α -> α -> α
⊕ forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'c'
   forall α. Monoid α => α -> α -> α
⊕ forall (f :: * -> *) a. String -> Mod f a
help String
"whether to use ANSI terminal colors in the output"

useColor
    ∷ ColorOption
    → Handle
    → IO Bool
useColor :: ColorOption -> Handle -> IO Bool
useColor ColorOption
ColorFalse Handle
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
useColor ColorOption
ColorTrue Handle
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
useColor ColorOption
ColorAuto Handle
handle = Handle -> IO Bool
A.hSupportsANSI Handle
handle