{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# 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.OutputPrinter
  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 Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (MonadReader(ask, reader), runReader)
import Data.Char (isPrint, isSpace, ord)
import Numeric (showHex)
import Data.Foldable (fold)
import Data.Text.Lazy (Text)
import Data.Text.Lazy.Builder (Builder, fromString, toLazyText)
import Data.Typeable (Typeable)
import Data.List (dropWhileEnd, intercalate)
import Data.Maybe (fromMaybe)
import Text.Read (readMaybe)
import GHC.Generics (Generic)
import System.IO (Handle, hIsTerminalDevice)

import Text.Pretty.Simple.Internal.Color
       (ColorOptions(..), colorReset, defaultColorOptionsDarkBg,
        defaultColorOptionsLightBg)
import Text.Pretty.Simple.Internal.Output
       (NestLevel(..), Output(..), OutputType(..))

-- | Determines whether pretty-simple should check if the output 'Handle' is a
-- TTY device.  Normally, users only want to print in color if the output
-- 'Handle' is a TTY device.
data CheckColorTty
  = CheckColorTty
  -- ^ Check if the output 'Handle' is a TTY device.  If the output 'Handle' is
  -- a TTY device, determine whether to print in color based on
  -- 'outputOptionsColorOptions'. If not, then set 'outputOptionsColorOptions'
  -- to 'Nothing' so the output does not get colorized.
  | NoCheckColorTty
  -- ^ Don't check if the output 'Handle' is a TTY device.  Determine whether to
  -- colorize the output based solely on the value of
  -- 'outputOptionsColorOptions'.
  deriving (CheckColorTty -> CheckColorTty -> Bool
(CheckColorTty -> CheckColorTty -> Bool)
-> (CheckColorTty -> CheckColorTty -> Bool) -> Eq CheckColorTty
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CheckColorTty -> CheckColorTty -> Bool
$c/= :: CheckColorTty -> CheckColorTty -> Bool
== :: CheckColorTty -> CheckColorTty -> Bool
$c== :: CheckColorTty -> CheckColorTty -> Bool
Eq, (forall x. CheckColorTty -> Rep CheckColorTty x)
-> (forall x. Rep CheckColorTty x -> CheckColorTty)
-> Generic CheckColorTty
forall x. Rep CheckColorTty x -> CheckColorTty
forall x. CheckColorTty -> Rep CheckColorTty x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CheckColorTty x -> CheckColorTty
$cfrom :: forall x. CheckColorTty -> Rep CheckColorTty x
Generic, Int -> CheckColorTty -> ShowS
[CheckColorTty] -> ShowS
CheckColorTty -> String
(Int -> CheckColorTty -> ShowS)
-> (CheckColorTty -> String)
-> ([CheckColorTty] -> ShowS)
-> Show CheckColorTty
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CheckColorTty] -> ShowS
$cshowList :: [CheckColorTty] -> ShowS
show :: CheckColorTty -> String
$cshow :: CheckColorTty -> String
showsPrec :: Int -> CheckColorTty -> ShowS
$cshowsPrec :: Int -> CheckColorTty -> ShowS
Show, Typeable)

-- | Data-type wrapping up all the options available when rendering the list
-- of 'Output's.
data OutputOptions = OutputOptions
  { OutputOptions -> Int
outputOptionsIndentAmount :: Int
  -- ^ Number of spaces to use when indenting.  It should probably be either 2
  -- or 4.
  , OutputOptions -> Maybe ColorOptions
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.
  --
  , OutputOptions -> Bool
outputOptionsEscapeNonPrintable :: Bool
  -- ^ Whether to replace non-printable characters with hexadecimal escape
  -- sequences.
  } deriving (OutputOptions -> OutputOptions -> Bool
(OutputOptions -> OutputOptions -> Bool)
-> (OutputOptions -> OutputOptions -> Bool) -> Eq OutputOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OutputOptions -> OutputOptions -> Bool
$c/= :: OutputOptions -> OutputOptions -> Bool
== :: OutputOptions -> OutputOptions -> Bool
$c== :: OutputOptions -> OutputOptions -> Bool
Eq, (forall x. OutputOptions -> Rep OutputOptions x)
-> (forall x. Rep OutputOptions x -> OutputOptions)
-> Generic OutputOptions
forall x. Rep OutputOptions x -> OutputOptions
forall x. OutputOptions -> Rep OutputOptions x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep OutputOptions x -> OutputOptions
$cfrom :: forall x. OutputOptions -> Rep OutputOptions x
Generic, Int -> OutputOptions -> ShowS
[OutputOptions] -> ShowS
OutputOptions -> String
(Int -> OutputOptions -> ShowS)
-> (OutputOptions -> String)
-> ([OutputOptions] -> ShowS)
-> Show OutputOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OutputOptions] -> ShowS
$cshowList :: [OutputOptions] -> ShowS
show :: OutputOptions -> String
$cshow :: OutputOptions -> String
showsPrec :: Int -> OutputOptions -> ShowS
$cshowsPrec :: Int -> OutputOptions -> ShowS
Show, Typeable)

-- | Default values for 'OutputOptions' when printing to a console with a dark
-- background.  'outputOptionsIndentAmount' is 4, and
-- 'outputOptionsColorOptions' is 'defaultColorOptionsDarkBg'.
defaultOutputOptionsDarkBg :: OutputOptions
defaultOutputOptionsDarkBg :: OutputOptions
defaultOutputOptionsDarkBg =
  OutputOptions :: Int -> Maybe ColorOptions -> Bool -> OutputOptions
OutputOptions
  { outputOptionsIndentAmount :: Int
outputOptionsIndentAmount = 4
  , outputOptionsColorOptions :: Maybe ColorOptions
outputOptionsColorOptions = ColorOptions -> Maybe ColorOptions
forall a. a -> Maybe a
Just ColorOptions
defaultColorOptionsDarkBg
  , outputOptionsEscapeNonPrintable :: Bool
outputOptionsEscapeNonPrintable = Bool
True
  }

-- | Default values for 'OutputOptions' when printing to a console with a light
-- background.  'outputOptionsIndentAmount' is 4, and
-- 'outputOptionsColorOptions' is 'defaultColorOptionsLightBg'.
defaultOutputOptionsLightBg :: OutputOptions
defaultOutputOptionsLightBg :: OutputOptions
defaultOutputOptionsLightBg =
  OutputOptions :: Int -> Maybe ColorOptions -> Bool -> OutputOptions
OutputOptions
  { outputOptionsIndentAmount :: Int
outputOptionsIndentAmount = 4
  , outputOptionsColorOptions :: Maybe ColorOptions
outputOptionsColorOptions = ColorOptions -> Maybe ColorOptions
forall a. a -> Maybe a
Just ColorOptions
defaultColorOptionsLightBg
  , outputOptionsEscapeNonPrintable :: Bool
outputOptionsEscapeNonPrintable = Bool
True
  }

-- | Default values for 'OutputOptions' when printing using using ANSI escape
-- sequences for color.  'outputOptionsIndentAmount' is 4, and
-- 'outputOptionsColorOptions' is 'Nothing'.
defaultOutputOptionsNoColor :: OutputOptions
defaultOutputOptionsNoColor :: OutputOptions
defaultOutputOptionsNoColor =
  OutputOptions :: Int -> Maybe ColorOptions -> Bool -> OutputOptions
OutputOptions
  { outputOptionsIndentAmount :: Int
outputOptionsIndentAmount = 4
  , outputOptionsColorOptions :: Maybe ColorOptions
outputOptionsColorOptions = Maybe ColorOptions
forall a. Maybe a
Nothing
  , outputOptionsEscapeNonPrintable :: Bool
outputOptionsEscapeNonPrintable = Bool
True
  }

-- | Given 'OutputOptions', disable colorful output if the given handle
-- is not connected to a TTY.
hCheckTTY :: MonadIO m => Handle -> OutputOptions -> m OutputOptions
hCheckTTY :: Handle -> OutputOptions -> m OutputOptions
hCheckTTY h :: Handle
h options :: OutputOptions
options = IO OutputOptions -> m OutputOptions
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO OutputOptions -> m OutputOptions)
-> IO OutputOptions -> m OutputOptions
forall a b. (a -> b) -> a -> b
$ Bool -> OutputOptions
conv (Bool -> OutputOptions) -> IO Bool -> IO OutputOptions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Bool
tty
  where
    conv :: Bool -> OutputOptions
    conv :: Bool -> OutputOptions
conv True = OutputOptions
options
    conv False = OutputOptions
options { outputOptionsColorOptions :: Maybe ColorOptions
outputOptionsColorOptions = Maybe ColorOptions
forall a. Maybe a
Nothing }

    tty :: IO Bool
    tty :: IO Bool
tty = Handle -> IO Bool
hIsTerminalDevice Handle
h

-- | Given 'OutputOptions' and a list of 'Output', turn the 'Output' into a
-- lazy 'Text'.
render :: OutputOptions -> [Output] -> Text
render :: OutputOptions -> [Output] -> Text
render options :: OutputOptions
options = Builder -> Text
toLazyText (Builder -> Text) -> ([Output] -> Builder) -> [Output] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Output -> Builder -> Builder) -> Builder -> [Output] -> Builder
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Output -> Builder -> Builder
foldFunc "" ([Output] -> Builder)
-> ([Output] -> [Output]) -> [Output] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Output] -> [Output]
modificationsOutputList
  where
    foldFunc :: Output -> Builder -> Builder
    foldFunc :: Output -> Builder -> Builder
foldFunc output :: Output
output accum :: Builder
accum = Reader OutputOptions Builder -> OutputOptions -> Builder
forall r a. Reader r a -> r -> a
runReader (Output -> Reader OutputOptions Builder
forall (m :: * -> *).
MonadReader OutputOptions m =>
Output -> m Builder
renderOutput Output
output) OutputOptions
options Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
accum

-- | Render a single 'Output' as a 'Builder', using the options specified in
-- the 'OutputOptions'.
renderOutput :: MonadReader OutputOptions m => Output -> m Builder
renderOutput :: Output -> m Builder
renderOutput (Output nest :: NestLevel
nest OutputCloseBrace) = NestLevel -> Builder -> m Builder
forall (m :: * -> *).
MonadReader OutputOptions m =>
NestLevel -> Builder -> m Builder
renderRainbowParenFor NestLevel
nest "}"
renderOutput (Output nest :: NestLevel
nest OutputCloseBracket) = NestLevel -> Builder -> m Builder
forall (m :: * -> *).
MonadReader OutputOptions m =>
NestLevel -> Builder -> m Builder
renderRainbowParenFor NestLevel
nest "]"
renderOutput (Output nest :: NestLevel
nest OutputCloseParen) = NestLevel -> Builder -> m Builder
forall (m :: * -> *).
MonadReader OutputOptions m =>
NestLevel -> Builder -> m Builder
renderRainbowParenFor NestLevel
nest ")"
renderOutput (Output nest :: NestLevel
nest OutputComma) = NestLevel -> Builder -> m Builder
forall (m :: * -> *).
MonadReader OutputOptions m =>
NestLevel -> Builder -> m Builder
renderRainbowParenFor NestLevel
nest ","
renderOutput (Output _ OutputIndent) = do
    Int
indentSpaces <- (OutputOptions -> Int) -> m Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader OutputOptions -> Int
outputOptionsIndentAmount
    Builder -> m Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder -> m Builder)
-> ([Builder] -> Builder) -> [Builder] -> m Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> m Builder) -> [Builder] -> m Builder
forall a b. (a -> b) -> a -> b
$ Int -> Builder -> [Builder]
forall a. Int -> a -> [a]
replicate Int
indentSpaces " "
renderOutput (Output _ OutputNewLine) = Builder -> m Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure "\n"
renderOutput (Output nest :: NestLevel
nest OutputOpenBrace) = NestLevel -> Builder -> m Builder
forall (m :: * -> *).
MonadReader OutputOptions m =>
NestLevel -> Builder -> m Builder
renderRainbowParenFor NestLevel
nest "{"
renderOutput (Output nest :: NestLevel
nest OutputOpenBracket) = NestLevel -> Builder -> m Builder
forall (m :: * -> *).
MonadReader OutputOptions m =>
NestLevel -> Builder -> m Builder
renderRainbowParenFor NestLevel
nest "["
renderOutput (Output nest :: NestLevel
nest OutputOpenParen) = NestLevel -> Builder -> m Builder
forall (m :: * -> *).
MonadReader OutputOptions m =>
NestLevel -> Builder -> m Builder
renderRainbowParenFor NestLevel
nest "("
renderOutput (Output _ (OutputOther string :: String
string)) = do
  Int
indentSpaces <- (OutputOptions -> Int) -> m Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader OutputOptions -> Int
outputOptionsIndentAmount
  let spaces :: String
spaces = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
indentSpaces Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2) ' '
  -- TODO: This probably shouldn't be a string to begin with.
  Builder -> m Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder -> m Builder) -> Builder -> m Builder
forall a b. (a -> b) -> a -> b
$ String -> Builder
fromString (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ String -> ShowS
indentSubsequentLinesWith String
spaces String
string
renderOutput (Output _ (OutputNumberLit number :: String
number)) = do
  [m Builder] -> m Builder
forall (f :: * -> *) a (t :: * -> *).
(Monad f, Monoid a, Traversable t) =>
t (f a) -> f a
sequenceFold
    [ m Builder
forall (m :: * -> *). MonadReader OutputOptions m => m Builder
useColorNum
    , Builder -> m Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Builder
fromString String
number)
    , m Builder
forall (m :: * -> *). MonadReader OutputOptions m => m Builder
useColorReset
    ]
renderOutput (Output _ (OutputStringLit string :: String
string)) = do
  OutputOptions
options <- m OutputOptions
forall r (m :: * -> *). MonadReader r m => m r
ask

  [m Builder] -> m Builder
forall (f :: * -> *) a (t :: * -> *).
(Monad f, Monoid a, Traversable t) =>
t (f a) -> f a
sequenceFold
    [ m Builder
forall (m :: * -> *). MonadReader OutputOptions m => m Builder
useColorQuote
    , Builder -> m Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure "\""
    , m Builder
forall (m :: * -> *). MonadReader OutputOptions m => m Builder
useColorReset
    , m Builder
forall (m :: * -> *). MonadReader OutputOptions m => m Builder
useColorString
    -- TODO: This probably shouldn't be a string to begin with.
    , Builder -> m Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Builder
fromString (OutputOptions -> ShowS
process OutputOptions
options String
string))
    , m Builder
forall (m :: * -> *). MonadReader OutputOptions m => m Builder
useColorReset
    , m Builder
forall (m :: * -> *). MonadReader OutputOptions m => m Builder
useColorQuote
    , Builder -> m Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure "\""
    , m Builder
forall (m :: * -> *). MonadReader OutputOptions m => m Builder
useColorReset
    ]
  where
    process :: OutputOptions -> String -> String
    process :: OutputOptions -> ShowS
process opts :: OutputOptions
opts =
      if OutputOptions -> Bool
outputOptionsEscapeNonPrintable OutputOptions
opts
        then String -> ShowS
indentSubsequentLinesWith String
spaces ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
escapeNonPrintable ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
readStr
        else String -> ShowS
indentSubsequentLinesWith String
spaces ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
readStr
      where
        spaces :: String
        spaces :: String
spaces = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
indentSpaces Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2) ' '

        indentSpaces :: Int
        indentSpaces :: Int
indentSpaces =  OutputOptions -> Int
outputOptionsIndentAmount OutputOptions
opts

        readStr :: String -> String
        readStr :: ShowS
readStr s :: String
s = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
s (Maybe String -> String) -> (String -> Maybe String) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. Read a => String -> Maybe a
readMaybe ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ '"'Char -> ShowS
forall a. a -> [a] -> [a]
:String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\""
renderOutput (Output _ (OutputCharLit string :: String
string)) = do
  [m Builder] -> m Builder
forall (f :: * -> *) a (t :: * -> *).
(Monad f, Monoid a, Traversable t) =>
t (f a) -> f a
sequenceFold
    [ m Builder
forall (m :: * -> *). MonadReader OutputOptions m => m Builder
useColorQuote
    , Builder -> m Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure "'"
    , m Builder
forall (m :: * -> *). MonadReader OutputOptions m => m Builder
useColorReset
    , m Builder
forall (m :: * -> *). MonadReader OutputOptions m => m Builder
useColorString
    , Builder -> m Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Builder
fromString String
string)
    , m Builder
forall (m :: * -> *). MonadReader OutputOptions m => m Builder
useColorReset
    , m Builder
forall (m :: * -> *). MonadReader OutputOptions m => m Builder
useColorQuote
    , Builder -> m Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure "'"
    , m Builder
forall (m :: * -> *). MonadReader OutputOptions m => m Builder
useColorReset
    ]

-- | Replace non-printable characters with hex escape sequences.
--
-- >>> escapeNonPrintable "\x1\x2"
-- "\\x1\\x2"
--
-- Newlines will not be escaped.
--
-- >>> escapeNonPrintable "hello\nworld"
-- "hello\nworld"
--
-- Printable characters will not be escaped.
--
-- >>> escapeNonPrintable "h\101llo"
-- "hello"
escapeNonPrintable :: String -> String
escapeNonPrintable :: ShowS
escapeNonPrintable input :: String
input = (Char -> ShowS) -> String -> ShowS
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> ShowS
escape "" String
input

-- Replace an unprintable character except a newline
-- with a hex escape sequence.
escape :: Char -> ShowS
escape :: Char -> ShowS
escape c :: Char
c
  | Char -> Bool
isPrint Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n' = (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:)
  | Bool
otherwise = ('\\'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ('x'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
showHex (Char -> Int
ord Char
c)

-- |
-- >>> indentSubsequentLinesWith "  " "aaa"
-- "aaa"
--
-- >>> indentSubsequentLinesWith "  " "aaa\nbbb\nccc"
-- "aaa\n  bbb\n  ccc"
--
-- >>> indentSubsequentLinesWith "  " ""
-- ""
indentSubsequentLinesWith :: String -> String -> String
indentSubsequentLinesWith :: String -> ShowS
indentSubsequentLinesWith indent :: String
indent input :: String
input =
  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ([String]
start [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
indent String -> ShowS
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String]
end
  where (start :: [String]
start, end :: [String]
end) = Int -> [String] -> ([String], [String])
forall a. Int -> [a] -> ([a], [a])
splitAt 1 ([String] -> ([String], [String]))
-> [String] -> ([String], [String])
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
input

-- | 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 :: m Builder
useColorQuote = Builder
-> (ColorOptions -> Builder) -> Maybe ColorOptions -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" ColorOptions -> Builder
colorQuote (Maybe ColorOptions -> Builder)
-> m (Maybe ColorOptions) -> m Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (OutputOptions -> Maybe ColorOptions) -> m (Maybe ColorOptions)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader OutputOptions -> Maybe ColorOptions
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 :: m Builder
useColorString = Builder
-> (ColorOptions -> Builder) -> Maybe ColorOptions -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" ColorOptions -> Builder
colorString (Maybe ColorOptions -> Builder)
-> m (Maybe ColorOptions) -> m Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (OutputOptions -> Maybe ColorOptions) -> m (Maybe ColorOptions)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader OutputOptions -> Maybe ColorOptions
outputOptionsColorOptions

useColorError :: forall m. MonadReader OutputOptions m => m Builder
useColorError :: m Builder
useColorError = Builder
-> (ColorOptions -> Builder) -> Maybe ColorOptions -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" ColorOptions -> Builder
colorError (Maybe ColorOptions -> Builder)
-> m (Maybe ColorOptions) -> m Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (OutputOptions -> Maybe ColorOptions) -> m (Maybe ColorOptions)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader OutputOptions -> Maybe ColorOptions
outputOptionsColorOptions

useColorNum :: forall m. MonadReader OutputOptions m => m Builder
useColorNum :: m Builder
useColorNum = Builder
-> (ColorOptions -> Builder) -> Maybe ColorOptions -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" ColorOptions -> Builder
colorNum (Maybe ColorOptions -> Builder)
-> m (Maybe ColorOptions) -> m Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (OutputOptions -> Maybe ColorOptions) -> m (Maybe ColorOptions)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader OutputOptions -> Maybe ColorOptions
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 :: m Builder
useColorReset = Builder
-> (ColorOptions -> Builder) -> Maybe ColorOptions -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (Builder -> ColorOptions -> Builder
forall a b. a -> b -> a
const Builder
colorReset) (Maybe ColorOptions -> Builder)
-> m (Maybe ColorOptions) -> m Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (OutputOptions -> Maybe ColorOptions) -> m (Maybe ColorOptions)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader OutputOptions -> Maybe ColorOptions
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.
renderRainbowParenFor
  :: MonadReader OutputOptions m
  => NestLevel -> Builder -> m Builder
renderRainbowParenFor :: NestLevel -> Builder -> m Builder
renderRainbowParenFor nest :: NestLevel
nest string :: Builder
string =
  [m Builder] -> m Builder
forall (f :: * -> *) a (t :: * -> *).
(Monad f, Monoid a, Traversable t) =>
t (f a) -> f a
sequenceFold [NestLevel -> m Builder
forall (m :: * -> *).
MonadReader OutputOptions m =>
NestLevel -> m Builder
useColorRainbowParens NestLevel
nest, Builder -> m Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure Builder
string, m Builder
forall (m :: * -> *). MonadReader OutputOptions m => m Builder
useColorReset]

useColorRainbowParens
  :: forall m.
     MonadReader OutputOptions m
  => NestLevel -> m Builder
useColorRainbowParens :: NestLevel -> m Builder
useColorRainbowParens nest :: NestLevel
nest = do
  Maybe ColorOptions
maybeOutputColor <- (OutputOptions -> Maybe ColorOptions) -> m (Maybe ColorOptions)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader OutputOptions -> Maybe ColorOptions
outputOptionsColorOptions
  Builder -> m Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder -> m Builder) -> Builder -> m Builder
forall a b. (a -> b) -> a -> b
$
    case Maybe ColorOptions
maybeOutputColor of
      Just ColorOptions {[Builder]
colorRainbowParens :: ColorOptions -> [Builder]
colorRainbowParens :: [Builder]
colorRainbowParens} -> do
        let choicesLen :: Int
choicesLen = [Builder] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Builder]
colorRainbowParens
        if Int
choicesLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
          then ""
          else [Builder]
colorRainbowParens [Builder] -> Int -> Builder
forall a. [a] -> Int -> a
!! (NestLevel -> Int
unNestLevel NestLevel
nest Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
choicesLen)
      Nothing -> ""

-- | This is simply @'fmap' 'fold' '.' 'sequence'@.
sequenceFold :: (Monad f, Monoid a, Traversable t) => t (f a) -> f a
sequenceFold :: t (f a) -> f a
sequenceFold = (t a -> a) -> f (t a) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t a -> a
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (f (t a) -> f a) -> (t (f a) -> f (t a)) -> t (f a) -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t (f a) -> f (t a)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence

-- | A function that performs optimizations and modifications to a list of
-- input 'Output's.
--
-- An sample of an optimization is 'removeStartingNewLine' which just removes a
-- newline if it is the first item in an 'Output' list.
modificationsOutputList :: [Output] -> [Output]
modificationsOutputList :: [Output] -> [Output]
modificationsOutputList =
  [Output] -> [Output]
removeTrailingSpacesInOtherBeforeNewLine ([Output] -> [Output])
-> ([Output] -> [Output]) -> [Output] -> [Output]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Output] -> [Output]
shrinkWhitespaceInOthers ([Output] -> [Output])
-> ([Output] -> [Output]) -> [Output] -> [Output]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Output] -> [Output]
compressOthers ([Output] -> [Output])
-> ([Output] -> [Output]) -> [Output] -> [Output]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Output] -> [Output]
removeStartingNewLine

-- | Remove a 'OutputNewLine' if it is the first item in the 'Output' list.
--
-- >>> removeStartingNewLine [Output 3 OutputNewLine, Output 3 OutputComma]
-- [Output {outputNestLevel = NestLevel {unNestLevel = 3}, outputOutputType = OutputComma}]
removeStartingNewLine :: [Output] -> [Output]
removeStartingNewLine :: [Output] -> [Output]
removeStartingNewLine ((Output _ OutputNewLine) : t :: [Output]
t) = [Output]
t
removeStartingNewLine outputs :: [Output]
outputs = [Output]
outputs

-- | Remove trailing spaces from the end of a 'OutputOther' token if it is
-- followed by a 'OutputNewLine', or if it is the final 'Output' in the list.
-- This function assumes that there is a single 'OutputOther' before any
-- 'OutputNewLine' (and before the end of the list), so it must be run after
-- running 'compressOthers'.
--
-- >>> removeTrailingSpacesInOtherBeforeNewLine [Output 2 (OutputOther "foo  "), Output 4 OutputNewLine]
-- [Output {outputNestLevel = NestLevel {unNestLevel = 2}, outputOutputType = OutputOther "foo"},Output {outputNestLevel = NestLevel {unNestLevel = 4}, outputOutputType = OutputNewLine}]
removeTrailingSpacesInOtherBeforeNewLine :: [Output] -> [Output]
removeTrailingSpacesInOtherBeforeNewLine :: [Output] -> [Output]
removeTrailingSpacesInOtherBeforeNewLine [] = []
removeTrailingSpacesInOtherBeforeNewLine (Output nest :: NestLevel
nest (OutputOther string :: String
string):[]) =
  (NestLevel -> OutputType -> Output
Output NestLevel
nest (String -> OutputType
OutputOther (String -> OutputType) -> String -> OutputType
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace String
string))Output -> [Output] -> [Output]
forall a. a -> [a] -> [a]
:[]
removeTrailingSpacesInOtherBeforeNewLine (Output nest :: NestLevel
nest (OutputOther string :: String
string):nl :: Output
nl@(Output _ OutputNewLine):t :: [Output]
t) =
  (NestLevel -> OutputType -> Output
Output NestLevel
nest (String -> OutputType
OutputOther (String -> OutputType) -> String -> OutputType
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace String
string))Output -> [Output] -> [Output]
forall a. a -> [a] -> [a]
:Output
nlOutput -> [Output] -> [Output]
forall a. a -> [a] -> [a]
:[Output] -> [Output]
removeTrailingSpacesInOtherBeforeNewLine [Output]
t
removeTrailingSpacesInOtherBeforeNewLine (h :: Output
h:t :: [Output]
t) = Output
h Output -> [Output] -> [Output]
forall a. a -> [a] -> [a]
: [Output] -> [Output]
removeTrailingSpacesInOtherBeforeNewLine [Output]
t

-- | If there are two subsequent 'OutputOther' tokens, combine them into just
-- one 'OutputOther'.
--
-- >>> compressOthers [Output 0 (OutputOther "foo"), Output 0 (OutputOther "bar")]
-- [Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputOther "foobar"}]
compressOthers :: [Output] -> [Output]
compressOthers :: [Output] -> [Output]
compressOthers [] = []
compressOthers (Output _ (OutputOther string1 :: String
string1):(Output nest :: NestLevel
nest (OutputOther string2 :: String
string2)):t :: [Output]
t) =
  [Output] -> [Output]
compressOthers ((NestLevel -> OutputType -> Output
Output NestLevel
nest (String -> OutputType
OutputOther (String
string1 String -> ShowS
forall a. Monoid a => a -> a -> a
`mappend` String
string2))) Output -> [Output] -> [Output]
forall a. a -> [a] -> [a]
: [Output]
t)
compressOthers (h :: Output
h:t :: [Output]
t) = Output
h Output -> [Output] -> [Output]
forall a. a -> [a] -> [a]
: [Output] -> [Output]
compressOthers [Output]
t

-- | In each 'OutputOther' token, compress multiple whitespaces to just one
-- whitespace.
--
-- >>> shrinkWhitespaceInOthers [Output 0 (OutputOther "  hello  ")]
-- [Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputOther " hello "}]
shrinkWhitespaceInOthers :: [Output] -> [Output]
shrinkWhitespaceInOthers :: [Output] -> [Output]
shrinkWhitespaceInOthers = (Output -> Output) -> [Output] -> [Output]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Output -> Output
shrinkWhitespaceInOther

shrinkWhitespaceInOther :: Output -> Output
shrinkWhitespaceInOther :: Output -> Output
shrinkWhitespaceInOther (Output nest :: NestLevel
nest (OutputOther string :: String
string)) =
  NestLevel -> OutputType -> Output
Output NestLevel
nest (OutputType -> Output)
-> (String -> OutputType) -> String -> Output
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OutputType
OutputOther (String -> Output) -> String -> Output
forall a b. (a -> b) -> a -> b
$ ShowS
shrinkWhitespace String
string
shrinkWhitespaceInOther other :: Output
other = Output
other

shrinkWhitespace :: String -> String
shrinkWhitespace :: ShowS
shrinkWhitespace (' ':' ':t :: String
t) = ShowS
shrinkWhitespace (' 'Char -> ShowS
forall a. a -> [a] -> [a]
:String
t)
shrinkWhitespace (h :: Char
h:t :: String
t) = Char
h Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
shrinkWhitespace String
t
shrinkWhitespace "" = ""