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.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
{ _indentAmount :: Int
, _useColor :: UseColor
} deriving (Data, Eq, Generic, Read, Show, Typeable)
makeLenses ''OutputOptions
defaultOutputOptions :: OutputOptions
defaultOutputOptions = OutputOptions {_indentAmount = 4, _useColor = 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 <- view indentAmount
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 <> 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 <- 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 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