{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Stack.PrettyPrint
(
displayPlain, displayWithColor
, prettyDebug, prettyInfo, prettyNote, prettyWarn, prettyError, prettyWarnNoIndent, prettyErrorNoIndent
, prettyDebugL, prettyInfoL, prettyNoteL, prettyWarnL, prettyErrorL, prettyWarnNoIndentL, prettyErrorNoIndentL
, prettyDebugS, prettyInfoS, prettyNoteS, prettyWarnS, prettyErrorS, prettyWarnNoIndentS, prettyErrorNoIndentS
, styleWarning, styleError, styleGood
, styleShell, styleFile, styleUrl, styleDir, styleModule
, styleCurrent, styleTarget
, styleRecommendation
, 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 qualified RIO
import Stack.Prelude hiding (Display (..))
import Data.List (intersperse)
import qualified Data.Text as T
import qualified Distribution.ModuleName as C (ModuleName)
import qualified Distribution.Text as C (display)
import Stack.Types.NamedComponent
import Stack.Types.PackageIdentifier
import Stack.Types.PackageName
import Stack.Types.Runner
import Stack.Types.Version
import Text.PrettyPrint.Leijen.Extended
displayWithColor
:: (HasRunner env, Display a, HasAnsiAnn (Ann a),
MonadReader env m, HasLogFunc env, HasCallStack)
=> a -> m T.Text
displayWithColor x = do
useAnsi <- view useColorL
termWidth <- view $ runnerL.to runnerTermWidth
return $ (if useAnsi then displayAnsi else displayPlain) termWidth x
prettyWith :: (HasRunner env, HasCallStack, Display b, HasAnsiAnn (Ann b),
MonadReader env m, MonadIO m)
=> LogLevel -> (a -> b) -> a -> m ()
prettyWith level f = logGeneric "" level . RIO.display <=< displayWithColor . f
prettyDebugWith, prettyInfoWith, prettyNoteWith, prettyWarnWith, prettyErrorWith, prettyWarnNoIndentWith, prettyErrorNoIndentWith
:: (HasCallStack, HasRunner env, MonadReader env m, MonadIO m)
=> (a -> Doc AnsiAnn) -> a -> m ()
prettyDebugWith = prettyWith LevelDebug
prettyInfoWith = prettyWith LevelInfo
prettyNoteWith f = prettyWith LevelInfo
((line <>) . (styleGood "Note:" <+>) .
indentAfterLabel . f)
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 LevelError
((line <>) . (styleError "Error:" <+>) . f)
prettyDebug, prettyInfo, prettyNote, prettyWarn, prettyError, prettyWarnNoIndent, prettyErrorNoIndent
:: (HasCallStack, HasRunner env, MonadReader env m, MonadIO m)
=> Doc AnsiAnn -> 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, HasRunner env, MonadReader env m, MonadIO m)
=> [Doc AnsiAnn] -> 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, HasRunner 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
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,
MonadIO m, MonadUnliftIO m) => Doc AnsiAnn -> 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
styleError :: AnsiDoc -> AnsiDoc
styleError = dullred
styleWarning :: AnsiDoc -> AnsiDoc
styleWarning = dullyellow
styleGood :: AnsiDoc -> AnsiDoc
styleGood = green
styleShell :: AnsiDoc -> AnsiDoc
styleShell = magenta
styleFile :: AnsiDoc -> AnsiDoc
styleFile = dullcyan
styleUrl :: AnsiDoc -> AnsiDoc
styleUrl = styleFile
styleDir :: AnsiDoc -> AnsiDoc
styleDir = bold . blue
styleRecommendation :: AnsiDoc -> AnsiDoc
styleRecommendation = bold . green
styleCurrent :: AnsiDoc -> AnsiDoc
styleCurrent = dullyellow
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
instance Display C.ModuleName where
display = fromString . C.display
displayMilliseconds :: Double -> AnsiDoc
displayMilliseconds t = green $
fromString (show (round (t * 1000) :: Int)) <> "ms"
bulletedList :: [AnsiDoc] -> AnsiDoc
bulletedList = mconcat . intersperse line . map (("*" <+>) . align)
spacedBulletedList :: [AnsiDoc] -> AnsiDoc
spacedBulletedList = mconcat . intersperse (line <> line) . map (("*" <+>) . align)