{-# 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, 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 (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 (Eq, Generic, Show, Typeable)
data OutputOptions = OutputOptions
{ outputOptionsIndentAmount :: Int
, outputOptionsColorOptions :: Maybe ColorOptions
, outputOptionsEscapeNonPrintable :: Bool
} deriving (Eq, Generic, Show, Typeable)
defaultOutputOptionsDarkBg :: OutputOptions
defaultOutputOptionsDarkBg =
OutputOptions
{ outputOptionsIndentAmount = 4
, outputOptionsColorOptions = Just defaultColorOptionsDarkBg
, outputOptionsEscapeNonPrintable = True
}
defaultOutputOptionsLightBg :: OutputOptions
defaultOutputOptionsLightBg =
OutputOptions
{ outputOptionsIndentAmount = 4
, outputOptionsColorOptions = Just defaultColorOptionsLightBg
, outputOptionsEscapeNonPrintable = True
}
defaultOutputOptionsNoColor :: OutputOptions
defaultOutputOptionsNoColor =
OutputOptions
{ outputOptionsIndentAmount = 4
, outputOptionsColorOptions = Nothing
, outputOptionsEscapeNonPrintable = True
}
hCheckTTY :: MonadIO m => Handle -> OutputOptions -> m OutputOptions
hCheckTTY h options = liftIO $ conv <$> tty
where
conv :: Bool -> OutputOptions
conv True = options
conv False = options { outputOptionsColorOptions = Nothing }
tty :: IO Bool
tty = hIsTerminalDevice h
render :: OutputOptions -> [Output] -> Text
render options = toLazyText . foldr foldFunc "" . modificationsOutputList
where
foldFunc :: Output -> Builder -> Builder
foldFunc output accum = runReader (renderOutput output) options `mappend` accum
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)) = do
indentSpaces <- reader outputOptionsIndentAmount
let spaces = replicate (indentSpaces + 2) ' '
pure $ fromString $ indentSubsequentLinesWith spaces string
renderOutput (Output _ (OutputNumberLit number)) = do
sequenceFold
[ useColorNum
, pure (fromString number)
, useColorReset
]
renderOutput (Output _ (OutputStringLit string)) = do
options <- ask
sequenceFold
[ useColorQuote
, pure "\""
, useColorReset
, useColorString
, pure (fromString (process options string))
, useColorReset
, useColorQuote
, pure "\""
, useColorReset
]
where
process :: OutputOptions -> String -> String
process opts =
if outputOptionsEscapeNonPrintable opts
then indentSubsequentLinesWith spaces . escapeNonPrintable . readStr
else indentSubsequentLinesWith spaces . readStr
where
spaces :: String
spaces = replicate (indentSpaces + 2) ' '
indentSpaces :: Int
indentSpaces = outputOptionsIndentAmount opts
readStr :: String -> String
readStr s = fromMaybe s . readMaybe $ '"':s ++ "\""
escapeNonPrintable :: String -> String
escapeNonPrintable input = foldr escape "" input
escape :: Char -> ShowS
escape c
| isPrint c || c == '\n' = (c:)
| otherwise = ('\\':) . ('x':) . showHex (ord c)
indentSubsequentLinesWith :: String -> String -> String
indentSubsequentLinesWith indent input =
intercalate "\n" $ (start ++) $ map (indent ++) $ end
where (start, end) = splitAt 1 $ lines input
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 "" = ""