{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} module Stack.PrettyPrint ( -- * Pretty printing functions displayPlain, displayWithColor -- * Logging based on pretty-print typeclass , prettyDebug, prettyInfo, prettyWarn, prettyError, prettyWarnNoIndent, prettyErrorNoIndent , prettyDebugL, prettyInfoL, prettyWarnL, prettyErrorL, prettyWarnNoIndentL, prettyErrorNoIndentL , prettyDebugS, prettyInfoS, prettyWarnS, prettyErrorS, prettyWarnNoIndentS, prettyErrorNoIndentS -- * Semantic styling functions -- | These are preferred to styling or colors directly, so that we can -- encourage consistency. , styleWarning, styleError, styleGood , styleShell, styleFile, styleUrl, styleDir, styleModule , styleCurrent, styleTarget , displayMilliseconds -- * Formatting utils , bulletedList , spacedBulletedList , debugBracket -- * Re-exports from "Text.PrettyPrint.Leijen.Extended" , Display(..), AnsiDoc, AnsiAnn(..), HasAnsiAnn(..), Doc , 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 , indentAfterLabel, wordDocs, flow ) where import Stack.Prelude import Data.List (intersperse) import qualified Data.Text as T import Stack.Types.Config import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Runner import Stack.Types.Version import qualified System.Clock as Clock import Text.PrettyPrint.Leijen.Extended displayWithColor :: (HasRunner env, Display a, HasAnsiAnn (Ann a), MonadReader env m, MonadLogger m) => a -> m T.Text displayWithColor x = do useAnsi <- liftM logUseColor $ view logOptionsL termWidth <- liftM logTermWidth $ view logOptionsL return $ (if useAnsi then displayAnsi else displayPlain) termWidth x -- TODO: switch to using implicit callstacks once 7.8 support is dropped prettyWith :: (HasRunner env, HasCallStack, Display b, HasAnsiAnn (Ann b), MonadReader env m, MonadLogger m) => LogLevel -> (a -> b) -> a -> m () prettyWith level f = logOther level <=< displayWithColor . f -- Note: I think keeping this section aligned helps spot errors, might be -- worth keeping the alignment in place. prettyDebugWith, prettyInfoWith, prettyWarnWith, prettyErrorWith, prettyWarnNoIndentWith, prettyErrorNoIndentWith :: (HasCallStack, HasRunner env, MonadReader env m, MonadLogger m) => (a -> Doc AnsiAnn) -> a -> m () prettyDebugWith = prettyWith LevelDebug prettyInfoWith = prettyWith LevelInfo prettyWarnWith f = prettyWith LevelWarn ((line <>) . (styleWarning "Warning:" <+>) . indentAfterLabel . f) prettyErrorWith f = prettyWith LevelError ((line <>) . (styleError "Error:" <+>) . indentAfterLabel . f) prettyWarnNoIndentWith f = prettyWith LevelWarn ((line <>) . (styleWarning "Warning:" <+>) . f) prettyErrorNoIndentWith f = prettyWith LevelWarn ((line <>) . (styleError "Error:" <+>) . f) prettyDebug, prettyInfo, prettyWarn, prettyError, prettyWarnNoIndent, prettyErrorNoIndent :: (HasCallStack, HasRunner env, MonadReader env m, MonadLogger m) => Doc AnsiAnn -> m () prettyDebug = prettyDebugWith id prettyInfo = prettyInfoWith id prettyWarn = prettyWarnWith id prettyError = prettyErrorWith id prettyWarnNoIndent = prettyWarnNoIndentWith id prettyErrorNoIndent = prettyErrorNoIndentWith id prettyDebugL, prettyInfoL, prettyWarnL, prettyErrorL, prettyWarnNoIndentL, prettyErrorNoIndentL :: (HasCallStack, HasRunner env, MonadReader env m, MonadLogger m) => [Doc AnsiAnn] -> m () prettyDebugL = prettyDebugWith fillSep prettyInfoL = prettyInfoWith fillSep prettyWarnL = prettyWarnWith fillSep prettyErrorL = prettyErrorWith fillSep prettyWarnNoIndentL = prettyWarnNoIndentWith fillSep prettyErrorNoIndentL = prettyErrorNoIndentWith fillSep prettyDebugS, prettyInfoS, prettyWarnS, prettyErrorS, prettyWarnNoIndentS, prettyErrorNoIndentS :: (HasCallStack, HasRunner env, MonadReader env m, MonadLogger m) => String -> m () prettyDebugS = prettyDebugWith flow prettyInfoS = prettyInfoWith 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 :: Doc a -> Doc a indentAfterLabel = align -- | Make a 'Doc' from each word in a 'String' wordDocs :: String -> [Doc a] wordDocs = map fromString . words -- | Wordwrap a 'String' flow :: String -> Doc a flow = fillSep . wordDocs debugBracket :: (HasCallStack, HasRunner env, MonadReader env m, MonadLogger m, MonadIO m, MonadUnliftIO m) => Doc AnsiAnn -> m a -> m a debugBracket msg f = do let output = logDebug <=< displayWithColor output $ "Start: " <> msg start <- liftIO $ Clock.getTime Clock.Monotonic x <- f `catch` \ex -> do end <- liftIO $ Clock.getTime Clock.Monotonic let diff = Clock.diffTimeSpec start end output $ "Finished with exception in" <+> displayMilliseconds diff <> ":" <+> msg <> line <> "Exception thrown: " <> fromString (show ex) throwIO (ex :: SomeException) end <- liftIO $ Clock.getTime Clock.Monotonic let diff = Clock.diffTimeSpec start end output $ "Finished in" <+> displayMilliseconds diff <> ":" <+> msg return x -- | Style an 'AnsiDoc' as an error. Should be used sparingly, not to style -- entire long messages. For example, it's used to style the "Error:" -- label for an error message, not the entire message. styleError :: AnsiDoc -> AnsiDoc styleError = dullred -- | Style an 'AnsiDoc' as a warning. Should be used sparingly, not to style -- entire long messages. For example, it's used to style the "Warning:" -- label for an error message, not the entire message. styleWarning :: AnsiDoc -> AnsiDoc styleWarning = yellow -- | Style an 'AnsiDoc' in a way to emphasize that it is a particularly good -- thing. styleGood :: AnsiDoc -> AnsiDoc styleGood = green -- | Style an 'AnsiDoc' as a shell command, i.e. when suggesting something -- to the user that should be typed in directly as written. styleShell :: AnsiDoc -> AnsiDoc styleShell = magenta -- | Style an 'AnsiDoc' as a filename. See 'styleDir' for directories. styleFile :: AnsiDoc -> AnsiDoc styleFile = bold . white -- | Style an 'AsciDoc' as a URL. For now using the same style as files. styleUrl :: AnsiDoc -> AnsiDoc styleUrl = styleFile -- | Style an 'AnsiDoc' as a directory name. See 'styleFile' for files. styleDir :: AnsiDoc -> AnsiDoc styleDir = bold . blue -- | Style an 'AnsiDoc' in a way that emphasizes that it is related to -- a current thing. For example, could be used when talking about the -- current package we're processing when outputting the name of it. styleCurrent :: AnsiDoc -> AnsiDoc styleCurrent = yellow -- TODO: figure out how to describe this styleTarget :: AnsiDoc -> AnsiDoc styleTarget = cyan -- | Style an 'AnsiDoc' as a module name styleModule :: AnsiDoc -> AnsiDoc styleModule = magenta -- TODO: what color should this be? instance Display PackageName where display = fromString . packageNameString instance Display PackageIdentifier where display = fromString . packageIdentifierString instance Display Version where display = fromString . versionString instance Display (Path b File) where display = styleFile . fromString . toFilePath instance Display (Path b Dir) where display = styleDir . fromString . toFilePath instance Display (PackageName, NamedComponent) where display = cyan . fromString . T.unpack . renderPkgComponent -- Display milliseconds. displayMilliseconds :: Clock.TimeSpec -> AnsiDoc displayMilliseconds t = green $ (fromString . show . (`div` 10^(6 :: Int)) . Clock.toNanoSecs) t <> "ms" -- | Display a bulleted list of 'AnsiDoc'. bulletedList :: [AnsiDoc] -> AnsiDoc bulletedList = mconcat . intersperse line . map (("*" <+>) . align) -- | Display a bulleted list of 'AnsiDoc' with a blank line between -- each. spacedBulletedList :: [AnsiDoc] -> AnsiDoc spacedBulletedList = mconcat . intersperse (line <> line) . map (("*" <+>) . align)