content: 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 { renderColour :: String }
  
  instance Semi.Semigroup PprColour where
    PprColour s1 <> PprColour s2 = PprColour (s1 <> 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
    mappend = (<>)
  
  renderColourAfresh :: PprColour -> String
  renderColourAfresh c = renderColour (colReset `mappend` c)
  
  colCustom :: String -> PprColour
  colCustom "" = mempty
  colCustom s  = PprColour ("\27[" ++ s ++ "m")
  
  colReset :: PprColour
  colReset = colCustom "0"
  
  colBold :: PprColour
  colBold = colCustom ";1"
  
  colBlackFg :: PprColour
  colBlackFg = colCustom "30"
  
  colRedFg :: PprColour
  colRedFg = colCustom "31"
  
  colGreenFg :: PprColour
  colGreenFg = colCustom "32"
  
  colYellowFg :: PprColour
  colYellowFg = colCustom "33"
  
  colBlueFg :: PprColour
  colBlueFg = colCustom "34"
  
  colMagentaFg :: PprColour
  colMagentaFg = colCustom "35"
  
  colCyanFg :: PprColour
  colCyanFg = colCustom "36"
  
  colWhiteFg :: PprColour
  colWhiteFg = colCustom "37"
  
  data Scheme =
    Scheme
    { sHeader  :: PprColour
    , sMessage :: PprColour
    , sWarning :: PprColour
    , sError   :: PprColour
    , sFatal   :: PprColour
    , sMargin  :: PprColour
    }
  
  defaultScheme :: Scheme
  defaultScheme =
    Scheme
    { sHeader  = mempty
    , sMessage = colBold
    , sWarning = colBold `mappend` colMagentaFg
    , sError   = colBold `mappend` colRedFg
    , sFatal   = colBold `mappend` colRedFg
    , sMargin  = colBold `mappend` colBlueFg
    }
  
  -- | Parse the colour scheme from a string (presumably from the @GHC_COLORS@
  -- environment variable).
  parseScheme :: String -> (OverridingBool, Scheme) -> (OverridingBool, Scheme)
  parseScheme "always" (_, cs) = (Always, cs)
  parseScheme "auto"   (_, cs) = (Auto,   cs)
  parseScheme "never"  (_, cs) = (Never,  cs)
  parseScheme input    (b, cs) =
    ( b
    , Scheme
      { sHeader  = fromMaybe (sHeader cs)  (lookup "header" table)
      , sMessage = fromMaybe (sMessage cs) (lookup "message" table)
      , sWarning = fromMaybe (sWarning cs) (lookup "warning" table)
      , sError   = fromMaybe (sError cs)   (lookup "error"   table)
      , sFatal   = fromMaybe (sFatal cs)   (lookup "fatal"   table)
      , sMargin  = fromMaybe (sMargin cs)  (lookup "margin"  table)
      }
    )
    where
      split :: Char -> String -> [String]
      split c s = case break (==c) s of
          (chunk,[])     -> [chunk]
          (chunk,_:rest) -> chunk : split c rest
  
      table = do
        w <- split ':' input
        let (k, v') = break (== '=') w
        case v' of
          '=' : v -> return (k, colCustom v)
          _ -> []
  