never executed always true always false

    1 module GHC.Utils.Ppr.Colour where
    2 import GHC.Prelude
    3 
    4 import Data.Maybe (fromMaybe)
    5 import GHC.Data.Bool
    6 import Data.Semigroup as Semi
    7 
    8 -- | A colour\/style for use with 'coloured'.
    9 newtype PprColour = PprColour { renderColour :: String }
   10 
   11 instance Semi.Semigroup PprColour where
   12   PprColour s1 <> PprColour s2 = PprColour (s1 <> s2)
   13 
   14 -- | Allow colours to be combined (e.g. bold + red);
   15 --   In case of conflict, right side takes precedence.
   16 instance Monoid PprColour where
   17   mempty = PprColour mempty
   18   mappend = (<>)
   19 
   20 renderColourAfresh :: PprColour -> String
   21 renderColourAfresh c = renderColour (colReset `mappend` c)
   22 
   23 colCustom :: String -> PprColour
   24 colCustom "" = mempty
   25 colCustom s  = PprColour ("\27[" ++ s ++ "m")
   26 
   27 colReset :: PprColour
   28 colReset = colCustom "0"
   29 
   30 colBold :: PprColour
   31 colBold = colCustom ";1"
   32 
   33 colBlackFg :: PprColour
   34 colBlackFg = colCustom "30"
   35 
   36 colRedFg :: PprColour
   37 colRedFg = colCustom "31"
   38 
   39 colGreenFg :: PprColour
   40 colGreenFg = colCustom "32"
   41 
   42 colYellowFg :: PprColour
   43 colYellowFg = colCustom "33"
   44 
   45 colBlueFg :: PprColour
   46 colBlueFg = colCustom "34"
   47 
   48 colMagentaFg :: PprColour
   49 colMagentaFg = colCustom "35"
   50 
   51 colCyanFg :: PprColour
   52 colCyanFg = colCustom "36"
   53 
   54 colWhiteFg :: PprColour
   55 colWhiteFg = colCustom "37"
   56 
   57 data Scheme =
   58   Scheme
   59   { sHeader  :: PprColour
   60   , sMessage :: PprColour
   61   , sWarning :: PprColour
   62   , sError   :: PprColour
   63   , sFatal   :: PprColour
   64   , sMargin  :: PprColour
   65   }
   66 
   67 defaultScheme :: Scheme
   68 defaultScheme =
   69   Scheme
   70   { sHeader  = mempty
   71   , sMessage = colBold
   72   , sWarning = colBold `mappend` colMagentaFg
   73   , sError   = colBold `mappend` colRedFg
   74   , sFatal   = colBold `mappend` colRedFg
   75   , sMargin  = colBold `mappend` colBlueFg
   76   }
   77 
   78 -- | Parse the colour scheme from a string (presumably from the @GHC_COLORS@
   79 -- environment variable).
   80 parseScheme :: String -> (OverridingBool, Scheme) -> (OverridingBool, Scheme)
   81 parseScheme "always" (_, cs) = (Always, cs)
   82 parseScheme "auto"   (_, cs) = (Auto,   cs)
   83 parseScheme "never"  (_, cs) = (Never,  cs)
   84 parseScheme input    (b, cs) =
   85   ( b
   86   , Scheme
   87     { sHeader  = fromMaybe (sHeader cs)  (lookup "header" table)
   88     , sMessage = fromMaybe (sMessage cs) (lookup "message" table)
   89     , sWarning = fromMaybe (sWarning cs) (lookup "warning" table)
   90     , sError   = fromMaybe (sError cs)   (lookup "error"   table)
   91     , sFatal   = fromMaybe (sFatal cs)   (lookup "fatal"   table)
   92     , sMargin  = fromMaybe (sMargin cs)  (lookup "margin"  table)
   93     }
   94   )
   95   where
   96     split :: Char -> String -> [String]
   97     split c s = case break (==c) s of
   98         (chunk,[])     -> [chunk]
   99         (chunk,_:rest) -> chunk : split c rest
  100 
  101     table = do
  102       w <- split ':' input
  103       let (k, v') = break (== '=') w
  104       case v' of
  105         '=' : v -> return (k, colCustom v)
  106         _ -> []