{-# 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)