module Text.Pretty.Simple.Internal.OutputPrinter
where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Lens (view)
import Control.Lens.TH (makeLenses)
import Control.Monad.Reader (MonadReader, runReader)
import Data.Data (Data)
import Data.Foldable (fold, foldlM)
import Data.Semigroup ((<>))
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
{ _indentAmount :: Int
, _useColor :: UseColor
} deriving (Data, Eq, Generic, Read, Show, Typeable)
makeLenses ''OutputOptions
defaultOutputOptions :: OutputOptions
defaultOutputOptions = OutputOptions {_indentAmount = 4, _useColor = UseColor}
render :: OutputOptions -> [Output] -> String
render options outputs = runReader (renderOutputs outputs) options
renderOutputs
:: forall m.
MonadReader OutputOptions m
=> [Output] -> m String
renderOutputs = foldlM foldFunc "" . modificationsOutputList
where
foldFunc :: String -> Output -> m String
foldFunc accum output = mappend accum <$> renderOutput output
renderRaibowParenFor
:: MonadReader OutputOptions m
=> NestLevel -> String -> m String
renderRaibowParenFor nest string =
sequenceFold [rainbowParen nest, pure string, colorReset]
renderOutput :: MonadReader OutputOptions m => Output -> m String
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 <- view indentAmount
pure $ 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 string
renderOutput (Output _ (OutputStringLit string)) = do
sequenceFold
[ colorQuote
, pure "\""
, colorString
, pure 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 <> 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 String
colorQuote = appendColors colorBold colorVividWhite
colorString :: MonadReader OutputOptions m => m String
colorString = appendColors colorBold colorVividBlue
colorError :: MonadReader OutputOptions m => m String
colorError = appendColors colorBold colorVividRed
colorNum :: MonadReader OutputOptions m => m String
colorNum = appendColors colorBold colorVividGreen
rainbowParen
:: forall m.
MonadReader OutputOptions m
=> NestLevel -> m String
rainbowParen (NestLevel nestLevel) =
let choicesLen = length rainbowParenChoices
in rainbowParenChoices !! (nestLevel `mod` choicesLen)
where
rainbowParenChoices :: [m String]
rainbowParenChoices =
[ appendColors colorBold colorVividMagenta
, appendColors colorBold colorVividCyan
, appendColors colorBold colorVividYellow
]
canUseColor :: MonadReader OutputOptions m => m Bool
canUseColor = do
color <- view useColor
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 String
colorBold = ifM canUseColor (setSGRCode [SetConsoleIntensity BoldIntensity]) ""
colorReset :: MonadReader OutputOptions m => m String
colorReset = ifM canUseColor (setSGRCode [Reset]) ""
colorVividBlue :: MonadReader OutputOptions m => m String
colorVividBlue = colorHelper Vivid Blue
colorVividCyan :: MonadReader OutputOptions m => m String
colorVividCyan = colorHelper Vivid Cyan
colorVividGreen :: MonadReader OutputOptions m => m String
colorVividGreen = colorHelper Vivid Green
colorVividMagenta :: MonadReader OutputOptions m => m String
colorVividMagenta = colorHelper Vivid Magenta
colorVividRed :: MonadReader OutputOptions m => m String
colorVividRed = colorHelper Vivid Red
colorVividWhite :: MonadReader OutputOptions m => m String
colorVividWhite = colorHelper Vivid White
colorVividYellow :: MonadReader OutputOptions m => m String
colorVividYellow = colorHelper Vivid Yellow
colorHelper :: MonadReader OutputOptions m => ColorIntensity -> Color -> m String
colorHelper colorIntensity color =
ifM canUseColor (setSGRCode [SetColor Foreground colorIntensity color]) ""
appendColors :: MonadReader OutputOptions m => m String -> m String -> m String
appendColors color1 color2 = mappend <$> color1 <*> color2