module GHC.Utils.Ppr.Colour where
import GHC.Prelude

import Data.Maybe (fromMaybe)
import GHC.Utils.Misc (OverridingBool(..), split)
import Data.Semigroup as Semi

-- | A colour\/style for use with 'coloured'.
newtype PprColour = PprColour { PprColour -> [Char]
renderColour :: String }

instance Semi.Semigroup PprColour where
  PprColour [Char]
s1 <> :: PprColour -> PprColour -> PprColour
<> PprColour [Char]
s2 = [Char] -> PprColour
PprColour ([Char]
s1 [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
External instance of the constraint type forall a. Semigroup [a]
<> [Char]
s2)

-- | Allow colours to be combined (e.g. bold + red);
--   In case of conflict, right side takes precedence.
instance Monoid PprColour where
  mempty :: PprColour
mempty = [Char] -> PprColour
PprColour [Char]
forall a. Monoid a => a
External instance of the constraint type forall a. Monoid [a]
mempty
  mappend :: PprColour -> PprColour -> PprColour
mappend = PprColour -> PprColour -> PprColour
forall a. Semigroup a => a -> a -> a
Instance of class: Semigroup of the constraint type Semigroup PprColour
(<>)

renderColourAfresh :: PprColour -> String
renderColourAfresh :: PprColour -> [Char]
renderColourAfresh PprColour
c = PprColour -> [Char]
renderColour (PprColour
colReset PprColour -> PprColour -> PprColour
forall a. Monoid a => a -> a -> a
Instance of class: Monoid of the constraint type Monoid PprColour
`mappend` PprColour
c)

colCustom :: String -> PprColour
colCustom :: [Char] -> PprColour
colCustom [Char]
"" = PprColour
forall a. Monoid a => a
Instance of class: Monoid of the constraint type Monoid PprColour
mempty
colCustom [Char]
s  = [Char] -> PprColour
PprColour ([Char]
"\27[" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"m")

colReset :: PprColour
colReset :: PprColour
colReset = [Char] -> PprColour
colCustom [Char]
"0"

colBold :: PprColour
colBold :: PprColour
colBold = [Char] -> PprColour
colCustom [Char]
";1"

colBlackFg :: PprColour
colBlackFg :: PprColour
colBlackFg = [Char] -> PprColour
colCustom [Char]
"30"

colRedFg :: PprColour
colRedFg :: PprColour
colRedFg = [Char] -> PprColour
colCustom [Char]
"31"

colGreenFg :: PprColour
colGreenFg :: PprColour
colGreenFg = [Char] -> PprColour
colCustom [Char]
"32"

colYellowFg :: PprColour
colYellowFg :: PprColour
colYellowFg = [Char] -> PprColour
colCustom [Char]
"33"

colBlueFg :: PprColour
colBlueFg :: PprColour
colBlueFg = [Char] -> PprColour
colCustom [Char]
"34"

colMagentaFg :: PprColour
colMagentaFg :: PprColour
colMagentaFg = [Char] -> PprColour
colCustom [Char]
"35"

colCyanFg :: PprColour
colCyanFg :: PprColour
colCyanFg = [Char] -> PprColour
colCustom [Char]
"36"

colWhiteFg :: PprColour
colWhiteFg :: PprColour
colWhiteFg = [Char] -> PprColour
colCustom [Char]
"37"

data Scheme =
  Scheme
  { Scheme -> PprColour
sHeader  :: PprColour
  , Scheme -> PprColour
sMessage :: PprColour
  , Scheme -> PprColour
sWarning :: PprColour
  , Scheme -> PprColour
sError   :: PprColour
  , Scheme -> PprColour
sFatal   :: PprColour
  , Scheme -> PprColour
sMargin  :: PprColour
  }

defaultScheme :: Scheme
defaultScheme :: Scheme
defaultScheme =
  Scheme :: PprColour
-> PprColour
-> PprColour
-> PprColour
-> PprColour
-> PprColour
-> Scheme
Scheme
  { sHeader :: PprColour
sHeader  = PprColour
forall a. Monoid a => a
Instance of class: Monoid of the constraint type Monoid PprColour
mempty
  , sMessage :: PprColour
sMessage = PprColour
colBold
  , sWarning :: PprColour
sWarning = PprColour
colBold PprColour -> PprColour -> PprColour
forall a. Monoid a => a -> a -> a
Instance of class: Monoid of the constraint type Monoid PprColour
`mappend` PprColour
colMagentaFg
  , sError :: PprColour
sError   = PprColour
colBold PprColour -> PprColour -> PprColour
forall a. Monoid a => a -> a -> a
Instance of class: Monoid of the constraint type Monoid PprColour
`mappend` PprColour
colRedFg
  , sFatal :: PprColour
sFatal   = PprColour
colBold PprColour -> PprColour -> PprColour
forall a. Monoid a => a -> a -> a
Instance of class: Monoid of the constraint type Monoid PprColour
`mappend` PprColour
colRedFg
  , sMargin :: PprColour
sMargin  = PprColour
colBold PprColour -> PprColour -> PprColour
forall a. Monoid a => a -> a -> a
Instance of class: Monoid of the constraint type Monoid PprColour
`mappend` PprColour
colBlueFg
  }

-- | Parse the colour scheme from a string (presumably from the @GHC_COLORS@
-- environment variable).
parseScheme :: String -> (OverridingBool, Scheme) -> (OverridingBool, Scheme)
parseScheme :: [Char] -> (OverridingBool, Scheme) -> (OverridingBool, Scheme)
parseScheme [Char]
"always" (OverridingBool
_, Scheme
cs) = (OverridingBool
Always, Scheme
cs)
parseScheme [Char]
"auto"   (OverridingBool
_, Scheme
cs) = (OverridingBool
Auto,   Scheme
cs)
parseScheme [Char]
"never"  (OverridingBool
_, Scheme
cs) = (OverridingBool
Never,  Scheme
cs)
parseScheme [Char]
input    (OverridingBool
b, Scheme
cs) =
  ( OverridingBool
b
  , Scheme :: PprColour
-> PprColour
-> PprColour
-> PprColour
-> PprColour
-> PprColour
-> Scheme
Scheme
    { sHeader :: PprColour
sHeader  = PprColour -> Maybe PprColour -> PprColour
forall a. a -> Maybe a -> a
fromMaybe (Scheme -> PprColour
sHeader Scheme
cs)  ([Char] -> [([Char], PprColour)] -> Maybe PprColour
forall a b. Eq a => a -> [(a, b)] -> Maybe b
External instance of the constraint type forall a. Eq a => Eq [a]
External instance of the constraint type Eq Char
lookup [Char]
"header" [([Char], PprColour)]
table)
    , sMessage :: PprColour
sMessage = PprColour -> Maybe PprColour -> PprColour
forall a. a -> Maybe a -> a
fromMaybe (Scheme -> PprColour
sMessage Scheme
cs) ([Char] -> [([Char], PprColour)] -> Maybe PprColour
forall a b. Eq a => a -> [(a, b)] -> Maybe b
External instance of the constraint type forall a. Eq a => Eq [a]
External instance of the constraint type Eq Char
lookup [Char]
"message" [([Char], PprColour)]
table)
    , sWarning :: PprColour
sWarning = PprColour -> Maybe PprColour -> PprColour
forall a. a -> Maybe a -> a
fromMaybe (Scheme -> PprColour
sWarning Scheme
cs) ([Char] -> [([Char], PprColour)] -> Maybe PprColour
forall a b. Eq a => a -> [(a, b)] -> Maybe b
External instance of the constraint type forall a. Eq a => Eq [a]
External instance of the constraint type Eq Char
lookup [Char]
"warning" [([Char], PprColour)]
table)
    , sError :: PprColour
sError   = PprColour -> Maybe PprColour -> PprColour
forall a. a -> Maybe a -> a
fromMaybe (Scheme -> PprColour
sError Scheme
cs)   ([Char] -> [([Char], PprColour)] -> Maybe PprColour
forall a b. Eq a => a -> [(a, b)] -> Maybe b
External instance of the constraint type forall a. Eq a => Eq [a]
External instance of the constraint type Eq Char
lookup [Char]
"error"   [([Char], PprColour)]
table)
    , sFatal :: PprColour
sFatal   = PprColour -> Maybe PprColour -> PprColour
forall a. a -> Maybe a -> a
fromMaybe (Scheme -> PprColour
sFatal Scheme
cs)   ([Char] -> [([Char], PprColour)] -> Maybe PprColour
forall a b. Eq a => a -> [(a, b)] -> Maybe b
External instance of the constraint type forall a. Eq a => Eq [a]
External instance of the constraint type Eq Char
lookup [Char]
"fatal"   [([Char], PprColour)]
table)
    , sMargin :: PprColour
sMargin  = PprColour -> Maybe PprColour -> PprColour
forall a. a -> Maybe a -> a
fromMaybe (Scheme -> PprColour
sMargin Scheme
cs)  ([Char] -> [([Char], PprColour)] -> Maybe PprColour
forall a b. Eq a => a -> [(a, b)] -> Maybe b
External instance of the constraint type forall a. Eq a => Eq [a]
External instance of the constraint type Eq Char
lookup [Char]
"margin"  [([Char], PprColour)]
table)
    }
  )
  where
    table :: [([Char], PprColour)]
table = do
      [Char]
w <- Char -> [Char] -> [[Char]]
split Char
':' [Char]
input
      let ([Char]
k, [Char]
v') = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq Char
== Char
'=') [Char]
w
      case [Char]
v' of
        Char
'=' : [Char]
v -> ([Char], PprColour) -> [([Char], PprColour)]
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad []
return ([Char]
k, [Char] -> PprColour
colCustom [Char]
v)
        [Char]
_ -> []