module GHC.Utils.Ppr.Colour where
import GHC.Prelude.Basic
import Data.Maybe (fromMaybe)
import GHC.Data.Bool
import Data.Semigroup as Semi
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)
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
{ :: 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
}
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
_ -> []