Dump build logs if they contain warnings (fixes #2545)

Also munge the build output when dumping logs e.g. so that file paths
are made absolute and TH loading messages are squelched.

ChangeLog.md

@@ -28,6 +28,8 @@ Other enhancements:
 * Make `stack list-dependencies` understand all of the `stack dot` options too.
 * Add the ability for `stack list-dependencies` to list dependency licenses by
   passing the `--license` flag.
+* Dump logs that contain warnings for any local non-dependency packages
+  [#2545](https://github.com/commercialhaskell/stack/issues/2545)
 * Add the `dump-logs` config option and `--dump-logs` command line
   option to get full build output on the
   console. [#426](https://github.com/commercialhaskell/stack/issues/426)

doc/build_command.md

@@ -181,7 +181,7 @@ the build output from GHC will be hidden for building all dependencies, and
 will be displayed for the one target package.
 
 By default, when building multiple target packages, the output from these will
-also end up in a log file instead of on the console, to avoid problems of
-interleaved output and decrease console noise. If you would like to see this
-content instead, you can use the `--dump-logs` command line option, or add
-`dump-logs: true` to your `stack.yaml` file.
+end up in a log file instead of on the console unless it contains errors or
+warnings, to avoid problems of interleaved output and decrease console noise.
+If you would like to see this content instead, you can use the `--dump-logs`
+command line option, or add `dump-logs: all` to your `stack.yaml` file.

doc/yaml_configuration.md

@@ -599,16 +599,17 @@ same name. See the [build command docs](build_command.md) and the
 
 ### dump-logs
 
-(Since XXX)
+(Since UNRELEASED)
 
-Tell Stack to print the log output from all local non-dependency
-packages to the console. By default, Stack will only do this when
-building a single target package, to avoid generating unnecessarily
-verbose output. This can be useful when you want to see warnings from
-all of your packages.
+Control which log output from local non-dependency packages to print to the
+console. By default, Stack will only do this when building a single target
+package or if the log contains warnings, to avoid generating unnecessarily
+verbose output.
 
 ```yaml
-dump-logs: true
+dump-logs: none      # don't dump logs even if they contain warnings
+dump-logs: warning   # default: dump logs that contain warnings
+dump-logs: all       # dump all logs for local non-dependency packages
 ```
 
 ### templates

src/Data/Text/Extra.hs

@@ -0,0 +1,9 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Data.Text.Extra where
+
+import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+
+-- | Strip trailing carriage return from Text
+stripCR :: T.Text -> T.Text
+stripCR t = fromMaybe t (T.stripSuffix "\r" t)

src/Stack/Build/Execute.hs

@@ -56,6 +56,7 @@ import           Data.String
 import           Data.Text (Text)
 import qualified Data.Text as T
 import           Data.Text.Encoding (decodeUtf8)
+import           Data.Text.Extra (stripCR)
 import           Data.Time.Clock (getCurrentTime)
 import           Data.Traversable (forM)
 import           Data.Tuple
@@ -227,7 +228,7 @@ data ExecuteEnv = ExecuteEnv
     , eeGlobalDumpPkgs :: !(Map GhcPkgId (DumpPackage () ()))
     , eeSnapshotDumpPkgs :: !(TVar (Map GhcPkgId (DumpPackage () ())))
     , eeLocalDumpPkgs  :: !(TVar (Map GhcPkgId (DumpPackage () ())))
-    , eeLogFiles       :: !(TChan (Path Abs File))
+    , eeLogFiles       :: !(TChan (Path Abs Dir, Path Abs File))
     }
 
 -- | Get a compiled Setup exe
@@ -350,21 +351,24 @@ withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshot
     toDumpPackagesByGhcPkgId = Map.fromList . map (\dp -> (dpGhcPkgId dp, dp))
 
     dumpLogs chan totalWanted = do
-        allLogs <- liftIO $ atomically drainChan
+        allLogs <- fmap reverse $ liftIO $ atomically drainChan
         case allLogs of
             -- No log files generated, nothing to dump
             [] -> return ()
             firstLog:_ -> do
                 toDump <- asks (configDumpLogs . getConfig)
-                when toDump $ mapM_ dumpLog allLogs
-
-                when (not toDump && totalWanted > 1) $ $logInfo $ T.concat
-                    [ "Build output has been captured to log files, use "
-                    , "--dump-logs to see it on the console"
-                    ]
-
+                case toDump of
+                    DumpAllLogs -> mapM_ (dumpLog "") allLogs
+                    DumpWarningLogs -> mapM_ dumpLogIfWarning allLogs
+                    DumpNoLogs
+                        | totalWanted > 1 ->
+                            $logInfo $ T.concat
+                                [ "Build output has been captured to log files, use "
+                                , "--dump-logs to see it on the console"
+                                ]
+                        | otherwise -> return ()
                 $logInfo $ T.pack $ "Log files have been written to: "
-                        ++ toFilePath (parent firstLog)
+                        ++ toFilePath (parent (snd firstLog))
       where
         drainChan = do
             mx <- tryReadTChan chan
@@ -374,14 +378,28 @@ withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshot
                     xs <- drainChan
                     return $ x:xs
 
-    dumpLog filepath = do
-        $logInfo $ T.pack $ "\nDumping log file: " ++ toFilePath filepath ++ "\n"
+    dumpLogIfWarning (pkgDir, filepath) = do
+      firstWarning <- runResourceT
+          $ CB.sourceFile (toFilePath filepath)
+         $$ CT.decodeUtf8Lenient
+         =$ CT.lines
+         =$ CL.map stripCR
+         =$ CL.filter isWarning
+         =$ CL.take 1
+      if (null firstWarning)
+        then return ()
+        else dumpLog " due to warnings" (pkgDir, filepath)
+
+    isWarning t = ": Warning:" `T.isSuffixOf` t
+
+    dumpLog msgSuffix (pkgDir, filepath) = do
+        $logInfo $ T.pack $ concat ["\n--  Dumping log file", msgSuffix, ": ", toFilePath filepath, "\n"]
         runResourceT
             $ CB.sourceFile (toFilePath filepath)
            $$ CT.decodeUtf8Lenient
-           =$ CT.lines
+           =$ mungeBuildOutput True True pkgDir
            =$ CL.mapM_ $logInfo
-        $logInfo $ T.pack $ "\nEnd of log file: " ++ toFilePath filepath ++ "\n"
+        $logInfo $ T.pack $ "\n--  End of log file: " ++ toFilePath filepath ++ "\n"
 
 -- | Perform the actual plan
 executePlan :: M env m
@@ -805,7 +823,7 @@ withSingleContext :: M env m
                   -> m a
 withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffix inner0 =
     withPackage $ \package cabalfp pkgDir ->
-    withLogFile package $ \mlogFile ->
+    withLogFile pkgDir package $ \mlogFile ->
     withCabal package pkgDir mlogFile $ \cabal ->
     inner0 package cabalfp pkgDir cabal announce console mlogFile
   where
@@ -836,7 +854,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
                             inner package cabalfp dir
                     _ -> error $ "withPackage: invariant violated: " ++ show m
 
-    withLogFile package inner
+    withLogFile pkgDir package inner
         | console = inner Nothing
         | otherwise = do
             logPath <- buildLogPath package msuffix
@@ -846,7 +864,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
             -- We only want to dump logs for local non-dependency packages
             case taskType of
                 TTLocal lp | lpWanted lp ->
-                    liftIO $ atomically $ writeTChan eeLogFiles logPath
+                    liftIO $ atomically $ writeTChan eeLogFiles (pkgDir, logPath)
                 _ -> return ()
 
             bracket
@@ -1454,7 +1472,7 @@ mungeBuildOutput :: (MonadIO m, MonadCatch m)
                  -> ConduitM Text Text m ()
 mungeBuildOutput excludeTHLoading makeAbsolute pkgDir = void $
     CT.lines
-    =$ CL.map stripCarriageReturn
+    =$ CL.map stripCR
     =$ CL.filter (not . isTHLoading)
     =$ CL.mapM toAbsolutePath
   where
@@ -1490,10 +1508,6 @@ mungeBuildOutput excludeTHLoading makeAbsolute pkgDir = void $
            >> return ()
         where num = some digit
 
-    -- | Strip @\r@ characters from the byte vector. Used because Windows.
-    stripCarriageReturn :: Text -> Text
-    stripCarriageReturn = T.filter (/= '\r')
-
 -- | Find the Setup.hs or Setup.lhs in the given directory. If none exists,
 -- throw an exception.
 getSetupHs :: Path Abs Dir -- ^ project directory

src/Stack/Config.hs

@@ -311,7 +311,7 @@ configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject C
          configApplyGhcOptions = fromFirst AGOLocals configMonoidApplyGhcOptions
          configAllowNewer = fromFirst False configMonoidAllowNewer
          configDefaultTemplate = getFirst configMonoidDefaultTemplate
-         configDumpLogs = fromFirst False configMonoidDumpLogs
+         configDumpLogs = fromFirst DumpWarningLogs configMonoidDumpLogs
 
      configAllowDifferentUser <-
         case getFirst configMonoidAllowDifferentUser of

src/Stack/GhcPkg.hs

@@ -33,6 +33,7 @@ import           Data.Maybe
 import           Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
+import           Data.Text.Extra (stripCR)
 import           Path (Path, Abs, Dir, toFilePath, parent)
 import           Path.Extra (toFilePathNoTrailingSep)
 import           Path.IO
@@ -127,8 +128,6 @@ findGhcPkgField menv wc pkgDbs name field = do
             Left{} -> Nothing
             Right lbs ->
                 fmap (stripCR . T.decodeUtf8) $ listToMaybe $ S8.lines lbs
-  where
-    stripCR t = fromMaybe t (T.stripSuffix "\r" t)
 
 -- | Get the version of the package
 findGhcPkgVersion :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)

src/Stack/Options/ConfigParser.hs

@@ -119,8 +119,13 @@ configOptsParser hide0 =
             ("permission for users other than the owner of the stack root " ++
                 "directory to use a stack installation (POSIX only)")
             hide
-    <*> firstBoolFlags
-            "dump-logs"
-            "dump the build output logs for local packages to the console"
-            hide
-  where hide = hideMods (hide0 /= OuterGlobalOpts)
+    <*> fmap toDumpLogs
+            (firstBoolFlags
+             "dump-logs"
+             "dump the build output logs for local packages to the console"
+             hide)
+  where
+    hide = hideMods (hide0 /= OuterGlobalOpts)
+    toDumpLogs (First (Just True)) = First (Just DumpAllLogs)
+    toDumpLogs (First (Just False)) = First (Just DumpNoLogs)
+    toDumpLogs (First Nothing) = First Nothing

src/Stack/Solver.hs

@@ -42,14 +42,15 @@ import           Data.List                   ( (\\), isSuffixOf, intercalate
 import           Data.List.Extra             (groupSortOn)
 import           Data.Map                    (Map)
 import qualified Data.Map                    as Map
-import           Data.Maybe                  (catMaybes, isNothing, mapMaybe, fromMaybe)
+import           Data.Maybe                  (catMaybes, isNothing, mapMaybe)
 import           Data.Monoid
 import           Data.Set                    (Set)
 import qualified Data.Set                    as Set
 import           Data.Text                   (Text)
 import qualified Data.Text                   as T
 import           Data.Text.Encoding          (decodeUtf8, encodeUtf8)
 import           Data.Text.Encoding.Error    (lenientDecode)
+import           Data.Text.Extra             (stripCR)
 import qualified Data.Text.Lazy              as LT
 import           Data.Text.Lazy.Encoding     (decodeUtf8With)
 import           Data.Tuple                  (swap)
@@ -190,8 +191,6 @@ cabalSolver menv cabalfps constraintType
                        \not be parsed: \n"
                        ++ T.unpack (T.intercalate "\n" errs)
 
-    stripCR t = fromMaybe t (T.stripSuffix "\r" t)
-
     toConstraintArgs userFlagMap =
         [formatFlagConstraint package flag enabled
             | (package, fs) <- Map.toList userFlagMap

src/Stack/Types/Config.hs

@@ -65,6 +65,8 @@ module Stack.Types.Config
   ,ConfigMonoid(..)
   ,configMonoidInstallGHCName
   ,configMonoidSystemGHCName
+  -- ** DumpLogs
+  ,DumpLogs(..)
   -- ** EnvSettings
   ,EnvSettings(..)
   ,minimalEnvSettings
@@ -167,7 +169,7 @@ import           Control.Monad.Logger (LogLevel(..))
 import           Control.Monad.Reader (MonadReader, ask, asks, MonadIO, liftIO)
 import           Data.Aeson.Extended
                  (ToJSON, toJSON, FromJSON, parseJSON, withText, object,
-                  (.=), (..:), (..:?), (..!=), Value(String, Object),
+                  (.=), (..:), (..:?), (..!=), Value(Bool, String, Object),
                   withObjectWarnings, WarningParser, Object, jsonSubWarnings,
                   jsonSubWarningsT, jsonSubWarningsTT, WithJSONWarnings(..), noJSONWarnings)
 import           Data.Attoparsec.Args
@@ -340,7 +342,7 @@ data Config =
          -- installation.
          ,configPackageCaches       :: !(IORef (Maybe (Map PackageIdentifier (PackageIndex, PackageCache))))
          -- ^ In memory cache of hackage index.
-         ,configDumpLogs            :: !Bool
+         ,configDumpLogs            :: !DumpLogs
          -- ^ Dump logs of local non-dependencies when doing a build.
          ,configMaybeProject        :: !(Maybe (Project, Path Abs File))
          }
@@ -359,6 +361,26 @@ instance FromJSON ApplyGhcOptions where
             "everything" -> return AGOEverything
             _ -> fail $ "Invalid ApplyGhcOptions: " ++ show t
 
+-- | Which build log files to dump
+data DumpLogs
+  = DumpNoLogs -- ^ don't dump any logfiles
+  | DumpWarningLogs -- ^ dump logfiles containing warnings
+  | DumpAllLogs -- ^ dump all logfiles
+  deriving (Show, Read, Eq, Ord, Enum, Bounded)
+
+instance FromJSON DumpLogs where
+  parseJSON (Bool True) = return DumpAllLogs
+  parseJSON (Bool False) = return DumpNoLogs
+  parseJSON v =
+    withText
+      "DumpLogs"
+      (\t ->
+          if | t == "none" -> return DumpNoLogs
+             | t == "warning" -> return DumpWarningLogs
+             | t == "all" -> return DumpAllLogs
+             | otherwise -> fail ("Invalid DumpLogs: " ++ show t))
+      v
+
 -- | Controls which version of the environment is used
 data EnvSettings = EnvSettings
     { esIncludeLocals :: !Bool
@@ -870,7 +892,7 @@ data ConfigMonoid =
     , configMonoidAllowDifferentUser :: !(First Bool)
     -- ^ Allow users other than the stack root owner to use the stack
     -- installation.
-    , configMonoidDumpLogs           :: !(First Bool)
+    , configMonoidDumpLogs           :: !(First DumpLogs)
     -- ^ See 'configDumpLogs'
     }
   deriving (Show, Generic)
@@ -1093,15 +1115,15 @@ instance Show ConfigException where
         , toFilePath configFile
         , "':\n"
         , Yaml.prettyPrintParseException exception
-        , "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration/."
+        , "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration/"
         ]
     show (ParseCustomSnapshotException url exception) = concat
         [ "Could not parse '"
         , T.unpack url
         , "':\n"
         , Yaml.prettyPrintParseException exception
         -- FIXME: Link to docs about custom snapshots
-        -- , "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration/."
+        -- , "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration/"
         ]
     show (ParseResolverException t) = concat
         [ "Invalid resolver value: "

stack.cabal

@@ -66,6 +66,7 @@ library
                      Data.Maybe.Extra
                      Data.Monoid.Extra
                      Data.Store.VersionTagged
+                     Data.Text.Extra
                      Data.Yaml.Extra
                      Distribution.Version.Extra
                      Network.HTTP.Download