diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 23f4d170e8..2561641d2c 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -17,6 +17,7 @@ module Stack.Build.Execute , ExecuteEnv , withExecuteEnv , withSingleContext + , ExcludeTHLoading(..) ) where import Control.Applicative @@ -329,7 +330,7 @@ getSetupExe setupHs setupShimHs tmpdir = do return $ Just exePath -- | Execute a function that takes an 'ExecuteEnv'. -withExecuteEnv :: (StackM env m, HasEnvConfig env) +withExecuteEnv :: forall env m a. (StackM env m, HasEnvConfig env) => EnvOverride -> BuildOpts -> BuildOptsCLI @@ -404,6 +405,7 @@ withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshot where toDumpPackagesByGhcPkgId = Map.fromList . map (\dp -> (dpGhcPkgId dp, dp)) + dumpLogs :: TChan (Path Abs Dir, Path Abs File) -> Int -> m () dumpLogs chan totalWanted = do allLogs <- fmap reverse $ liftIO $ atomically drainChan case allLogs of @@ -424,6 +426,7 @@ withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshot $logInfo $ T.pack $ "Log files have been written to: " ++ toFilePath (parent (snd firstLog)) where + drainChan :: STM [(Path Abs Dir, Path Abs File)] drainChan = do mx <- tryReadTChan chan case mx of @@ -432,6 +435,7 @@ withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshot xs <- drainChan return $ x:xs + dumpLogIfWarning :: (Path Abs Dir, Path Abs File) -> m () dumpLogIfWarning (pkgDir, filepath) = do firstWarning <- runResourceT $ CB.sourceFile (toFilePath filepath) @@ -442,15 +446,18 @@ withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshot =$ CL.take 1 unless (null firstWarning) $ dumpLog " due to warnings" (pkgDir, filepath) + isWarning :: Text -> Bool isWarning t = ": Warning:" `T.isSuffixOf` t -- prior to GHC 8 || ": warning:" `T.isInfixOf` t -- GHC 8 is slightly different + dumpLog :: String -> (Path Abs Dir, Path Abs File) -> m () dumpLog msgSuffix (pkgDir, filepath) = do $logInfo $ T.pack $ concat ["\n-- Dumping log file", msgSuffix, ": ", toFilePath filepath, "\n"] + compilerVer <- view actualCompilerVersionL runResourceT $ CB.sourceFile (toFilePath filepath) $$ CT.decodeUtf8Lenient - =$ mungeBuildOutput True True pkgDir + =$ mungeBuildOutput ExcludeTHLoading ConvertPathsToAbsolute pkgDir compilerVer =$ CL.mapM_ $logInfo $logInfo $ T.pack $ "\n-- End of log file: " ++ toFilePath filepath ++ "\n" @@ -808,7 +815,7 @@ ensureConfig :: (StackM env m, HasEnvConfig env) -> Path Abs Dir -- ^ package directory -> ExecuteEnv m -> m () -- ^ announce - -> (Bool -> [String] -> m ()) -- ^ cabal + -> (ExcludeTHLoading -> [String] -> m ()) -- ^ cabal -> Path Abs File -- ^ .cabal file -> m Bool ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp = do @@ -847,7 +854,7 @@ ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp = do Just x -> return $ concat ["--with-", name, "=", toFilePath x] -- Configure cabal with arguments determined by -- Stack.Types.Build.configureOpts - cabal False $ "configure" : concat + cabal KeepTHLoading $ "configure" : concat [ concat exes , dirs , nodirs @@ -875,7 +882,7 @@ announceTask task x = $logInfo $ T.concat -- custom setup is built. -- -- * Provides the user a function with which run the Cabal process. -withSingleContext :: (StackM env m, HasEnvConfig env) +withSingleContext :: forall env m a. (StackM env m, HasEnvConfig env) => (m () -> IO ()) -> ActionContext -> ExecuteEnv m @@ -885,14 +892,13 @@ withSingleContext :: (StackM env m, HasEnvConfig env) -- Nothing, just provide global and snapshot package -- databases. -> Maybe String - -> ( Package -- Package info - -> Path Abs File -- Cabal file path - -> Path Abs Dir -- Package root directory file path - -> (Bool -> [String] -> m ()) -- Function to run Cabal with args - -- The Bool indicates if it's a build step, so strip TH stuff - -> (Text -> m ()) -- An 'announce' function, for different build phases - -> Bool -- Whether output should be directed to the console - -> Maybe (Path Abs File, Handle) -- Log file + -> ( Package -- Package info + -> Path Abs File -- Cabal file path + -> Path Abs Dir -- Package root directory file path + -> (ExcludeTHLoading -> [String] -> m ()) -- Function to run Cabal with args + -> (Text -> m ()) -- An 'announce' function, for different build phases + -> Bool -- Whether output should be directed to the console + -> Maybe (Path Abs File, Handle) -- Log file -> m a) -> m a withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffix inner0 = @@ -946,6 +952,12 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md (liftIO . hClose) $ \h -> inner (Just (logPath, h)) + withCabal + :: Package + -> Path Abs Dir + -> Maybe (Path Abs File, Handle) + -> ((ExcludeTHLoading -> [String] -> m ()) -> m a) + -> m a withCabal package pkgDir mlogFile inner = do config <- view configL @@ -987,6 +999,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md : ["-hide-all-packages"] ) + warnCustomNoDeps :: m () warnCustomNoDeps = case (taskType, packageBuildType package) of (TTLocal{}, Just C.Custom) -> do @@ -999,6 +1012,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md $logWarn "Strongly recommend fixing the package's cabal file" _ -> return () + getPackageArgs :: Path Abs Dir -> m [String] getPackageArgs setupDir = case (packageSetupDeps package, mdeps) of -- The package is using the Cabal custom-setup @@ -1078,8 +1092,11 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md ++ ["-package-db=" ++ toFilePathNoTrailingSep (bcoSnapDB eeBaseConfigOpts)]) setupArgs = ("--builddir=" ++ toFilePathNoTrailingSep distRelativeDir') : args - runExe exeName fullArgs = - runAndOutput `catch` \(ProcessExitedUnsuccessfully _ ec) -> do + + runExe :: Path Abs File -> [String] -> m () + runExe exeName fullArgs = do + compilerVer <- view actualCompilerVersionL + runAndOutput compilerVer `catch` \(ProcessExitedUnsuccessfully _ ec) -> do bss <- case mlogFile of Nothing -> return [] @@ -1088,7 +1105,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md runResourceT $ CB.sourceFile (toFilePath logFile) =$= CT.decodeUtf8Lenient - $$ mungeBuildOutput stripTHLoading makeAbsolute pkgDir + $$ mungeBuildOutput stripTHLoading makeAbsolute pkgDir compilerVer =$ CL.consume throwM $ CabalExitedUnsuccessfully ec @@ -1098,19 +1115,28 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md (fmap fst mlogFile) bss where - runAndOutput = case mlogFile of + runAndOutput :: CompilerVersion -> m () + runAndOutput compilerVer = case mlogFile of Just (_, h) -> sinkProcessStderrStdoutHandle (Just pkgDir) menv (toFilePath exeName) fullArgs h h Nothing -> void $ sinkProcessStderrStdout (Just pkgDir) menv (toFilePath exeName) fullArgs - (outputSink False LevelWarn) - (outputSink stripTHLoading LevelInfo) - outputSink excludeTH level = + (outputSink KeepTHLoading LevelWarn compilerVer) + (outputSink stripTHLoading LevelInfo compilerVer) + outputSink + :: ExcludeTHLoading + -> LogLevel + -> CompilerVersion + -> Sink S.ByteString IO () + outputSink excludeTH level compilerVer = CT.decodeUtf8Lenient - =$ mungeBuildOutput excludeTH makeAbsolute pkgDir + =$ mungeBuildOutput excludeTH makeAbsolute pkgDir compilerVer =$ CL.mapM_ (runInBase . monadLoggerLog $(TH.location >>= liftLoc) "" level) -- If users want control, we should add a config option for this - makeAbsolute = stripTHLoading + makeAbsolute :: ConvertPathsToAbsolute + makeAbsolute = case stripTHLoading of + ExcludeTHLoading -> ConvertPathsToAbsolute + KeepTHLoading -> KeepPathsAsIs wc <- view $ actualCompilerVersionL.whichCompilerL exeName <- case (esetupexehs, wc) of @@ -1166,7 +1192,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md -- local install directory. Note that this is literally invoking Cabal -- with @copy@, and not the copying done by @stack install@ - that is -- handled by 'copyExecutables'. -singleBuild :: (StackM env m, HasEnvConfig env) +singleBuild :: forall env m. (StackM env m, HasEnvConfig env) => (m () -> IO ()) -> ActionContext -> ExecuteEnv m @@ -1322,8 +1348,15 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in initialBuildSteps cabal announce = do () <- announce ("initial-build-steps" <> annSuffix) - cabal False ["repl", "stack-initial-build-steps"] - + cabal KeepTHLoading ["repl", "stack-initial-build-steps"] + + realBuild + :: ConfigCache + -> Package + -> Path Abs Dir + -> (ExcludeTHLoading -> [String] -> m ()) + -> (Text -> m ()) + -> m Installed realBuild cache package pkgDir cabal announce = do wc <- view $ actualCompilerVersionL.whichCompilerL @@ -1363,7 +1396,10 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in () <- announce ("build" <> annSuffix) config <- view configL extraOpts <- extraBuildOptions wc eeBuildOpts - cabal (configHideTHLoading config) (("build" :) $ (++ extraOpts) $ + let stripTHLoading + | configHideTHLoading config = ExcludeTHLoading + | otherwise = KeepTHLoading + cabal stripTHLoading (("build" :) $ (++ extraOpts) $ case (taskType, taskAllInOne, isFinalBuild) of (_, True, True) -> error "Invariant violated: cannot have an all-in-one build that also has a final build step." (TTLocal lp, False, False) -> primaryComponentOptions lp @@ -1391,22 +1427,23 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in ("Warning: haddock not generating hyperlinked sources because 'HsColour' not\n" <> "found on PATH (use 'stack install hscolour' to install).") return ["--hyperlink-source" | hscolourExists] - cabal False (concat [ ["haddock", "--html", "--html-location=../$pkg-$version/"] - , sourceFlag - , ["--internal" | boptsHaddockInternal eeBuildOpts] - , [ "--haddock-option=" <> opt - | opt <- hoAdditionalArgs (boptsHaddockOpts eeBuildOpts) ] - ]) + cabal KeepTHLoading $ concat + [ ["haddock", "--html", "--html-location=../$pkg-$version/"] + , sourceFlag + , ["--internal" | boptsHaddockInternal eeBuildOpts] + , [ "--haddock-option=" <> opt + | opt <- hoAdditionalArgs (boptsHaddockOpts eeBuildOpts) ] + ] let shouldCopy = not isFinalBuild && (packageHasLibrary package || not (Set.null (packageExes package))) when shouldCopy $ withMVar eeInstallLock $ \() -> do announce "copy/register" - eres <- try $ cabal False ["copy"] + eres <- try $ cabal KeepTHLoading ["copy"] case eres of Left err@CabalExitedUnsuccessfully{} -> throwM $ CabalCopyFailed (packageBuildType package == Just C.Simple) (show err) _ -> return () - when (packageHasLibrary package) $ cabal False ["register"] + when (packageHasLibrary package) $ cabal KeepTHLoading ["register"] let (installedPkgDb, installedDumpPkgsTVar) = case taskLocation task of @@ -1649,31 +1686,54 @@ singleBench runInBase beopts benchesToRun ac ee task installedMap = do return True when toRun $ do - announce "benchmarks" - cabal False ("bench" : args) + announce "benchmarks" + cabal KeepTHLoading ("bench" : args) + +data ExcludeTHLoading = ExcludeTHLoading | KeepTHLoading +data ConvertPathsToAbsolute = ConvertPathsToAbsolute | KeepPathsAsIs -- | Strip Template Haskell "Loading package" lines and making paths absolute. -mungeBuildOutput :: (MonadIO m, MonadCatch m, MonadBaseControl IO m) - => Bool -- ^ exclude TH loading? - -> Bool -- ^ convert paths to absolute? - -> Path Abs Dir -- ^ package's root directory +mungeBuildOutput :: forall m. (MonadIO m, MonadCatch m, MonadBaseControl IO m) + => ExcludeTHLoading -- ^ exclude TH loading? + -> ConvertPathsToAbsolute -- ^ convert paths to absolute? + -> Path Abs Dir -- ^ package's root directory + -> CompilerVersion -- ^ compiler we're building with -> ConduitM Text Text m () -mungeBuildOutput excludeTHLoading makeAbsolute pkgDir = void $ +mungeBuildOutput excludeTHLoading makeAbsolute pkgDir compilerVer = void $ CT.lines =$ CL.map stripCR =$ CL.filter (not . isTHLoading) - =$ CL.mapM toAbsolutePath + =$ filterLinkerWarnings + =$ toAbsolute where -- | Is this line a Template Haskell "Loading package" line -- ByteString isTHLoading :: Text -> Bool - isTHLoading _ | not excludeTHLoading = False - isTHLoading bs = - "Loading package " `T.isPrefixOf` bs && - ("done." `T.isSuffixOf` bs || "done.\r" `T.isSuffixOf` bs) + isTHLoading = case excludeTHLoading of + KeepTHLoading -> const False + ExcludeTHLoading -> \bs -> + "Loading package " `T.isPrefixOf` bs && + ("done." `T.isSuffixOf` bs || "done.\r" `T.isSuffixOf` bs) + + filterLinkerWarnings :: ConduitM Text Text m () + filterLinkerWarnings + -- Check for ghc 7.8 since it's the only one prone to producing + -- linker warnings on Windows x64 + | getGhcVersion compilerVer >= $(mkVersion "7.8") = doNothing + | otherwise = CL.filter (not . isLinkerWarning) + + isLinkerWarning :: Text -> Bool + isLinkerWarning str = + ("ghc.exe: warning:" `T.isPrefixOf` str || "ghc.EXE: warning:" `T.isPrefixOf` str) && + "is linked instead of __imp_" `T.isInfixOf` str -- | Convert GHC error lines with file paths to have absolute file paths - toAbsolutePath bs | not makeAbsolute = return bs + toAbsolute :: ConduitM Text Text m () + toAbsolute = case makeAbsolute of + KeepPathsAsIs -> doNothing + ConvertPathsToAbsolute -> CL.mapM toAbsolutePath + + toAbsolutePath :: Text -> m Text toAbsolutePath bs = do let (x, y) = T.break (== ':') bs mabs <- @@ -1686,6 +1746,9 @@ mungeBuildOutput excludeTHLoading makeAbsolute pkgDir = void $ Nothing -> return bs Just fp -> return $ fp `T.append` y + doNothing :: ConduitM Text Text m () + doNothing = awaitForever yield + -- | Match the error location format at the end of lines isValidSuffix = isRight . parseOnly lineCol lineCol = char ':' diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index 25cd55627c..04afe6ffb7 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -266,7 +266,7 @@ getSDistFileList lp = $ \ee -> withSingleContext runInBase ac ee task Nothing (Just "sdist") $ \_package cabalfp _pkgDir cabal _announce _console _mlogFile -> do let outFile = toFilePath tmpdir FP. "source-files-list" - cabal False ["sdist", "--list-sources", outFile] + cabal KeepTHLoading ["sdist", "--list-sources", outFile] contents <- liftIO (readFile outFile) return (contents, cabalfp) where