diff --git a/pretty-simple.cabal b/pretty-simple.cabal --- a/pretty-simple.cabal +++ b/pretty-simple.cabal @@ -1,5 +1,5 @@ name: pretty-simple -version: 1.1.0.3 +version: 2.0.0.0 synopsis: pretty printer for data types with a 'Show' instance. description: Please see . homepage: https://github.com/cdepillabout/pretty-simple @@ -22,6 +22,7 @@ hs-source-dirs: src exposed-modules: Text.Pretty.Simple , Text.Pretty.Simple.Internal + , Text.Pretty.Simple.Internal.Color , Text.Pretty.Simple.Internal.Expr , Text.Pretty.Simple.Internal.ExprParser , Text.Pretty.Simple.Internal.ExprToOutput diff --git a/src/Text/Pretty/Simple.hs b/src/Text/Pretty/Simple.hs --- a/src/Text/Pretty/Simple.hs +++ b/src/Text/Pretty/Simple.hs @@ -20,30 +20,52 @@ 'pPrint' is the main go-to function when debugging Haskell code. 'pShow' and 'pString' are slight variations on 'pPrint'. -The other variations of 'pPrint', 'pShow', and 'pString' are for printing -without color and changing the indentation amount. Most users can ignore these. +'pPrint', 'pShow', and 'pString' will pretty-print in color using ANSI escape +codes. They look good on a console with a dark (black) background. The +variations 'pPrintLightBg', 'pShowLightBg', and 'pStringLightBg' are for +printing in color to a console with a light (white) background. The variations +'pPrintNoColor', 'pShowNoColor', and 'pStringNoColor' are for pretty-printing +without using color. +The variations 'pPrintOpt', 'pShowOpt', and 'pStringOpt' are used when +specifying the 'OutputOptions'. Most users can ignore these. + See the Examples section at the end of this module for examples of acutally -using 'pPrint'. +using 'pPrint'. See the + +for examples of printing in color. -} module Text.Pretty.Simple ( - -- * Output With Color - pShow - , pPrint + -- * Output with color on dark background + pPrint + , pShow , pString - -- * Output With NO Color - , pShowNoColor + -- * Aliases for output with color on dark background + , pPrintDarkBg + , pShowDarkBg + , pStringDarkBg + -- * Output with color on light background + , pPrintLightBg + , pShowLightBg + , pStringLightBg + -- * Output with NO color , pPrintNoColor + , pShowNoColor , pStringNoColor - -- * Output With Output Options - , pShowOpt + -- * Output With 'OutputOptions' , pPrintOpt + , pShowOpt , pStringOpt + -- * 'OutputOptions' , OutputOptions(..) - , UseColor(..) - , defaultOutputOptions - , noColorOutputOptions + , defaultOutputOptionsDarkBg + , defaultOutputOptionsLightBg + , defaultOutputOptionsNoColor + -- * 'ColorOptions' + -- $colorOptions + , defaultColorOptionsDarkBg + , defaultColorOptionsLightBg -- * Examples -- $examples ) where @@ -60,12 +82,14 @@ import Data.Text.Lazy.IO as LText import Text.Pretty.Simple.Internal - (OutputOptions(..), UseColor(..), defaultOutputOptions, + (OutputOptions(..), defaultColorOptionsDarkBg, + defaultColorOptionsLightBg, defaultOutputOptionsDarkBg, + defaultOutputOptionsLightBg, defaultOutputOptionsNoColor, expressionParse, expressionsToOutputs, render) ------------------------------- --- normal (color) functions -- ------------------------------- +---------------------------------------------------------- +-- functions for printing in color to a dark background -- +---------------------------------------------------------- -- | Pretty-print any data type that has a 'Show' instance. -- @@ -75,13 +99,17 @@ -- @ -- pPrint :: Show a => a -> IO () -- @ +-- +-- This function is for printing to a dark background. pPrint :: (MonadIO m, Show a) => a -> m () -pPrint = pPrintOpt defaultOutputOptions +pPrint = pPrintOpt defaultOutputOptionsDarkBg -- | Similar to 'pPrint', but just return the resulting pretty-printed data -- type as a 'Text' instead of printing it to the screen. +-- +-- This function is for printing to a dark background. pShow :: Show a => a -> Text -pShow = pShowOpt defaultOutputOptions +pShow = pShowOpt defaultOutputOptionsDarkBg -- | Similar to 'pShow', but the first argument is a 'String' representing a -- data type that has already been 'show'ed. @@ -90,13 +118,47 @@ -- only requirement is that the strings are quoted, and braces, parentheses, and -- brackets are correctly used to represent indentation. For example, -- 'pString' will correctly pretty-print JSON. +-- +-- This function is for printing to a dark background. pString :: String -> Text -pString = pStringOpt defaultOutputOptions +pString = pStringOpt defaultOutputOptionsDarkBg ------------------------- --- no-color functions -- ------------------------- +-------------------------------------------------------- +-- aliases for printing in color to a dark background -- +-------------------------------------------------------- +-- | Alias for 'pPrint'. +pPrintDarkBg :: (MonadIO m, Show a) => a -> m () +pPrintDarkBg = pPrint + +-- | Alias for 'pShow'. +pShowDarkBg :: Show a => a -> Text +pShowDarkBg = pShow + +-- | Alias for 'pString'. +pStringDarkBg :: String -> Text +pStringDarkBg = pString + +----------------------------------------------------------- +-- functions for printing in color to a light background -- +----------------------------------------------------------- + +-- | Just like 'pPrintDarkBg', but for printing to a light background. +pPrintLightBg :: (MonadIO m, Show a) => a -> m () +pPrintLightBg = pPrintOpt defaultOutputOptionsLightBg + +-- | Just like 'pShowDarkBg', but for printing to a light background. +pShowLightBg :: Show a => a -> Text +pShowLightBg = pShowOpt defaultOutputOptionsLightBg + +-- | Just like 'pStringDarkBg', but for printing to a light background. +pStringLightBg :: String -> Text +pStringLightBg = pStringOpt defaultOutputOptionsLightBg + +------------------------------------------ +-- functions for printing without color -- +------------------------------------------ + -- | Similar to 'pPrint', but doesn't print in color. However, data types -- will still be indented nicely. -- @@ -106,20 +168,15 @@ -- , "bye" -- ] pPrintNoColor :: (MonadIO m, Show a) => a -> m () -pPrintNoColor = pPrintOpt noColorOutputOptions +pPrintNoColor = pPrintOpt defaultOutputOptionsNoColor -- | Like 'pShow', but without color. pShowNoColor :: Show a => a -> Text -pShowNoColor = pShowOpt noColorOutputOptions +pShowNoColor = pShowOpt defaultOutputOptionsNoColor -- | LIke 'pString', but without color. pStringNoColor :: String -> Text -pStringNoColor = pStringOpt noColorOutputOptions - --- | 'noColorOutputOptions' is just like 'defaultOutputOptions', but --- 'outputOptionsUseColor' is set to 'NoColor'. -noColorOutputOptions :: OutputOptions -noColorOutputOptions = defaultOutputOptions {outputOptionsUseColor = NoColor} +pStringNoColor = pStringOpt defaultOutputOptionsNoColor --------------------------------- -- functions that take options -- @@ -133,7 +190,7 @@ -- -- This is what the normal indentation looks like: -- --- >>> pPrintOpt noColorOutputOptions $ Just ("hello", "bye") +-- >>> pPrintOpt defaultOutputOptionsNoColor $ Just ("hello", "bye") -- Just -- ( "hello" -- , "bye" @@ -141,7 +198,7 @@ -- -- This is what smaller indentation looks like: -- --- >>> let smallIndent = noColorOutputOptions {outputOptionsIndentAmount = 1} +-- >>> let smallIndent = defaultOutputOptionsNoColor {outputOptionsIndentAmount = 1} -- >>> pPrintOpt smallIndent $ Just ("hello", "bye") -- Just -- ( "hello" @@ -163,6 +220,11 @@ Left _ -> pack string Right expressions -> render outputOptions . toList $ expressionsToOutputs expressions + +-- $colorOptions +-- +-- Additional settings for color options can be found in +-- 'Text.Pretty.Simple.Internal.Color'. -- $examples -- diff --git a/src/Text/Pretty/Simple/Internal.hs b/src/Text/Pretty/Simple/Internal.hs --- a/src/Text/Pretty/Simple/Internal.hs +++ b/src/Text/Pretty/Simple/Internal.hs @@ -11,6 +11,7 @@ ( module X ) where +import Text.Pretty.Simple.Internal.Color as X import Text.Pretty.Simple.Internal.ExprParser as X import Text.Pretty.Simple.Internal.Expr as X import Text.Pretty.Simple.Internal.ExprToOutput as X diff --git a/src/Text/Pretty/Simple/Internal/Color.hs b/src/Text/Pretty/Simple/Internal/Color.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pretty/Simple/Internal/Color.hs @@ -0,0 +1,307 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +{-| +Module : Text.Pretty.Simple.Internal.OutputPrinter +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.Text.Lazy.Builder (Builder, fromString) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import System.Console.ANSI + (Color(..), ColorIntensity(..), ConsoleIntensity(..), + ConsoleLayer(..), SGR(..), setSGRCode) + +-- | These options are for colorizing the output of functions like 'pPrint'. +-- +-- For example, if you set 'colorQuote' to something like 'colorVividBlueBold', +-- then the quote character (@\"@) will be output as bright blue in bold. +-- +-- If you don't want to use a color for one of the options, use 'colorNull'. +data ColorOptions = ColorOptions + { colorQuote :: Builder + -- ^ Color to use for quote characters (@\"@) around strings. + , colorString :: Builder + -- ^ Color to use for strings. + , colorError :: Builder + -- ^ (currently not used) + , colorNum :: Builder + -- ^ (currently not used) + , colorRainbowParens :: [Builder] + -- ^ A list of 'Builder' 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) + +------------------------------------ +-- Dark background default colors -- +------------------------------------ + +-- | Default color options for use on a dark background. +-- +-- 'colorQuote' is 'defaultColorQuoteDarkBg'. 'colorString' is +-- 'defaultColorStringDarkBg'. 'colorError' is 'defaultColorErrorDarkBg'. +-- 'colorNum' is 'defaultColorNumDarkBg'. 'colorRainbowParens' is +-- 'defaultColorRainboxParensDarkBg'. +defaultColorOptionsDarkBg :: ColorOptions +defaultColorOptionsDarkBg = + ColorOptions + { colorQuote = defaultColorQuoteDarkBg + , colorString = defaultColorStringDarkBg + , colorError = defaultColorErrorDarkBg + , colorNum = defaultColorNumDarkBg + , colorRainbowParens = defaultColorRainbowParensDarkBg + } + +-- | Default color for 'colorQuote' for dark backgrounds. This is +-- 'colorVividWhiteBold'. +defaultColorQuoteDarkBg :: Builder +defaultColorQuoteDarkBg = colorVividWhiteBold + +-- | Default color for 'colorString' for dark backgrounds. This is +-- 'colorVividBlueBold'. +defaultColorStringDarkBg :: Builder +defaultColorStringDarkBg = colorVividBlueBold + +-- | Default color for 'colorError' for dark backgrounds. This is +-- 'colorVividRedBold'. +defaultColorErrorDarkBg :: Builder +defaultColorErrorDarkBg = colorVividRedBold + +-- | Default color for 'colorNum' for dark backgrounds. This is +-- 'colorVividGreenBold'. +defaultColorNumDarkBg :: Builder +defaultColorNumDarkBg = colorVividGreenBold + +-- | Default colors for 'colorRainbowParens' for dark backgrounds. +defaultColorRainbowParensDarkBg :: [Builder] +defaultColorRainbowParensDarkBg = + [ colorVividMagentaBold + , colorVividCyanBold + , colorVividYellowBold + , colorDullMagenta + , colorDullCyan + , colorDullYellow + , colorDullMagentaBold + , colorDullCyanBold + , colorDullYellowBold + , colorVividMagenta + , colorVividCyan + , colorVividYellow + ] + +------------------------------------- +-- Light background default colors -- +------------------------------------- + +-- | Default color options for use on a light background. +-- +-- 'colorQuote' is 'defaultColorQuoteLightBg'. 'colorString' is +-- 'defaultColorStringLightBg'. 'colorError' is 'defaultColorErrorLightBg'. +-- 'colorNum' is 'defaultColorNumLightBg'. 'colorRainbowParens' is +-- 'defaultColorRainboxParensLightBg'. +defaultColorOptionsLightBg :: ColorOptions +defaultColorOptionsLightBg = + ColorOptions + { colorQuote = defaultColorQuoteLightBg + , colorString = defaultColorStringLightBg + , colorError = defaultColorErrorLightBg + , colorNum = defaultColorNumLightBg + , colorRainbowParens = defaultColorRainbowParensLightBg + } + +-- | Default color for 'colorQuote' for light backgrounds. This is +-- 'colorVividWhiteBold'. +defaultColorQuoteLightBg :: Builder +defaultColorQuoteLightBg = colorVividBlackBold + +-- | Default color for 'colorString' for light backgrounds. This is +-- 'colorVividBlueBold'. +defaultColorStringLightBg :: Builder +defaultColorStringLightBg = colorVividBlueBold + +-- | Default color for 'colorError' for light backgrounds. This is +-- 'colorVividRedBold'. +defaultColorErrorLightBg :: Builder +defaultColorErrorLightBg = colorVividRedBold + +-- | Default color for 'colorNum' for light backgrounds. This is +-- 'colorVividGreenBold'. +defaultColorNumLightBg :: Builder +defaultColorNumLightBg = colorVividGreenBold + +-- | Default colors for 'colorRainbowParens' for light backgrounds. +defaultColorRainbowParensLightBg :: [Builder] +defaultColorRainbowParensLightBg = + [ colorVividMagentaBold + , colorVividCyanBold + , colorDullMagenta + , colorDullCyan + , colorDullMagentaBold + , colorDullCyanBold + , colorVividMagenta + , colorVividCyan + ] + +----------------------- +-- Vivid Bold Colors -- +----------------------- + +colorVividBlackBold :: Builder +colorVividBlackBold = colorBold `mappend` colorVividBlack + +colorVividBlueBold :: Builder +colorVividBlueBold = colorBold `mappend` colorVividBlue + +colorVividCyanBold :: Builder +colorVividCyanBold = colorBold `mappend` colorVividCyan + +colorVividGreenBold :: Builder +colorVividGreenBold = colorBold `mappend` colorVividGreen + +colorVividMagentaBold :: Builder +colorVividMagentaBold = colorBold `mappend` colorVividMagenta + +colorVividRedBold :: Builder +colorVividRedBold = colorBold `mappend` colorVividRed + +colorVividWhiteBold :: Builder +colorVividWhiteBold = colorBold `mappend` colorVividWhite + +colorVividYellowBold :: Builder +colorVividYellowBold = colorBold `mappend` colorVividYellow + +----------------------- +-- Dull Bold Colors -- +----------------------- + +colorDullBlackBold :: Builder +colorDullBlackBold = colorBold `mappend` colorDullBlack + +colorDullBlueBold :: Builder +colorDullBlueBold = colorBold `mappend` colorDullBlue + +colorDullCyanBold :: Builder +colorDullCyanBold = colorBold `mappend` colorDullCyan + +colorDullGreenBold :: Builder +colorDullGreenBold = colorBold `mappend` colorDullGreen + +colorDullMagentaBold :: Builder +colorDullMagentaBold = colorBold `mappend` colorDullMagenta + +colorDullRedBold :: Builder +colorDullRedBold = colorBold `mappend` colorDullRed + +colorDullWhiteBold :: Builder +colorDullWhiteBold = colorBold `mappend` colorDullWhite + +colorDullYellowBold :: Builder +colorDullYellowBold = colorBold `mappend` colorDullYellow + +------------------ +-- Vivid Colors -- +------------------ + +colorVividBlack :: Builder +colorVividBlack = colorHelper Vivid Black + +colorVividBlue :: Builder +colorVividBlue = colorHelper Vivid Blue + +colorVividCyan :: Builder +colorVividCyan = colorHelper Vivid Cyan + +colorVividGreen :: Builder +colorVividGreen = colorHelper Vivid Green + +colorVividMagenta :: Builder +colorVividMagenta = colorHelper Vivid Magenta + +colorVividRed :: Builder +colorVividRed = colorHelper Vivid Red + +colorVividWhite :: Builder +colorVividWhite = colorHelper Vivid White + +colorVividYellow :: Builder +colorVividYellow = colorHelper Vivid Yellow + +------------------ +-- Dull Colors -- +------------------ + +colorDullBlack :: Builder +colorDullBlack = colorHelper Dull Black + +colorDullBlue :: Builder +colorDullBlue = colorHelper Dull Blue + +colorDullCyan :: Builder +colorDullCyan = colorHelper Dull Cyan + +colorDullGreen :: Builder +colorDullGreen = colorHelper Dull Green + +colorDullMagenta :: Builder +colorDullMagenta = colorHelper Dull Magenta + +colorDullRed :: Builder +colorDullRed = colorHelper Dull Red + +colorDullWhite :: Builder +colorDullWhite = colorHelper Dull White + +colorDullYellow :: Builder +colorDullYellow = colorHelper Dull Yellow + +-------------------- +-- Special Colors -- +-------------------- + +-- | Change the intensity to 'BoldIntensity'. +colorBold :: Builder +colorBold = setSGRCodeBuilder [SetConsoleIntensity BoldIntensity] + +-- | 'Reset' the console color back to normal. +colorReset :: Builder +colorReset = setSGRCodeBuilder [Reset] + +-- | Empty string. +colorNull :: Builder +colorNull = "" + +------------- +-- Helpers -- +------------- + +-- | Helper for creating a 'Builder' for an ANSI escape sequence color based on +-- a 'ColorIntensity' and a 'Color'. +colorHelper :: ColorIntensity -> Color -> Builder +colorHelper colorIntensity color = + setSGRCodeBuilder [SetColor Foreground colorIntensity color] + +-- | Convert a list of 'SGR' to a 'Builder'. +setSGRCodeBuilder :: [SGR] -> Builder +setSGRCodeBuilder = fromString . setSGRCode + diff --git a/src/Text/Pretty/Simple/Internal/OutputPrinter.hs b/src/Text/Pretty/Simple/Internal/OutputPrinter.hs --- a/src/Text/Pretty/Simple/Internal/OutputPrinter.hs +++ b/src/Text/Pretty/Simple/Internal/OutputPrinter.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -26,46 +27,64 @@ #endif import Control.Monad.Reader (MonadReader(reader), runReader) -import Data.Data (Data) import Data.Foldable (fold, foldlM) import Data.Text.Lazy (Text) import Data.Text.Lazy.Builder (Builder, fromString, toLazyText) import Data.Typeable (Typeable) import GHC.Generics (Generic) -import System.Console.ANSI - (Color(..), ColorIntensity(..), ConsoleIntensity(..), - ConsoleLayer(..), SGR(..), setSGRCode) +import Text.Pretty.Simple.Internal.Color + (ColorOptions(..), colorReset, defaultColorOptionsDarkBg, + defaultColorOptionsLightBg) import Text.Pretty.Simple.Internal.Output (NestLevel(..), Output(..), OutputType(..)) --- | 'UseColor' describes whether or not we want to use color when printing the --- 'Output' list. -data UseColor - = NoColor - | UseColor - deriving (Data, Eq, Generic, Read, Show, Typeable) - -- | Data-type wrapping up all the options available when rendering the list -- of 'Output's. data OutputOptions = OutputOptions { outputOptionsIndentAmount :: Int -- ^ Number of spaces to use when indenting. It should probably be either 2 -- or 4. - , outputOptionsUseColor :: UseColor - -- ^ Whether or not to use ansi escape sequences to print colors. - } deriving (Data, Eq, Generic, Read, Show, Typeable) + , outputOptionsColorOptions :: Maybe ColorOptions + -- ^ If this is 'Nothing', then don't colorize the output. If this is + -- @'Just' colorOptions@, then use @colorOptions@ to colorize the output. + } deriving (Eq, Generic, Show, Typeable) --- | Default values for 'OutputOptions'. 'outputOptionsIndentAmount' defaults --- to 4, and 'outputOptionsUseColor' defaults to 'UseColor'. -defaultOutputOptions :: OutputOptions -defaultOutputOptions = +-- | Default values for 'OutputOptions' when printing to a console with a dark +-- background. 'outputOptionsIndentAmount' is 4, and +-- 'outputOptionsColorOptions' is 'defaultColorOptionsDarkBg'. +defaultOutputOptionsDarkBg :: OutputOptions +defaultOutputOptionsDarkBg = OutputOptions - {outputOptionsIndentAmount = 4, outputOptionsUseColor = UseColor} + { outputOptionsIndentAmount = 4 + , outputOptionsColorOptions = Just defaultColorOptionsDarkBg + } +-- | Default values for 'OutputOptions' when printing to a console with a light +-- background. 'outputOptionsIndentAmount' is 4, and +-- 'outputOptionsColorOptions' is 'defaultColorOptionsLightBg'. +defaultOutputOptionsLightBg :: OutputOptions +defaultOutputOptionsLightBg = + OutputOptions + { outputOptionsIndentAmount = 4 + , outputOptionsColorOptions = Just defaultColorOptionsLightBg + } + +-- | Default values for 'OutputOptions' when printing using using ANSI escape +-- sequences for color. 'outputOptionsIndentAmount' is 4, and +-- 'outputOptionsColorOptions' is 'Nothing'. +defaultOutputOptionsNoColor :: OutputOptions +defaultOutputOptionsNoColor = + OutputOptions + {outputOptionsIndentAmount = 4, outputOptionsColorOptions = Nothing} + +-- | Given 'OutputOptions' and a list of 'Output', turn the 'Output' into a +-- lazy 'Text'. render :: OutputOptions -> [Output] -> Text render options outputs = toLazyText $ runReader (renderOutputs outputs) options +-- | Turn a list of 'Output' into a 'Builder', using the options specified in +-- the 'OutputOptions'. renderOutputs :: forall m. MonadReader OutputOptions m @@ -75,12 +94,8 @@ foldFunc :: Builder -> Output -> m Builder foldFunc accum output = mappend accum <$> renderOutput output -renderRaibowParenFor - :: MonadReader OutputOptions m - => NestLevel -> Builder -> m Builder -renderRaibowParenFor nest string = - sequenceFold [rainbowParen nest, pure string, colorReset] - +-- | Render a single 'Output' as a 'Builder', using the options specified in +-- the 'OutputOptions'. renderOutput :: MonadReader OutputOptions m => Output -> m Builder renderOutput (Output nest OutputCloseBrace) = renderRaibowParenFor nest "}" renderOutput (Output nest OutputCloseBracket) = renderRaibowParenFor nest "]" @@ -98,16 +113,71 @@ pure $ fromString string renderOutput (Output _ (OutputStringLit string)) = do sequenceFold - [ colorQuote + [ useColorQuote , pure "\"" - , colorString + , useColorReset + , useColorString -- TODO: This probably shouldn't be a string to begin with. , pure $ fromString string - , colorQuote + , useColorReset + , useColorQuote , pure "\"" - , colorReset + , useColorReset ] +-- | Produce a 'Builder' corresponding to the ANSI escape sequence for the +-- color for the @\"@, based on whether or not 'outputOptionsColorOptions' is +-- 'Just' or 'Nothing', and the value of 'colorQuote'. +useColorQuote :: forall m. MonadReader OutputOptions m => m Builder +useColorQuote = maybe "" colorQuote <$> reader outputOptionsColorOptions + +-- | Produce a 'Builder' corresponding to the ANSI escape sequence for the +-- color for the characters of a string, based on whether or not +-- 'outputOptionsColorOptions' is 'Just' or 'Nothing', and the value of +-- 'colorString'. +useColorString :: forall m. MonadReader OutputOptions m => m Builder +useColorString = maybe "" colorString <$> reader outputOptionsColorOptions + +useColorError :: forall m. MonadReader OutputOptions m => m Builder +useColorError = maybe "" colorError <$> reader outputOptionsColorOptions + +useColorNum :: forall m. MonadReader OutputOptions m => m Builder +useColorNum = maybe "" colorNum <$> reader outputOptionsColorOptions + +-- | Produce a 'Builder' corresponding to the ANSI escape sequence for +-- resetting the console color back to the default. Produces an empty 'Builder' +-- if 'outputOptionsColorOptions' is 'Nothing'. +useColorReset :: forall m. MonadReader OutputOptions m => m Builder +useColorReset = maybe "" (const colorReset) <$> reader outputOptionsColorOptions + +-- | Produce a 'Builder' representing the ANSI escape sequence for the color of +-- the rainbow parenthesis, given an input 'NestLevel' and 'Builder' to use as +-- the input character. +-- +-- If 'outputOptionsColorOptions' is 'Nothing', then just return the input +-- character. If it is 'Just', then return the input character colorized. +renderRaibowParenFor + :: MonadReader OutputOptions m + => NestLevel -> Builder -> m Builder +renderRaibowParenFor nest string = + sequenceFold [useColorRainbowParens nest, pure string, useColorReset] + +useColorRainbowParens + :: forall m. + MonadReader OutputOptions m + => NestLevel -> m Builder +useColorRainbowParens nest = do + maybeOutputColor <- reader outputOptionsColorOptions + pure $ + case maybeOutputColor of + Just ColorOptions {colorRainbowParens} -> do + let choicesLen = length colorRainbowParens + if choicesLen == 0 + then "" + else colorRainbowParens !! (unNestLevel nest `mod` choicesLen) + Nothing -> "" + +-- | This is simply @'fmap' 'fold' '.' 'sequence'@. sequenceFold :: (Monad f, Monoid a, Traversable t) => t (f a) -> f a sequenceFold = fmap fold . sequence @@ -155,89 +225,3 @@ shrinkWhitespace (' ':' ':t) = shrinkWhitespace (' ':t) shrinkWhitespace (h:t) = h : shrinkWhitespace t shrinkWhitespace "" = "" - ------------------------ --- High-level colors -- ------------------------ - -colorQuote :: MonadReader OutputOptions m => m Builder -colorQuote = appendColors colorBold colorVividWhite - -colorString :: MonadReader OutputOptions m => m Builder -colorString = appendColors colorBold colorVividBlue - -colorError :: MonadReader OutputOptions m => m Builder -colorError = appendColors colorBold colorVividRed - -colorNum :: MonadReader OutputOptions m => m Builder -colorNum = appendColors colorBold colorVividGreen - -rainbowParen - :: forall m. - MonadReader OutputOptions m - => NestLevel -> m Builder -rainbowParen (NestLevel nestLevel) = - let choicesLen = length rainbowParenChoices - in rainbowParenChoices !! (nestLevel `mod` choicesLen) - where - rainbowParenChoices :: [m Builder] - rainbowParenChoices = - [ appendColors colorBold colorVividMagenta - , appendColors colorBold colorVividCyan - , appendColors colorBold colorVividYellow - ] - ----------------------- --- Low-level Colors -- ----------------------- - -canUseColor :: MonadReader OutputOptions m => m Bool -canUseColor = do - color <- reader outputOptionsUseColor - case color of - NoColor -> pure False - UseColor -> pure True - -ifM :: Monad m => m Bool -> a -> a -> m a -ifM comparisonM thenValue elseValue = do - res <- comparisonM - case res of - True -> pure thenValue - False -> pure elseValue - -colorBold :: MonadReader OutputOptions m => m Builder -colorBold = ifM canUseColor (setSGRCodeBuilder [SetConsoleIntensity BoldIntensity]) "" - -colorReset :: MonadReader OutputOptions m => m Builder -colorReset = ifM canUseColor (setSGRCodeBuilder [Reset]) "" - -colorVividBlue :: MonadReader OutputOptions m => m Builder -colorVividBlue = colorHelper Vivid Blue - -colorVividCyan :: MonadReader OutputOptions m => m Builder -colorVividCyan = colorHelper Vivid Cyan - -colorVividGreen :: MonadReader OutputOptions m => m Builder -colorVividGreen = colorHelper Vivid Green - -colorVividMagenta :: MonadReader OutputOptions m => m Builder -colorVividMagenta = colorHelper Vivid Magenta - -colorVividRed :: MonadReader OutputOptions m => m Builder -colorVividRed = colorHelper Vivid Red - -colorVividWhite :: MonadReader OutputOptions m => m Builder -colorVividWhite = colorHelper Vivid White - -colorVividYellow :: MonadReader OutputOptions m => m Builder -colorVividYellow = colorHelper Vivid Yellow - -colorHelper :: MonadReader OutputOptions m => ColorIntensity -> Color -> m Builder -colorHelper colorIntensity color = - ifM canUseColor (setSGRCodeBuilder [SetColor Foreground colorIntensity color]) "" - -appendColors :: MonadReader OutputOptions m => m Builder -> m Builder -> m Builder -appendColors color1 color2 = mappend <$> color1 <*> color2 - -setSGRCodeBuilder :: [SGR] -> Builder -setSGRCodeBuilder = fromString . setSGRCode