Color.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-|
Module      : Text.Pretty.Simple.Internal.Color
Copyright   : (c) Dennis Gosnell, 2016
License     : BSD-style (see LICENSE file)
Maintainer  : cdep.illabout@gmail.com
Stability   : experimental
Portability : POSIX

-}
module Text.Pretty.Simple.Internal.Color
  where

#if __GLASGOW_HASKELL__ < 710
-- We don't need this import for GHC 7.10 as it exports all required functions
-- from Prelude
import Control.Applicative
#endif

import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Prettyprinter.Render.Terminal
  (AnsiStyle, Intensity(Dull,Vivid), Color(..))
import qualified Prettyprinter.Render.Terminal as Ansi

-- | These options are for colorizing the output of functions like 'pPrint'.
--
-- If you don't want to use a color for one of the options, use 'colorNull'.
data ColorOptions = ColorOptions
  { colorQuote :: Style
  -- ^ Color to use for quote characters (@\"@) around strings.
  , colorString :: Style
  -- ^ Color to use for strings.
  , colorError :: Style
  -- ^ Color for errors, e.g. unmatched brackets.
  , colorNum :: Style
  -- ^ Color to use for numbers.
  , colorRainbowParens :: [Style]
  -- ^ A list of colors to use for rainbow parenthesis output.  Use
  -- '[]' if you don't want rainbow parenthesis.  Use just a single item if you
  -- want all the rainbow parenthesis to be colored the same.
  } deriving (Eq, Generic, Show, Typeable)

-- | Default color options for use on a dark background.
defaultColorOptionsDarkBg :: ColorOptions
defaultColorOptionsDarkBg =
  ColorOptions
  { colorQuote = colorBold Vivid White
  , colorString = colorBold Vivid Blue
  , colorError = colorBold Vivid Red
  , colorNum = colorBold Vivid Green
  , colorRainbowParens =
    [ colorBold Vivid Magenta
    , colorBold Vivid Cyan
    , colorBold Vivid Yellow
    , color Dull Magenta
    , color Dull Cyan
    , color Dull Yellow
    , colorBold Dull Magenta
    , colorBold Dull Cyan
    , colorBold Dull Yellow
    , color Vivid Magenta
    , color Vivid Cyan
    , color Vivid Yellow
    ]
  }

-- | Default color options for use on a light background.
defaultColorOptionsLightBg :: ColorOptions
defaultColorOptionsLightBg =
  ColorOptions
  { colorQuote = colorBold Vivid Black
  , colorString = colorBold Vivid Blue
  , colorError = colorBold Vivid Red
  , colorNum = colorBold Vivid Green
  , colorRainbowParens =
    [ colorBold Vivid Magenta
    , colorBold Vivid Cyan
    , color Dull Magenta
    , color Dull Cyan
    , colorBold Dull Magenta
    , colorBold Dull Cyan
    , color Vivid Magenta
    , color Vivid Cyan
    ]
  }

-- | No styling.
colorNull :: Style
colorNull = Style
  { styleColor = Nothing
  , styleBold = False
  , styleItalic = False
  , styleUnderlined = False
  }

-- | Ways to style terminal output.
data Style = Style
  { styleColor :: Maybe (Color, Intensity)
  , styleBold :: Bool
  , styleItalic :: Bool
  , styleUnderlined :: Bool
  }
  deriving (Eq, Generic, Show, Typeable)

color :: Intensity -> Color -> Style
color i c = colorNull {styleColor = Just (c, i)}

colorBold :: Intensity -> Color -> Style
colorBold i c = (color i c) {styleBold = True}

convertStyle :: Style -> AnsiStyle
convertStyle Style {..} =
  mconcat
    [ maybe mempty (uncurry $ flip col) styleColor
    , if styleBold then Ansi.bold else mempty
    , if styleItalic then Ansi.italicized else mempty
    , if styleUnderlined then Ansi.underlined else mempty
    ]
  where
    col = \case
      Vivid -> Ansi.color
      Dull -> Ansi.colorDull