module PprColour where
import GhcPrelude

import Data.Maybe (fromMaybe)
import Util (OverridingBool(..), split)
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 s1 :: String
s1 <> :: PprColour -> PprColour -> PprColour
<> PprColour s2 :: 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 c :: 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 "" = PprColour
forall a. Monoid a => a
mempty
colCustom s :: String
s  = String -> PprColour
PprColour ("\27[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ "m")

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

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

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

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

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

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

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

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

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

colWhiteFg :: PprColour
colWhiteFg :: PprColour
colWhiteFg = String -> PprColour
colCustom "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
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 "always" (_, cs :: Scheme
cs) = (OverridingBool
Always, Scheme
cs)
parseScheme "auto"   (_, cs :: Scheme
cs) = (OverridingBool
Auto,   Scheme
cs)
parseScheme "never"  (_, cs :: Scheme
cs) = (OverridingBool
Never,  Scheme
cs)
parseScheme input :: String
input    (b :: OverridingBool
b, cs :: 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)  (String -> [(String, PprColour)] -> Maybe PprColour
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "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 "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 "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 "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 "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 "margin"  [(String, PprColour)]
table)
    }
  )
  where
    table :: [(String, PprColour)]
table = do
      String
w <- Char -> String -> [String]
split ':' String
input
      let (k :: String
k, v' :: 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
== '=') String
w
      case String
v' of
        '=' : v :: String
v -> (String, PprColour) -> [(String, PprColour)]
forall (m :: * -> *) a. Monad m => a -> m a
return (String
k, String -> PprColour
colCustom String
v)
        _ -> []