{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} module RIO.PrettyPrint ( -- * Type classes for optionally colored terminal output HasTerm (..) , HasStylesUpdate (..) -- * Pretty printing functions , displayPlain , displayWithColor -- * Logging based on pretty-print typeclass -- | The @pretty...@ functions come in three varieties: -- -- * The normal variety, with a single styled document; -- * The @L@ variety. The listed styled documents are concatenated with -- 'fillSep'; and -- * The @S@ variety. 'flow' is applied to the 'String'. -- -- Pretty message at log level 'LevelDebug'. , prettyDebug , prettyDebugL , prettyDebugS -- | Pretty message at log level 'LevelInfo'. , prettyInfo , prettyInfoL , prettyInfoS -- | Pretty messages at log level 'LevelInfo', starting on a new line with -- label @Note:@, with the message indented after the label. , prettyNote , prettyNoteL , prettyNoteS -- | Pretty messages at log level 'LevelWarn', starting on a new line with -- label @Warning:@, with or without the message indented after the label. , prettyWarn , prettyWarnL , prettyWarnS , prettyWarnNoIndent , prettyWarnNoIndentL , prettyWarnNoIndentS -- | Pretty messages at log level 'LevelError', starting on a new line with -- label @Error:@, with or without the message indented after the label. , prettyError , prettyErrorL , prettyErrorS , prettyErrorNoIndent , prettyErrorNoIndentL , prettyErrorNoIndentS -- | Pretty messages at the specified log level. , prettyGeneric , prettyWith -- * Semantic styling functions -- | These are used rather than applying colors or other styling directly, -- to provide consistency. , style , displayMilliseconds , logLevelToStyle -- * Formatting utils , blankLine , bulletedList , spacedBulletedList , mkBulletedList , mkNarrativeList , debugBracket -- * Re-exports from "Text.PrettyPrint.Leijen.Extended" , Pretty (..) , StyleDoc (..) , StyleAnn (..) , nest , line , linebreak , group , softline , softbreak , align , hang , indent , encloseSep , (<+>) , hsep , vsep , fillSep , sep , hcat , vcat , fillCat , cat , punctuate , fill , fillBreak , enclose , squotes , dquotes , parens , angles , braces , brackets , string , indentAfterLabel , wordDocs , flow -- * Re-exports from "RIO.PrettyPrint.Types.PrettyPrint" , Style (..) ) where import Data.List ( intersperse ) import RIO import RIO.PrettyPrint.StylesUpdate ( HasStylesUpdate (..) ) import RIO.PrettyPrint.Types ( Style (..) ) import Text.PrettyPrint.Leijen.Extended ( Pretty (pretty), StyleAnn (..), StyleDoc, (<+>), align , angles, braces, brackets, cat, displayAnsi, displayPlain , dquotes, enclose, encloseSep, fill, fillBreak, fillCat , fillSep, group, hang, hcat, hsep, indent, line, linebreak , nest, parens, punctuate, sep, softbreak, softline, squotes , string, styleAnn, vcat, vsep ) class (HasLogFunc env, HasStylesUpdate env) => HasTerm env where useColorL :: Lens' env Bool termWidthL :: Lens' env Int displayWithColor :: (HasTerm env, Pretty a, MonadReader env m, HasCallStack) => a -> m Utf8Builder displayWithColor x = do useAnsi <- view useColorL termWidth <- view termWidthL (if useAnsi then displayAnsi else displayPlain) termWidth x -- TODO: switch to using implicit callstacks once 7.8 support is dropped prettyGeneric :: (HasTerm env, HasCallStack, Pretty b, MonadReader env m, MonadIO m) => LogLevel -> b -> m () prettyGeneric level = prettyWith level id prettyWith :: (HasTerm env, HasCallStack, Pretty b, MonadReader env m, MonadIO m) => LogLevel -> (a -> b) -> a -> m () prettyWith level f = logGeneric "" level . RIO.display <=< displayWithColor . f -- Note: I think keeping this section aligned helps spot errors, might be -- worth keeping the alignment in place. prettyDebugWith, prettyInfoWith, prettyNoteWith, prettyWarnWith, prettyErrorWith, prettyWarnNoIndentWith, prettyErrorNoIndentWith :: (HasCallStack, HasTerm env, MonadReader env m, MonadIO m) => (a -> StyleDoc) -> a -> m () prettyDebugWith = prettyWith LevelDebug prettyInfoWith = prettyWith LevelInfo prettyNoteWith f = prettyWith LevelInfo ((line <>) . (style Good "Note:" <+>) . indentAfterLabel . f) prettyWarnWith f = prettyWith LevelWarn ((line <>) . (style Warning "Warning:" <+>) . indentAfterLabel . f) prettyErrorWith f = prettyWith LevelError ((line <>) . (style Error "Error:" <+>) . indentAfterLabel . f) prettyWarnNoIndentWith f = prettyWith LevelWarn ((line <>) . (style Warning "Warning:" <+>) . f) prettyErrorNoIndentWith f = prettyWith LevelError ((line <>) . (style Error "Error:" <+>) . f) prettyDebug, prettyInfo, prettyNote, prettyWarn, prettyError, prettyWarnNoIndent, prettyErrorNoIndent :: (HasCallStack, HasTerm env, MonadReader env m, MonadIO m) => StyleDoc -> m () prettyDebug = prettyDebugWith id prettyInfo = prettyInfoWith id prettyNote = prettyNoteWith id prettyWarn = prettyWarnWith id prettyError = prettyErrorWith id prettyWarnNoIndent = prettyWarnNoIndentWith id prettyErrorNoIndent = prettyErrorNoIndentWith id prettyDebugL, prettyInfoL, prettyNoteL, prettyWarnL, prettyErrorL, prettyWarnNoIndentL, prettyErrorNoIndentL :: (HasCallStack, HasTerm env, MonadReader env m, MonadIO m) => [StyleDoc] -> m () prettyDebugL = prettyDebugWith fillSep prettyInfoL = prettyInfoWith fillSep prettyNoteL = prettyNoteWith fillSep prettyWarnL = prettyWarnWith fillSep prettyErrorL = prettyErrorWith fillSep prettyWarnNoIndentL = prettyWarnNoIndentWith fillSep prettyErrorNoIndentL = prettyErrorNoIndentWith fillSep prettyDebugS, prettyInfoS, prettyNoteS, prettyWarnS, prettyErrorS, prettyWarnNoIndentS, prettyErrorNoIndentS :: (HasCallStack, HasTerm env, MonadReader env m, MonadIO m) => String -> m () prettyDebugS = prettyDebugWith flow prettyInfoS = prettyInfoWith flow prettyNoteS = prettyNoteWith flow prettyWarnS = prettyWarnWith flow prettyErrorS = prettyErrorWith flow prettyWarnNoIndentS = prettyWarnNoIndentWith flow prettyErrorNoIndentS = prettyErrorNoIndentWith flow -- End of aligned section -- | Use after a label and before the rest of what's being labelled for -- consistent spacing/indenting/etc. -- -- For example this is used after "Warning:" in warning messages. indentAfterLabel :: StyleDoc -> StyleDoc indentAfterLabel = align -- | Make a 'StyleDoc' from each word in a 'String' wordDocs :: String -> [StyleDoc] wordDocs = map fromString . words -- | Wordwrap a 'String' flow :: String -> StyleDoc flow = fillSep . wordDocs -- | A blank line. blankLine :: StyleDoc blankLine = line <> line -- | @debug message action@ brackets any output of the specified @action@ with -- an initial and final @message@ at log level 'LevelDebug'. The initial message -- is prefixed with the label @Start:@. The final message is prefixed with -- information about the duration of the action in milliseconds (ms) and, if -- an exception is thrown by the action, the exception. For example: -- -- > Start: -- > -- > Finished in ...ms: -- -- or: -- -- > Start: -- > -- > Finished with exception in ...ms: -- > Exception thrown: debugBracket :: (HasCallStack, HasTerm env, MonadReader env m, MonadIO m, MonadUnliftIO m) => StyleDoc -> m a -> m a debugBracket msg f = do let output = logDebug . RIO.display <=< displayWithColor output $ "Start: " <> msg start <- getMonotonicTime x <- f `catch` \ex -> do end <- getMonotonicTime let diff = end - start output $ "Finished with exception in" <+> displayMilliseconds diff <> ":" <+> msg <> line <> "Exception thrown: " <> fromString (show ex) throwIO (ex :: SomeException) end <- getMonotonicTime let diff = end - start output $ "Finished in" <+> displayMilliseconds diff <> ":" <+> msg return x -- | Annotate a 'StyleDoc' with a 'Style'. style :: Style -> StyleDoc -> StyleDoc style = styleAnn -- | Display as milliseconds in style 'Good'. displayMilliseconds :: Double -- ^ Amount of time in seconds. -> StyleDoc displayMilliseconds t = style Good $ fromString (show (round (t * 1000) :: Int)) <> "ms" -- | Display a bulleted list of 'StyleDoc' with @*@ as the bullet point. bulletedList :: [StyleDoc] -> StyleDoc bulletedList = mkBulletedList False '*' -- | Display a bulleted list of 'StyleDoc', spaced with blank lines or not, -- given a character for the bullet point. -- -- @since 0.1.6.0 mkBulletedList :: Bool -- ^ Spaced with a blank line between each item? -> Char -- ^ The character to act as the bullet point. -> [StyleDoc] -> StyleDoc mkBulletedList isSpaced bullet = mconcat . intersperse spacer . map ((fromString [bullet] <+>) . align) where spacer = if isSpaced then line <> line else line -- | A helper function to yield a narrative list from a list of items, with a -- final fullstop. For example, helps produce the output -- @\"apple, ball and cat.\"@ (no serial comma) or @\"apple, ball, and cat.\"@ -- (serial comma) from @[\"apple\", \"ball\", \"cat\"]@. -- -- @since 0.1.4.0 mkNarrativeList :: Pretty a => Maybe Style -- ^ Style the items in the list? -> Bool -- ^ Use a serial comma? -> [a] -> [StyleDoc] mkNarrativeList _ _ [] = [] mkNarrativeList mStyle _ [x] = [maybe id style mStyle (pretty x) <> "."] mkNarrativeList mStyle useSerialComma [x1, x2] = mStyle' (pretty x1) <> (if useSerialComma then "," else mempty) : "and" : mkNarrativeList mStyle useSerialComma [x2] where mStyle' = maybe id style mStyle mkNarrativeList mStyle useSerialComma (x:xs) = maybe id style mStyle (pretty x) <> "," : mkNarrativeList mStyle useSerialComma xs -- | Display a bulleted list of 'StyleDoc' with a blank line between -- each and @*@ as the bullet point. spacedBulletedList :: [StyleDoc] -> StyleDoc spacedBulletedList = mkBulletedList True '*' -- | The 'Style' intended to be associated with a 'LogLevel'. -- -- @since 0.1.1.0 logLevelToStyle :: LogLevel -> Style logLevelToStyle level = case level of LevelDebug -> Debug LevelInfo -> Info LevelWarn -> Warning LevelError -> Error LevelOther _ -> OtherLevel