Merge pull request #3354 from kadoban/colorfully-messing-with-output

explore improvements to output (especially colors)

src/Stack/Build/ConstructPlan.hs

@@ -935,7 +935,7 @@ pprintExceptions exceptions stackYaml parentMap wanted =
 
     pprintException (DependencyCycleDetected pNames) = Just $
         "Dependency cycle detected in packages:" <> line <>
-        indent 4 (encloseSep "[" "]" "," (map (errorRed . fromString . packageNameString) pNames))
+        indent 4 (encloseSep "[" "]" "," (map (styleError . display) pNames))
     pprintException (DependencyPlanFailures pkg pDeps) =
         case mapMaybe pprintDep (Map.toList pDeps) of
             [] -> Nothing
@@ -949,17 +949,17 @@ pprintExceptions exceptions stackYaml parentMap wanted =
                     Just (target:path) -> line <> "needed due to " <> encloseSep "" "" " -> " pathElems
                       where
                         pathElems =
-                            [displayTargetPkgId target] ++
+                            [styleTarget . display $ target] ++
                             map display path ++
                             [pkgIdent]
               where
-                pkgIdent = displayCurrentPkgId (packageIdentifier pkg)
+                pkgIdent = styleCurrent . display $ packageIdentifier pkg
     -- Skip these when they are redundant with 'NotInBuildPlan' info.
     pprintException (UnknownPackage name)
         | name `Set.member` allNotInBuildPlan = Nothing
         | name `HashSet.member` wiredInPackages =
-            Just $ "Can't build a package with same name as a wired-in-package:" <+> displayCurrentPkgName name
-        | otherwise = Just $ "Unknown package:" <+> displayCurrentPkgName name
+            Just $ "Can't build a package with same name as a wired-in-package:" <+> (styleCurrent . display $ name)
+        | otherwise = Just $ "Unknown package:" <+> (styleCurrent . display $ name)
 
     pprintFlags flags
         | Map.null flags = ""
@@ -969,29 +969,29 @@ pprintExceptions exceptions stackYaml parentMap wanted =
 
     pprintDep (name, (range, mlatestApplicable, badDep)) = case badDep of
         NotInBuildPlan -> Just $
-            errorRed (display name) <+>
+            styleError (display name) <+>
             align ("must match" <+> goodRange <> "," <> softline <>
                    "but the stack configuration has no specified version" <>
                    latestApplicable Nothing)
         -- TODO: For local packages, suggest editing constraints
         DependencyMismatch version -> Just $
-            displayErrorPkgId (PackageIdentifier name version) <+>
+            (styleError . display) (PackageIdentifier name version) <+>
             align ("must match" <+> goodRange <>
                    latestApplicable (Just version))
         -- I think the main useful info is these explain why missing
         -- packages are needed. Instead lets give the user the shortest
         -- path from a target to the package.
         Couldn'tResolveItsDependencies _version -> Nothing
       where
-        goodRange = goodGreen (fromString (Cabal.display range))
+        goodRange = styleGood (fromString (Cabal.display range))
         latestApplicable mversion =
             case mlatestApplicable of
                 Nothing -> ""
                 Just la
                     | mlatestApplicable == mversion -> softline <>
                         "(latest applicable is specified)"
                     | otherwise -> softline <>
-                        "(latest applicable is " <> goodGreen (display la) <> ")"
+                        "(latest applicable is " <> styleGood (display la) <> ")"
 
 -- | Get the shortest reason for the package to be in the build plan. In
 -- other words, trace the parent dependencies back to a 'wanted'

src/Stack/Build/Execute.hs

@@ -970,13 +970,11 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
                 warnCustomNoDeps =
                     case (taskType, packageBuildType package) of
                         (TTFiles lp Local, Just C.Custom) | lpWanted lp -> do
-                            $logWarn $ T.pack $ concat
-                                [ "Package "
-                                , packageNameString $ packageName package
-                                , " uses a custom Cabal build, but does not use a custom-setup stanza"
+                            $prettyWarnL $
+                                [ flow "Package"
+                                , display $ packageName package
+                                , flow "uses a custom Cabal build, but does not use a custom-setup stanza"
                                 ]
-                            $logWarn "Using the explicit setup deps approach based on configuration"
-                            $logWarn "Strongly recommend fixing the package's cabal file"
                         _ -> return ()
 
                 getPackageArgs :: Path Abs Dir -> RIO env [String]
@@ -992,7 +990,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
                                 case mdeps of
                                     Just x -> return x
                                     Nothing -> do
-                                        $logWarn "In getPackageArgs: custom-setup in use, but no dependency map present"
+                                        $prettyWarnS "In getPackageArgs: custom-setup in use, but no dependency map present"
                                         return Map.empty
                             matchedDeps <- forM (Map.toList customSetupDeps) $ \(name, range) -> do
                                 let matches (PackageIdentifier name' version) =
@@ -1362,7 +1360,7 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in
                       "- In" <+>
                       maybe "the library component" (\c -> fromString c <+> "component") mcomp <>
                       ":" <> line <>
-                      indent 4 (mconcat $ intersperse line $ map (goodGreen . fromString . C.display) modules)
+                      indent 4 (mconcat $ intersperse line $ map (styleGood . fromString . C.display) modules)
                 forM_ mlocalWarnings $ \(cabalfp, warnings) -> do
                     unless (null warnings) $ $prettyWarn $
                         "The following modules should be added to exposed-modules or other-modules in" <+>

src/Stack/PrettyPrint.hs

@@ -11,15 +11,18 @@ module Stack.PrettyPrint
       displayPlain, displayWithColor
       -- * Logging based on pretty-print typeclass
     , prettyDebug, prettyInfo, prettyWarn, prettyError
-    , debugBracket
-      -- * Color utils
-      -- | These are preferred to colors directly, so that we can
-      -- encourage consistency of color meanings.
-    , errorRed, goodGreen, shellMagenta
-    , displayTargetPkgId, displayCurrentPkgId, displayCurrentPkgName, displayErrorPkgId
+    , prettyDebugL, prettyInfoL, prettyWarnL, prettyErrorL
+    , prettyDebugS, prettyInfoS, prettyWarnS, prettyErrorS
+      -- * Semantic styling functions
+      -- | These are preferred to styling or colors directly, so that we can
+      -- encourage consistency.
+    , styleWarning, styleError, styleGood
+    , styleShell, styleFile, styleDir
+    , styleCurrent, styleTarget
     , displayMilliseconds
       -- * Formatting utils
     , bulletedList
+    , debugBracket
       -- * Re-exports from "Text.PrettyPrint.Leijen.Extended"
     , Display(..), AnsiDoc, AnsiAnn(..), HasAnsiAnn(..), Doc
     , nest, line, linebreak, group, softline, softbreak
@@ -28,6 +31,7 @@ module Stack.PrettyPrint
     , 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
@@ -52,25 +56,56 @@ displayWithColor x = do
 
 -- TODO: switch to using implicit callstacks once 7.8 support is dropped
 
-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
+prettyWith :: LogLevel -> ExpQ -> Q Exp
+prettyWith level f = do
     loc <- location
-    [e| monadLoggerLog loc "" LevelError <=< displayWithColor . (line <>) . (errorRed "Error:" <+>) |]
+    [e| monadLoggerLog loc "" 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 :: ExpQ -> Q Exp
+prettyDebugWith   = prettyWith LevelDebug
+prettyInfoWith    = prettyWith LevelInfo
+prettyWarnWith  f = prettyWith LevelWarn
+                        [| (line <>) . (styleWarning "Warning:" <+>) .
+                           indentAfterLabel . $f |]
+prettyErrorWith f = prettyWith LevelError
+                        [| (line <>) . (styleError   "Error:" <+>) .
+                           indentAfterLabel . $f |]
+
+prettyDebug, prettyInfo, prettyWarn, prettyError :: Q Exp
+prettyDebug  = prettyDebugWith [| id |]
+prettyInfo   = prettyInfoWith  [| id |]
+prettyWarn   = prettyWarnWith  [| id |]
+prettyError  = prettyErrorWith [| id |]
+
+prettyDebugL, prettyInfoL, prettyWarnL, prettyErrorL :: Q Exp
+prettyDebugL = prettyDebugWith [| fillSep |]
+prettyInfoL  = prettyInfoWith  [| fillSep |]
+prettyWarnL  = prettyWarnWith  [| fillSep |]
+prettyErrorL = prettyErrorWith [| fillSep |]
+
+prettyDebugS, prettyInfoS, prettyWarnS, prettyErrorS :: Q Exp
+prettyDebugS = prettyDebugWith [| flow |]
+prettyInfoS  = prettyInfoWith  [| flow |]
+prettyWarnS  = prettyWarnWith  [| flow |]
+prettyErrorS = prettyErrorWith [| 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 :: Q Exp
 debugBracket = do
@@ -92,29 +127,45 @@ debugBracket = do
             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
-
-displayCurrentPkgName :: PackageName -> AnsiDoc
-displayCurrentPkgName = yellow . display
-
-displayErrorPkgId :: PackageIdentifier -> AnsiDoc
-displayErrorPkgId = errorRed . display
+-- | 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 '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
 
 instance Display PackageName where
     display = fromString . packageNameString
@@ -126,18 +177,19 @@ instance Display Version where
     display = fromString . versionString
 
 instance Display (Path b File) where
-    display = bold . white . fromString . toFilePath
+    display = styleFile . fromString . toFilePath
 
 instance Display (Path b Dir) where
-    display = bold . blue . fromString . toFilePath
+    display = styleDir . fromString . toFilePath
 
 instance Display (PackageName, NamedComponent) where
     display = cyan . fromString . T.unpack . renderPkgComponent
 
 -- Display milliseconds.
 displayMilliseconds :: Clock.TimeSpec -> AnsiDoc
-displayMilliseconds t = goodGreen $
+displayMilliseconds t = green $
     (fromString . show . (`div` 10^(6 :: Int)) . Clock.toNanoSecs) t <> "ms"
 
+-- | Display a list of 'AnsiDoc', one per line, with bullets before each
 bulletedList :: [AnsiDoc] -> AnsiDoc
 bulletedList = mconcat . intersperse line . map ("*" <+>)

src/Stack/Setup.hs

@@ -1027,9 +1027,9 @@ installGHCPosix version downloadInfo _ archiveFile archiveType tempDir destDir =
                     $prettyError $
                         hang 2
                           ("Error encountered while" <+> step <+> "GHC with" <> line <>
-                           shellMagenta (fromString (unwords (cmd : args))) <> line <>
+                           styleShell (fromString (unwords (cmd : args))) <> line <>
                            -- TODO: Figure out how to insert \ in the appropriate spots
-                           -- hang 2 (shellMagenta (fillSep (fromString cmd : map fromString args))) <> line <>
+                           -- hang 2 (shellColor (fillSep (fromString cmd : map fromString args))) <> line <>
                            "run in " <> display wd) <> line <> line <>
                         "The following directories may now contain files, but won't be used by stack:" <> line <>
                         "  -" <+> display tempDir <> line <>

src/main/Main.hs

@@ -85,6 +85,8 @@ import           Stack.Options.SolverParser
 import           Stack.Options.Utils
 import qualified Stack.PackageIndex
 import qualified Stack.Path
+import           Stack.PrettyPrint hiding (display)
+import qualified Stack.PrettyPrint as P
 import           Stack.Runners
 import           Stack.Script
 import           Stack.SDist (getSDistTarball, checkSDistTarball, checkSDistTarball', SDistOpts(..))
@@ -605,10 +607,13 @@ buildCmd opts go = do
                Build -> go -- Default case is just Build
 
 uninstallCmd :: [String] -> GlobalOpts -> IO ()
-uninstallCmd _ go = withConfigAndLock go $ do
-    $logError "stack does not manage installations in global locations"
-    $logError "The only global mutation stack performs is executable copying"
-    $logError "For the default executable destination, please run 'stack path --local-bin'"
+uninstallCmd _ go = withConfigAndLock go $
+    $prettyErrorL
+      [ flow "stack does not manage installations in global locations."
+      , flow "The only global mutation stack performs is executable copying."
+      , flow "For the default executable destination, please run"
+      , styleShell "stack path --local-bin"
+      ]
 
 -- | Unpack packages to the filesystem
 unpackCmd :: [String] -> GlobalOpts -> IO ()
@@ -633,7 +638,12 @@ upgradeCmd upgradeOpts' go = withGlobalConfigAndLock go $
 
 -- | Upload to Hackage
 uploadCmd :: SDistOpts -> GlobalOpts -> IO ()
-uploadCmd (SDistOpts [] _ _ _ _ _) _ = throwString "Error: To upload the current package, please run 'stack upload .'"
+uploadCmd (SDistOpts [] _ _ _ _ _) go =
+    withConfigAndLock go . $prettyErrorL $
+        [ flow "To upload the current package, please run"
+        , styleShell "stack upload ."
+        , flow "(with the period at the end)"
+        ]
 uploadCmd sdistOpts go = do
     let partitionM _ [] = return ([], [])
         partitionM f (x:xs) = do
@@ -642,12 +652,16 @@ uploadCmd sdistOpts go = do
             return $ if r then (x:as, bs) else (as, x:bs)
     (files, nonFiles) <- partitionM D.doesFileExist (sdoptsDirsToWorkWith sdistOpts)
     (dirs, invalid) <- partitionM D.doesDirectoryExist nonFiles
-    unless (null invalid) $ do
-        hPutStrLn stderr $
-            "Error: stack upload expects a list sdist tarballs or cabal directories.  Can't find " ++
-            show invalid
-        exitFailure
     withBuildConfigAndLock go $ \_ -> do
+        unless (null invalid) $ do
+            let invalidList = bulletedList $ map (styleFile . fromString) invalid
+            $prettyErrorL $
+                [ styleShell "stack upload"
+                , flow "expects a list of sdist tarballs or cabal directories."
+                , flow "Can't find:"
+                , line <> invalidList
+                ]
+            liftIO exitFailure
         config <- view configL
         getCreds <- liftIO (runOnce (Upload.loadCreds config))
         mapM_ (resolveFile' >=> checkSDistTarball sdistOpts) files
@@ -696,7 +710,7 @@ sdistCmd sdistOpts go =
             ensureDir (parent tarPath)
             liftIO $ L.writeFile (toFilePath tarPath) tarBytes
             checkSDistTarball sdistOpts tarPath
-            $logInfo $ "Wrote sdist tarball to " <> T.pack (toFilePath tarPath)
+            $prettyInfoL [flow "Wrote sdist tarball to", P.display tarPath]
             when (sdoptsSign sdistOpts) (void $ Sig.sign (sdoptsSignServerUrl sdistOpts) tarPath)
 
 -- | Execute a command.