{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Text.Pretty.Simple.Internal.OutputPrinter
where
#if __GLASGOW_HASKELL__ < 710
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(..))
data CheckColorTty
= CheckColorTty
| NoCheckColorTty
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 OutputOptions = OutputOptions
{ OutputOptions -> Int
outputOptionsIndentAmount :: Int
, OutputOptions -> Maybe ColorOptions
outputOptionsColorOptions :: Maybe ColorOptions
, OutputOptions -> Bool
outputOptionsEscapeNonPrintable :: Bool
} 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)
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
}
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
}
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
}
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
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
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) ' '
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
, 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
]
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
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 :: 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
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
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
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
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 -> ""
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
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
removeStartingNewLine :: [Output] -> [Output]
removeStartingNewLine :: [Output] -> [Output]
removeStartingNewLine ((Output _ OutputNewLine) : t :: [Output]
t) = [Output]
t
removeStartingNewLine outputs :: [Output]
outputs = [Output]
outputs
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
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
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 "" = ""