module Text.Pretty.Simple.Internal.OutputPrinter
where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Monad.Reader (MonadReader(reader), runReader)
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 Text.Pretty.Simple.Internal.Color
(ColorOptions(..), colorReset, defaultColorOptionsDarkBg,
defaultColorOptionsLightBg)
import Text.Pretty.Simple.Internal.Output
(NestLevel(..), Output(..), OutputType(..))
data OutputOptions = OutputOptions
{ outputOptionsIndentAmount :: Int
, outputOptionsColorOptions :: Maybe ColorOptions
} deriving (Eq, Generic, Show, Typeable)
defaultOutputOptionsDarkBg :: OutputOptions
defaultOutputOptionsDarkBg =
OutputOptions
{ outputOptionsIndentAmount = 4
, outputOptionsColorOptions = Just defaultColorOptionsDarkBg
}
defaultOutputOptionsLightBg :: OutputOptions
defaultOutputOptionsLightBg =
OutputOptions
{ outputOptionsIndentAmount = 4
, outputOptionsColorOptions = Just defaultColorOptionsLightBg
}
defaultOutputOptionsNoColor :: OutputOptions
defaultOutputOptionsNoColor =
OutputOptions
{outputOptionsIndentAmount = 4, outputOptionsColorOptions = Nothing}
render :: OutputOptions -> [Output] -> Text
render options outputs = toLazyText $ runReader (renderOutputs outputs) options
renderOutputs
:: forall m.
MonadReader OutputOptions m
=> [Output] -> m Builder
renderOutputs = foldlM foldFunc "" . modificationsOutputList
where
foldFunc :: Builder -> Output -> m Builder
foldFunc accum output = mappend accum <$> renderOutput output
renderOutput :: MonadReader OutputOptions m => Output -> m Builder
renderOutput (Output nest OutputCloseBrace) = renderRaibowParenFor nest "}"
renderOutput (Output nest OutputCloseBracket) = renderRaibowParenFor nest "]"
renderOutput (Output nest OutputCloseParen) = renderRaibowParenFor nest ")"
renderOutput (Output nest OutputComma) = renderRaibowParenFor nest ","
renderOutput (Output _ OutputIndent) = do
indentSpaces <- reader outputOptionsIndentAmount
pure . mconcat $ replicate indentSpaces " "
renderOutput (Output _ OutputNewLine) = pure "\n"
renderOutput (Output nest OutputOpenBrace) = renderRaibowParenFor nest "{"
renderOutput (Output nest OutputOpenBracket) = renderRaibowParenFor nest "["
renderOutput (Output nest OutputOpenParen) = renderRaibowParenFor nest "("
renderOutput (Output _ (OutputOther string)) =
pure $ fromString string
renderOutput (Output _ (OutputStringLit string)) = do
sequenceFold
[ useColorQuote
, pure "\""
, useColorReset
, useColorString
, pure $ fromString string
, useColorReset
, useColorQuote
, pure "\""
, useColorReset
]
useColorQuote :: forall m. MonadReader OutputOptions m => m Builder
useColorQuote = maybe "" colorQuote <$> reader outputOptionsColorOptions
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
useColorReset :: forall m. MonadReader OutputOptions m => m Builder
useColorReset = maybe "" (const colorReset) <$> reader outputOptionsColorOptions
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 -> ""
sequenceFold :: (Monad f, Monoid a, Traversable t) => t (f a) -> f a
sequenceFold = fmap fold . sequence
modificationsOutputList :: [Output] -> [Output]
modificationsOutputList = shrinkWhitespaceInOthers . compressOthers . removeStartingNewLine
removeStartingNewLine :: [Output] -> [Output]
removeStartingNewLine ((Output _ OutputNewLine) : t) = t
removeStartingNewLine outputs = outputs
compressOthers :: [Output] -> [Output]
compressOthers [] = []
compressOthers (Output _ (OutputOther string1):(Output nest (OutputOther string2)):t) =
compressOthers ((Output nest (OutputOther (string1 `mappend` string2))) : t)
compressOthers (h:t) = h : compressOthers t
shrinkWhitespaceInOthers :: [Output] -> [Output]
shrinkWhitespaceInOthers = fmap shrinkWhitespaceInOther
shrinkWhitespaceInOther :: Output -> Output
shrinkWhitespaceInOther (Output nest (OutputOther string)) =
Output nest . OutputOther $ shrinkWhitespace string
shrinkWhitespaceInOther other = other
shrinkWhitespace :: String -> String
shrinkWhitespace (' ':' ':t) = shrinkWhitespace (' ':t)
shrinkWhitespace (h:t) = h : shrinkWhitespace t
shrinkWhitespace "" = ""