module Text.Pretty.Simple.Internal.OutputPrinter
where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#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.Output
(NestLevel(..), Output(..), OutputType(..))
data UseColor
= NoColor
| UseColor
deriving (Data, Eq, Generic, Read, Show, Typeable)
data OutputOptions = OutputOptions
{ outputOptionsIndentAmount :: Int
, outputOptionsUseColor :: UseColor
} deriving (Data, Eq, Generic, Read, Show, Typeable)
defaultOutputOptions :: OutputOptions
defaultOutputOptions =
OutputOptions
{outputOptionsIndentAmount = 4, outputOptionsUseColor = UseColor}
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
renderRaibowParenFor
:: MonadReader OutputOptions m
=> NestLevel -> Builder -> m Builder
renderRaibowParenFor nest string =
sequenceFold [rainbowParen nest, pure string, colorReset]
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
[ colorQuote
, pure "\""
, colorString
, pure $ fromString string
, colorQuote
, pure "\""
, colorReset
]
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 "" = ""
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
]
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