module Stack.PrettyPrint
(
displayPlain, displayWithColor
, prettyDebug, prettyInfo, prettyWarn, prettyError, prettyWarnNoIndent, prettyErrorNoIndent
, prettyDebugL, prettyInfoL, prettyWarnL, prettyErrorL, prettyWarnNoIndentL, prettyErrorNoIndentL
, prettyDebugS, prettyInfoS, prettyWarnS, prettyErrorS, prettyWarnNoIndentS, prettyErrorNoIndentS
, styleWarning, styleError, styleGood
, styleShell, styleFile, styleUrl, styleDir, styleModule
, styleCurrent, styleTarget
, displayMilliseconds
, bulletedList
, spacedBulletedList
, debugBracket
, 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
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
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
indentAfterLabel :: Doc a -> Doc a
indentAfterLabel = align
wordDocs :: String -> [Doc a]
wordDocs = map fromString . words
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
styleError :: AnsiDoc -> AnsiDoc
styleError = dullred
styleWarning :: AnsiDoc -> AnsiDoc
styleWarning = yellow
styleGood :: AnsiDoc -> AnsiDoc
styleGood = green
styleShell :: AnsiDoc -> AnsiDoc
styleShell = magenta
styleFile :: AnsiDoc -> AnsiDoc
styleFile = bold . white
styleUrl :: AnsiDoc -> AnsiDoc
styleUrl = styleFile
styleDir :: AnsiDoc -> AnsiDoc
styleDir = bold . blue
styleCurrent :: AnsiDoc -> AnsiDoc
styleCurrent = yellow
styleTarget :: AnsiDoc -> AnsiDoc
styleTarget = cyan
styleModule :: AnsiDoc -> AnsiDoc
styleModule = magenta
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
displayMilliseconds :: Clock.TimeSpec -> AnsiDoc
displayMilliseconds t = green $
(fromString . show . (`div` 10^(6 :: Int)) . Clock.toNanoSecs) t <> "ms"
bulletedList :: [AnsiDoc] -> AnsiDoc
bulletedList = mconcat . intersperse line . map (("*" <+>) . align)
spacedBulletedList :: [AnsiDoc] -> AnsiDoc
spacedBulletedList = mconcat . intersperse (line <> line) . map (("*" <+>) . align)