Skip to content

Commit 06de280

Browse files
mgsloanmgsloan
authored
Merge pull request #3127 from sergv/improve-filtering-of-ghc-messages
Improve filtering of ghc messages
2 parents f2cbb71 + dce9840 commit 06de280

File tree

2 files changed

+111
-48
lines changed

2 files changed

+111
-48
lines changed

‎src/Stack/Build/Execute.hs‎

Lines changed: 110 additions & 47 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,7 @@ module Stack.Build.Execute
1717
, ExecuteEnv
1818
, withExecuteEnv
1919
, withSingleContext
20+
, ExcludeTHLoading(..)
2021
) where
2122

2223
import Control.Applicative
@@ -329,7 +330,7 @@ getSetupExe setupHs setupShimHs tmpdir = do
329330
return $ Just exePath
330331

331332
-- | Execute a function that takes an 'ExecuteEnv'.
332-
withExecuteEnv :: (StackM env m, HasEnvConfig env)
333+
withExecuteEnv :: forall env m a. (StackM env m, HasEnvConfig env)
333334
=> EnvOverride
334335
-> BuildOpts
335336
-> BuildOptsCLI
@@ -404,6 +405,7 @@ withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshot
404405
where
405406
toDumpPackagesByGhcPkgId = Map.fromList . map (\dp -> (dpGhcPkgId dp, dp))
406407

408+
dumpLogs :: TChan (Path Abs Dir, Path Abs File) -> Int -> m ()
407409
dumpLogs chan totalWanted = do
408410
allLogs <- fmap reverse $ liftIO $ atomically drainChan
409411
case allLogs of
@@ -424,6 +426,7 @@ withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshot
424426
$logInfo $ T.pack $ "Log files have been written to: "
425427
++ toFilePath (parent (snd firstLog))
426428
where
429+
drainChan :: STM [(Path Abs Dir, Path Abs File)]
427430
drainChan = do
428431
mx <- tryReadTChan chan
429432
case mx of
@@ -432,6 +435,7 @@ withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshot
432435
xs <- drainChan
433436
return $ x:xs
434437

438+
dumpLogIfWarning :: (Path Abs Dir, Path Abs File) -> m ()
435439
dumpLogIfWarning (pkgDir, filepath) = do
436440
firstWarning <- runResourceT
437441
$ CB.sourceFile (toFilePath filepath)
@@ -442,15 +446,18 @@ withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshot
442446
=$ CL.take 1
443447
unless (null firstWarning) $ dumpLog " due to warnings" (pkgDir, filepath)
444448

449+
isWarning :: Text -> Bool
445450
isWarning t = ": Warning:" `T.isSuffixOf` t -- prior to GHC 8
446451
|| ": warning:" `T.isInfixOf` t -- GHC 8 is slightly different
447452

453+
dumpLog :: String -> (Path Abs Dir, Path Abs File) -> m ()
448454
dumpLog msgSuffix (pkgDir, filepath) = do
449455
$logInfo $ T.pack $ concat ["\n-- Dumping log file", msgSuffix, ": ", toFilePath filepath, "\n"]
456+
compilerVer <- view actualCompilerVersionL
450457
runResourceT
451458
$ CB.sourceFile (toFilePath filepath)
452459
$$ CT.decodeUtf8Lenient
453-
=$ mungeBuildOutput True True pkgDir
460+
=$ mungeBuildOutput ExcludeTHLoading ConvertPathsToAbsolute pkgDir compilerVer
454461
=$ CL.mapM_ $logInfo
455462
$logInfo $ T.pack $ "\n-- End of log file: " ++ toFilePath filepath ++ "\n"
456463

@@ -808,7 +815,7 @@ ensureConfig :: (StackM env m, HasEnvConfig env)
808815
-> Path Abs Dir -- ^ package directory
809816
-> ExecuteEnv m
810817
-> m () -- ^ announce
811-
-> (Bool -> [String] -> m ()) -- ^ cabal
818+
-> (ExcludeTHLoading -> [String] -> m ()) -- ^ cabal
812819
-> Path Abs File -- ^ .cabal file
813820
-> m Bool
814821
ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp = do
@@ -847,7 +854,7 @@ ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp = do
847854
Just x -> return $ concat ["--with-", name, "=", toFilePath x]
848855
-- Configure cabal with arguments determined by
849856
-- Stack.Types.Build.configureOpts
850-
cabal False $ "configure" : concat
857+
cabal KeepTHLoading $ "configure" : concat
851858
[ concat exes
852859
, dirs
853860
, nodirs
@@ -875,7 +882,7 @@ announceTask task x = $logInfo $ T.concat
875882
-- custom setup is built.
876883
--
877884
-- * Provides the user a function with which run the Cabal process.
878-
withSingleContext :: (StackM env m, HasEnvConfig env)
885+
withSingleContext :: forall env m a. (StackM env m, HasEnvConfig env)
879886
=> (m () -> IO ())
880887
-> ActionContext
881888
-> ExecuteEnv m
@@ -885,14 +892,13 @@ withSingleContext :: (StackM env m, HasEnvConfig env)
885892
-- Nothing, just provide global and snapshot package
886893
-- databases.
887894
-> Maybe String
888-
-> ( Package -- Package info
889-
-> Path Abs File -- Cabal file path
890-
-> Path Abs Dir -- Package root directory file path
891-
-> (Bool -> [String] -> m ()) -- Function to run Cabal with args
892-
-- The Bool indicates if it's a build step, so strip TH stuff
893-
-> (Text -> m ()) -- An 'announce' function, for different build phases
894-
-> Bool -- Whether output should be directed to the console
895-
-> Maybe (Path Abs File, Handle) -- Log file
895+
-> ( Package -- Package info
896+
-> Path Abs File -- Cabal file path
897+
-> Path Abs Dir -- Package root directory file path
898+
-> (ExcludeTHLoading -> [String] -> m ()) -- Function to run Cabal with args
899+
-> (Text -> m ()) -- An 'announce' function, for different build phases
900+
-> Bool -- Whether output should be directed to the console
901+
-> Maybe (Path Abs File, Handle) -- Log file
896902
-> m a)
897903
-> m a
898904
withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffix inner0 =
@@ -946,6 +952,12 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
946952
(liftIO . hClose)
947953
$ \h -> inner (Just (logPath, h))
948954

955+
withCabal
956+
:: Package
957+
-> Path Abs Dir
958+
-> Maybe (Path Abs File, Handle)
959+
-> ((ExcludeTHLoading -> [String] -> m ()) -> m a)
960+
-> m a
949961
withCabal package pkgDir mlogFile inner = do
950962
config <- view configL
951963

@@ -987,6 +999,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
987999
: ["-hide-all-packages"]
9881000
)
9891001

1002+
warnCustomNoDeps :: m ()
9901003
warnCustomNoDeps =
9911004
case (taskType, packageBuildType package) of
9921005
(TTLocal{}, Just C.Custom) -> do
@@ -999,6 +1012,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
9991012
$logWarn "Strongly recommend fixing the package's cabal file"
10001013
_ -> return ()
10011014

1015+
getPackageArgs :: Path Abs Dir -> m [String]
10021016
getPackageArgs setupDir =
10031017
case (packageSetupDeps package, mdeps) of
10041018
-- The package is using the Cabal custom-setup
@@ -1078,8 +1092,11 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
10781092
++ ["-package-db=" ++ toFilePathNoTrailingSep (bcoSnapDB eeBaseConfigOpts)])
10791093

10801094
setupArgs = ("--builddir=" ++ toFilePathNoTrailingSep distRelativeDir') : args
1081-
runExe exeName fullArgs =
1082-
runAndOutput `catch` \(ProcessExitedUnsuccessfully _ ec) -> do
1095+
1096+
runExe :: Path Abs File -> [String] -> m ()
1097+
runExe exeName fullArgs = do
1098+
compilerVer <- view actualCompilerVersionL
1099+
runAndOutput compilerVer `catch` \(ProcessExitedUnsuccessfully _ ec) -> do
10831100
bss <-
10841101
case mlogFile of
10851102
Nothing -> return []
@@ -1088,7 +1105,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
10881105
runResourceT
10891106
$ CB.sourceFile (toFilePath logFile)
10901107
=$= CT.decodeUtf8Lenient
1091-
$$ mungeBuildOutput stripTHLoading makeAbsolute pkgDir
1108+
$$ mungeBuildOutput stripTHLoading makeAbsolute pkgDir compilerVer
10921109
=$ CL.consume
10931110
throwM $ CabalExitedUnsuccessfully
10941111
ec
@@ -1098,19 +1115,28 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
10981115
(fmap fst mlogFile)
10991116
bss
11001117
where
1101-
runAndOutput = case mlogFile of
1118+
runAndOutput :: CompilerVersion -> m ()
1119+
runAndOutput compilerVer = case mlogFile of
11021120
Just (_, h) ->
11031121
sinkProcessStderrStdoutHandle (Just pkgDir) menv (toFilePath exeName) fullArgs h h
11041122
Nothing ->
11051123
void $ sinkProcessStderrStdout (Just pkgDir) menv (toFilePath exeName) fullArgs
1106-
(outputSink False LevelWarn)
1107-
(outputSink stripTHLoading LevelInfo)
1108-
outputSink excludeTH level =
1124+
(outputSink KeepTHLoading LevelWarn compilerVer)
1125+
(outputSink stripTHLoading LevelInfo compilerVer)
1126+
outputSink
1127+
:: ExcludeTHLoading
1128+
-> LogLevel
1129+
-> CompilerVersion
1130+
-> Sink S.ByteString IO ()
1131+
outputSink excludeTH level compilerVer =
11091132
CT.decodeUtf8Lenient
1110-
=$ mungeBuildOutput excludeTH makeAbsolute pkgDir
1133+
=$ mungeBuildOutput excludeTH makeAbsolute pkgDir compilerVer
11111134
=$ CL.mapM_ (runInBase . monadLoggerLog $(TH.location >>= liftLoc) "" level)
11121135
-- If users want control, we should add a config option for this
1113-
makeAbsolute = stripTHLoading
1136+
makeAbsolute :: ConvertPathsToAbsolute
1137+
makeAbsolute = case stripTHLoading of
1138+
ExcludeTHLoading -> ConvertPathsToAbsolute
1139+
KeepTHLoading -> KeepPathsAsIs
11141140

11151141
wc <- view $ actualCompilerVersionL.whichCompilerL
11161142
exeName <- case (esetupexehs, wc) of
@@ -1166,7 +1192,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
11661192
-- local install directory. Note that this is literally invoking Cabal
11671193
-- with @copy@, and not the copying done by @stack install@ - that is
11681194
-- handled by 'copyExecutables'.
1169-
singleBuild :: (StackM env m, HasEnvConfig env)
1195+
singleBuild :: forall env m. (StackM env m, HasEnvConfig env)
11701196
=> (m () -> IO ())
11711197
-> ActionContext
11721198
-> ExecuteEnv m
@@ -1322,8 +1348,15 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in
13221348

13231349
initialBuildSteps cabal announce = do
13241350
() <- announce ("initial-build-steps" <> annSuffix)
1325-
cabal False ["repl", "stack-initial-build-steps"]
1326-
1351+
cabal KeepTHLoading ["repl", "stack-initial-build-steps"]
1352+
1353+
realBuild
1354+
:: ConfigCache
1355+
-> Package
1356+
-> Path Abs Dir
1357+
-> (ExcludeTHLoading -> [String] -> m ())
1358+
-> (Text -> m ())
1359+
-> m Installed
13271360
realBuild cache package pkgDir cabal announce = do
13281361
wc <- view $ actualCompilerVersionL.whichCompilerL
13291362

@@ -1363,7 +1396,10 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in
13631396
() <- announce ("build" <> annSuffix)
13641397
config <- view configL
13651398
extraOpts <- extraBuildOptions wc eeBuildOpts
1366-
cabal (configHideTHLoading config) (("build" :) $ (++ extraOpts) $
1399+
let stripTHLoading
1400+
| configHideTHLoading config = ExcludeTHLoading
1401+
| otherwise = KeepTHLoading
1402+
cabal stripTHLoading (("build" :) $ (++ extraOpts) $
13671403
case (taskType, taskAllInOne, isFinalBuild) of
13681404
(_, True, True) -> error "Invariant violated: cannot have an all-in-one build that also has a final build step."
13691405
(TTLocal lp, False, False) -> primaryComponentOptions lp
@@ -1391,22 +1427,23 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in
13911427
("Warning: haddock not generating hyperlinked sources because 'HsColour' not\n" <>
13921428
"found on PATH (use 'stack install hscolour' to install).")
13931429
return ["--hyperlink-source" | hscolourExists]
1394-
cabal False (concat [ ["haddock", "--html", "--html-location=../$pkg-$version/"]
1395-
, sourceFlag
1396-
, ["--internal" | boptsHaddockInternal eeBuildOpts]
1397-
, [ "--haddock-option=" <> opt
1398-
| opt <- hoAdditionalArgs (boptsHaddockOpts eeBuildOpts) ]
1399-
])
1430+
cabal KeepTHLoading $ concat
1431+
[ ["haddock", "--html", "--html-location=../$pkg-$version/"]
1432+
, sourceFlag
1433+
, ["--internal" | boptsHaddockInternal eeBuildOpts]
1434+
, [ "--haddock-option=" <> opt
1435+
| opt <- hoAdditionalArgs (boptsHaddockOpts eeBuildOpts) ]
1436+
]
14001437

14011438
let shouldCopy = not isFinalBuild && (packageHasLibrary package || not (Set.null (packageExes package)))
14021439
when shouldCopy $ withMVar eeInstallLock $ \() -> do
14031440
announce "copy/register"
1404-
eres <- try $ cabal False ["copy"]
1441+
eres <- try $ cabal KeepTHLoading ["copy"]
14051442
case eres of
14061443
Left err@CabalExitedUnsuccessfully{} ->
14071444
throwM $ CabalCopyFailed (packageBuildType package == Just C.Simple) (show err)
14081445
_ -> return ()
1409-
when (packageHasLibrary package) $ cabal False ["register"]
1446+
when (packageHasLibrary package) $ cabal KeepTHLoading ["register"]
14101447

14111448
let (installedPkgDb, installedDumpPkgsTVar) =
14121449
case taskLocation task of
@@ -1649,31 +1686,54 @@ singleBench runInBase beopts benchesToRun ac ee task installedMap = do
16491686
return True
16501687

16511688
when toRun $ do
1652-
announce "benchmarks"
1653-
cabal False ("bench" : args)
1689+
announce "benchmarks"
1690+
cabal KeepTHLoading ("bench" : args)
1691+
1692+
data ExcludeTHLoading = ExcludeTHLoading | KeepTHLoading
1693+
data ConvertPathsToAbsolute = ConvertPathsToAbsolute | KeepPathsAsIs
16541694

16551695
-- | Strip Template Haskell "Loading package" lines and making paths absolute.
1656-
mungeBuildOutput :: (MonadIO m, MonadCatch m, MonadBaseControl IO m)
1657-
=> Bool -- ^ exclude TH loading?
1658-
-> Bool -- ^ convert paths to absolute?
1659-
-> Path Abs Dir -- ^ package's root directory
1696+
mungeBuildOutput :: forall m. (MonadIO m, MonadCatch m, MonadBaseControl IO m)
1697+
=> ExcludeTHLoading -- ^ exclude TH loading?
1698+
-> ConvertPathsToAbsolute -- ^ convert paths to absolute?
1699+
-> Path Abs Dir -- ^ package's root directory
1700+
-> CompilerVersion -- ^ compiler we're building with
16601701
-> ConduitM Text Text m ()
1661-
mungeBuildOutput excludeTHLoading makeAbsolute pkgDir = void $
1702+
mungeBuildOutput excludeTHLoading makeAbsolute pkgDir compilerVer = void $
16621703
CT.lines
16631704
=$ CL.map stripCR
16641705
=$ CL.filter (not . isTHLoading)
1665-
=$ CL.mapM toAbsolutePath
1706+
=$ filterLinkerWarnings
1707+
=$ toAbsolute
16661708
where
16671709
-- | Is this line a Template Haskell "Loading package" line
16681710
-- ByteString
16691711
isTHLoading :: Text -> Bool
1670-
isTHLoading _ | not excludeTHLoading = False
1671-
isTHLoading bs =
1672-
"Loading package " `T.isPrefixOf` bs &&
1673-
("done." `T.isSuffixOf` bs || "done.\r" `T.isSuffixOf` bs)
1712+
isTHLoading = case excludeTHLoading of
1713+
KeepTHLoading -> const False
1714+
ExcludeTHLoading -> \bs ->
1715+
"Loading package " `T.isPrefixOf` bs &&
1716+
("done." `T.isSuffixOf` bs || "done.\r" `T.isSuffixOf` bs)
1717+
1718+
filterLinkerWarnings :: ConduitM Text Text m ()
1719+
filterLinkerWarnings
1720+
-- Check for ghc 7.8 since it's the only one prone to producing
1721+
-- linker warnings on Windows x64
1722+
| getGhcVersion compilerVer >= $(mkVersion "7.8") = doNothing
1723+
| otherwise = CL.filter (not . isLinkerWarning)
1724+
1725+
isLinkerWarning :: Text -> Bool
1726+
isLinkerWarning str =
1727+
("ghc.exe: warning:" `T.isPrefixOf` str || "ghc.EXE: warning:" `T.isPrefixOf` str) &&
1728+
"is linked instead of __imp_" `T.isInfixOf` str
16741729

16751730
-- | Convert GHC error lines with file paths to have absolute file paths
1676-
toAbsolutePath bs | not makeAbsolute = return bs
1731+
toAbsolute :: ConduitM Text Text m ()
1732+
toAbsolute = case makeAbsolute of
1733+
KeepPathsAsIs -> doNothing
1734+
ConvertPathsToAbsolute -> CL.mapM toAbsolutePath
1735+
1736+
toAbsolutePath :: Text -> m Text
16771737
toAbsolutePath bs = do
16781738
let (x, y) = T.break (== ':') bs
16791739
mabs <-
@@ -1686,6 +1746,9 @@ mungeBuildOutput excludeTHLoading makeAbsolute pkgDir = void $
16861746
Nothing -> return bs
16871747
Just fp -> return $ fp `T.append` y
16881748

1749+
doNothing :: ConduitM Text Text m ()
1750+
doNothing = awaitForever yield
1751+
16891752
-- | Match the error location format at the end of lines
16901753
isValidSuffix = isRight . parseOnly lineCol
16911754
lineCol = char ':'

‎src/Stack/SDist.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -266,7 +266,7 @@ getSDistFileList lp =
266266
$ \ee ->
267267
withSingleContext runInBase ac ee task Nothing (Just "sdist") $ \_package cabalfp _pkgDir cabal _announce _console _mlogFile -> do
268268
let outFile = toFilePath tmpdir FP.</> "source-files-list"
269-
cabal False ["sdist", "--list-sources", outFile]
269+
cabal KeepTHLoading ["sdist", "--list-sources", outFile]
270270
contents <- liftIO (readFile outFile)
271271
return (contents, cabalfp)
272272
where

0 commit comments

Comments
 (0)