module Stack.PrettyPrint
(
displayPlain, displayWithColor
, prettyDebug, prettyInfo, prettyWarn, prettyError
, debugBracket
, errorRed, goodGreen, shellMagenta
, displayTargetPkgId, displayCurrentPkgId, displayErrorPkgId
, displayMilliseconds
, bulletedList
, 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
) where
import Control.Exception.Lifted
import Control.Monad.Logger
import Control.Monad.Reader
import Data.List (intersperse)
import Data.Monoid
import Data.String (fromString)
import qualified Data.Text as T
import Language.Haskell.TH
import Path
import Stack.Types.Internal
import Stack.Types.Package
import Stack.Types.PackageIdentifier
import Stack.Types.PackageName
import Stack.Types.Version
import qualified System.Clock as Clock
import Text.PrettyPrint.Leijen.Extended
displayWithColor
:: (HasLogOptions env, MonadReader env m, Display a, HasAnsiAnn (Ann a))
=> a -> m T.Text
displayWithColor x = do
useAnsi <- liftM logUseColor $ view logOptionsL
return $ if useAnsi then displayAnsi x else displayPlain x
prettyDebug :: Q Exp
prettyDebug = do
loc <- location
[e| monadLoggerLog loc "" LevelDebug <=< displayWithColor |]
prettyInfo :: Q Exp
prettyInfo = do
loc <- location
[e| monadLoggerLog loc "" LevelInfo <=< displayWithColor |]
prettyWarn :: Q Exp
prettyWarn = do
loc <- location
[e| monadLoggerLog loc "" LevelWarn <=< displayWithColor . (line <>) . (warningYellow "Warning:" <+>) |]
prettyError :: Q Exp
prettyError = do
loc <- location
[e| monadLoggerLog loc "" LevelError <=< displayWithColor . (line <>) . (errorRed "Error:" <+>) |]
debugBracket :: Q Exp
debugBracket = do
loc <- location
[e| \msg f -> do
let output = monadLoggerLog loc "" LevelDebug <=< 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)
throw (ex :: SomeException)
end <- liftIO $ Clock.getTime Clock.Monotonic
let diff = Clock.diffTimeSpec start end
output $ "Finished in" <+> displayMilliseconds diff <> ":" <+> msg
return x
|]
errorRed :: AnsiDoc -> AnsiDoc
errorRed = dullred
warningYellow :: AnsiDoc -> AnsiDoc
warningYellow = yellow
goodGreen :: AnsiDoc -> AnsiDoc
goodGreen = green
shellMagenta :: AnsiDoc -> AnsiDoc
shellMagenta = magenta
displayTargetPkgId :: PackageIdentifier -> AnsiDoc
displayTargetPkgId = cyan . display
displayCurrentPkgId :: PackageIdentifier -> AnsiDoc
displayCurrentPkgId = yellow . display
displayErrorPkgId :: PackageIdentifier -> AnsiDoc
displayErrorPkgId = errorRed . display
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 = bold . white . fromString . toFilePath
instance Display (Path b Dir) where
display = bold . blue . fromString . toFilePath
instance Display (PackageName, NamedComponent) where
display = cyan . fromString . T.unpack . renderPkgComponent
displayMilliseconds :: Clock.TimeSpec -> AnsiDoc
displayMilliseconds t = goodGreen $
(fromString . show . (`div` 10^(6 :: Int)) . Clock.toNanoSecs) t <> "ms"
bulletedList :: [AnsiDoc] -> AnsiDoc
bulletedList = mconcat . intersperse line . map ("*" <+>)