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

import Data.Maybe (fromMaybe)
import GHC.Data.Bool
import Data.Semigroup as Semi

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

instance Semi.Semigroup PprColour where
  PprColour String
s1 <> :: PprColour -> PprColour -> PprColour
<> PprColour String
s2 = String -> PprColour
PprColour (String
s1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
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 = String -> PprColour
PprColour String
forall a. Monoid a => a
mempty
  mappend :: PprColour -> PprColour -> PprColour
mappend = PprColour -> PprColour -> PprColour
forall a. Semigroup a => a -> a -> a
(<>)

renderColourAfresh :: PprColour -> String
renderColourAfresh :: PprColour -> String
renderColourAfresh PprColour
c = PprColour -> String
renderColour (PprColour
colReset PprColour -> PprColour -> PprColour
forall a. Monoid a => a -> a -> a
`mappend` PprColour
c)

colCustom :: String -> PprColour
colCustom :: String -> PprColour
colCustom String
"" = PprColour
forall a. Monoid a => a
mempty
colCustom String
s  = String -> PprColour
PprColour (String
"\27[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"m")

colReset :: PprColour
colReset :: PprColour
colReset = String -> PprColour
colCustom String
"0"

colBold :: PprColour
colBold :: PprColour
colBold = String -> PprColour
colCustom String
";1"

colBlackFg :: PprColour
colBlackFg :: PprColour
colBlackFg = String -> PprColour
colCustom String
"30"

colRedFg :: PprColour
colRedFg :: PprColour
colRedFg = String -> PprColour
colCustom String
"31"

colGreenFg :: PprColour
colGreenFg :: PprColour
colGreenFg = String -> PprColour
colCustom String
"32"

colYellowFg :: PprColour
colYellowFg :: PprColour
colYellowFg = String -> PprColour
colCustom String
"33"

colBlueFg :: PprColour
colBlueFg :: PprColour
colBlueFg = String -> PprColour
colCustom String
"34"

colMagentaFg :: PprColour
colMagentaFg :: PprColour
colMagentaFg = String -> PprColour
colCustom String
"35"

colCyanFg :: PprColour
colCyanFg :: PprColour
colCyanFg = String -> PprColour
colCustom String
"36"

colWhiteFg :: PprColour
colWhiteFg :: PprColour
colWhiteFg = String -> PprColour
colCustom String
"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
  { sHeader :: PprColour
sHeader  = PprColour
forall a. Monoid a => a
mempty
  , sMessage :: PprColour
sMessage = PprColour
colBold
  , sWarning :: PprColour
sWarning = PprColour
colBold PprColour -> PprColour -> PprColour
forall a. Monoid a => a -> a -> a
`mappend` PprColour
colMagentaFg
  , sError :: PprColour
sError   = PprColour
colBold PprColour -> PprColour -> PprColour
forall a. Monoid a => a -> a -> a
`mappend` PprColour
colRedFg
  , sFatal :: PprColour
sFatal   = PprColour
colBold PprColour -> PprColour -> PprColour
forall a. Monoid a => a -> a -> a
`mappend` PprColour
colRedFg
  , sMargin :: PprColour
sMargin  = PprColour
colBold PprColour -> PprColour -> PprColour
forall a. Monoid a => a -> a -> a
`mappend` PprColour
colBlueFg
  }

-- | Parse the colour scheme from a string (presumably from the @GHC_COLORS@
-- environment variable).
parseScheme :: String -> (OverridingBool, Scheme) -> (OverridingBool, Scheme)
parseScheme :: String -> (OverridingBool, Scheme) -> (OverridingBool, Scheme)
parseScheme String
"always" (OverridingBool
_, Scheme
cs) = (OverridingBool
Always, Scheme
cs)
parseScheme String
"auto"   (OverridingBool
_, Scheme
cs) = (OverridingBool
Auto,   Scheme
cs)
parseScheme String
"never"  (OverridingBool
_, Scheme
cs) = (OverridingBool
Never,  Scheme
cs)
parseScheme String
input    (OverridingBool
b, Scheme
cs) =
  ( OverridingBool
b
  , Scheme
    { sHeader :: PprColour
sHeader  = PprColour -> Maybe PprColour -> PprColour
forall a. a -> Maybe a -> a
fromMaybe (Scheme -> PprColour
sHeader Scheme
cs)  (String -> [(String, PprColour)] -> Maybe PprColour
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"header" [(String, PprColour)]
table)
    , sMessage :: PprColour
sMessage = PprColour -> Maybe PprColour -> PprColour
forall a. a -> Maybe a -> a
fromMaybe (Scheme -> PprColour
sMessage Scheme
cs) (String -> [(String, PprColour)] -> Maybe PprColour
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"message" [(String, PprColour)]
table)
    , sWarning :: PprColour
sWarning = PprColour -> Maybe PprColour -> PprColour
forall a. a -> Maybe a -> a
fromMaybe (Scheme -> PprColour
sWarning Scheme
cs) (String -> [(String, PprColour)] -> Maybe PprColour
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"warning" [(String, PprColour)]
table)
    , sError :: PprColour
sError   = PprColour -> Maybe PprColour -> PprColour
forall a. a -> Maybe a -> a
fromMaybe (Scheme -> PprColour
sError Scheme
cs)   (String -> [(String, PprColour)] -> Maybe PprColour
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"error"   [(String, PprColour)]
table)
    , sFatal :: PprColour
sFatal   = PprColour -> Maybe PprColour -> PprColour
forall a. a -> Maybe a -> a
fromMaybe (Scheme -> PprColour
sFatal Scheme
cs)   (String -> [(String, PprColour)] -> Maybe PprColour
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"fatal"   [(String, PprColour)]
table)
    , sMargin :: PprColour
sMargin  = PprColour -> Maybe PprColour -> PprColour
forall a. a -> Maybe a -> a
fromMaybe (Scheme -> PprColour
sMargin Scheme
cs)  (String -> [(String, PprColour)] -> Maybe PprColour
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"margin"  [(String, PprColour)]
table)
    }
  )
  where
    split :: Char -> String -> [String]
    split :: Char -> String -> [String]
split Char
c String
s = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
c) String
s of
        (String
chunk,[])     -> [String
chunk]
        (String
chunk,Char
_:String
rest) -> String
chunk String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Char -> String -> [String]
split Char
c String
rest

    table :: [(String, PprColour)]
table = do
      String
w <- Char -> String -> [String]
split Char
':' String
input
      let (String
k, String
v') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=') String
w
      case String
v' of
        Char
'=' : String
v -> (String, PprColour) -> [(String, PprColour)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (String
k, String -> PprColour
colCustom String
v)
        String
_ -> []