{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}

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

import Data.Maybe (fromMaybe)
import GHC.Data.Bool
import GHC.Generics (Generic, Generically(..))

-- | A colour\/style for use with 'coloured'.
newtype PprColour = PprColour { PprColour -> String
renderColour :: String }
  deriving ((forall x. PprColour -> Rep PprColour x)
-> (forall x. Rep PprColour x -> PprColour) -> Generic PprColour
forall x. Rep PprColour x -> PprColour
forall x. PprColour -> Rep PprColour x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PprColour -> Rep PprColour x
from :: forall x. PprColour -> Rep PprColour x
$cto :: forall x. Rep PprColour x -> PprColour
to :: forall x. Rep PprColour x -> PprColour
Generic)
  deriving (NonEmpty PprColour -> PprColour
PprColour -> PprColour -> PprColour
(PprColour -> PprColour -> PprColour)
-> (NonEmpty PprColour -> PprColour)
-> (forall b. Integral b => b -> PprColour -> PprColour)
-> Semigroup PprColour
forall b. Integral b => b -> PprColour -> PprColour
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: PprColour -> PprColour -> PprColour
<> :: PprColour -> PprColour -> PprColour
$csconcat :: NonEmpty PprColour -> PprColour
sconcat :: NonEmpty PprColour -> PprColour
$cstimes :: forall b. Integral b => b -> PprColour -> PprColour
stimes :: forall b. Integral b => b -> PprColour -> PprColour
Semigroup, Semigroup PprColour
PprColour
Semigroup PprColour =>
PprColour
-> (PprColour -> PprColour -> PprColour)
-> ([PprColour] -> PprColour)
-> Monoid PprColour
[PprColour] -> PprColour
PprColour -> PprColour -> PprColour
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: PprColour
mempty :: PprColour
$cmappend :: PprColour -> PprColour -> PprColour
mappend :: PprColour -> PprColour -> PprColour
$cmconcat :: [PprColour] -> PprColour
mconcat :: [PprColour] -> PprColour
Monoid) via Generically PprColour

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
      w <- Char -> String -> [String]
split Char
':' String
input
      let (k, v') = break (== '=') w
      case 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
_ -> []