stack build: Add --keep-tmp-files flag. Fixes commercialhaskell#3857

src/Stack/Build/Execute.hs

@@ -327,7 +327,7 @@ withExecuteEnv :: forall env a. HasEnvConfig env
                -> (ExecuteEnv -> RIO env a)
                -> RIO env a
 withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages inner =
-    withSystemTempDir stackProgName $ \tmpdir -> do
+    createTempDirFunction stackProgName $ \tmpdir -> do
         configLock <- liftIO $ newMVar ()
         installLock <- liftIO $ newMVar ()
         idMap <- liftIO $ newTVarIO Map.empty
@@ -391,6 +391,10 @@ withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshot
   where
     toDumpPackagesByGhcPkgId = Map.fromList . map (\dp -> (dpGhcPkgId dp, dp))
 
+    createTempDirFunction
+        | Just True <- boptsKeepTmpFiles bopts = withKeepSystemTempDir
+        | otherwise = withSystemTempDir
+
     dumpLogs :: TChan (Path Abs Dir, Path Abs File) -> Int -> RIO env ()
     dumpLogs chan totalWanted = do
         allLogs <- fmap reverse $ liftIO $ atomically drainChan

src/Stack/Config/Build.hs

@@ -50,6 +50,7 @@ buildOptsFromMonoid BuildOptsMonoid{..} = BuildOpts
           (boptsPreFetch defaultBuildOpts)
           buildMonoidPreFetch
     , boptsKeepGoing = getFirst buildMonoidKeepGoing
+    , boptsKeepTmpFiles = getFirst buildMonoidKeepTmpFiles
     , boptsForceDirty = fromFirst
           (boptsForceDirty defaultBuildOpts)
           buildMonoidForceDirty

src/Stack/Options/BuildMonoidParser.hs

@@ -19,7 +19,7 @@ buildOptsMonoidParser hide0 =
     exeStripping <*> haddock <*> haddockOptsParser hideBool <*>
     openHaddocks <*> haddockDeps <*> haddockInternal <*>
     haddockHyperlinkSource <*> copyBins <*> copyCompilerTool <*>
-    preFetch <*> keepGoing <*> forceDirty <*>
+    preFetch <*> keepGoing <*> keepTmpFiles <*> forceDirty <*>
     tests <*> testOptsParser hideBool <*> benches <*>
     benchOptsParser hideBool <*> reconfigure <*> cabalVerbose <*> splitObjs <*> skipComponents
   where
@@ -120,6 +120,11 @@ buildOptsMonoidParser hide0 =
             "keep-going"
             "continue running after a step fails (default: false for build, true for test/bench)"
             hide
+    keepTmpFiles =
+        firstBoolFlags
+            "keep-tmp-files"
+            "keep intermediate files and build directories (default: false)"
+            hide
     preFetch =
         firstBoolFlags
             "prefetch"

src/Stack/Prelude.hs

@@ -9,6 +9,7 @@ module Stack.Prelude
   , liftResourceT
   , NoLogging (..)
   , withSystemTempDir
+  , withKeepSystemTempDir
   , fromFirst
   , mapMaybeA
   , mapMaybeM
@@ -164,6 +165,13 @@ instance MonadLogger NoLogging where
 withSystemTempDir :: MonadUnliftIO m => String -> (Path Abs Dir -> m a) -> m a
 withSystemTempDir str inner = withRunInIO $ \run -> Path.IO.withSystemTempDir str $ run . inner
 
+-- | Like `withSystemTempDir`, but the temporary directory is not deleted.
+withKeepSystemTempDir :: MonadUnliftIO m => String -> (Path Abs Dir -> m a) -> m a
+withKeepSystemTempDir str inner = withRunInIO $ \run -> do
+  path <- Path.IO.getTempDir
+  dir <- Path.IO.createTempDir path str
+  run $ inner dir
+
 -- | Write a "sticky" line to the terminal. Any subsequent lines will
 -- overwrite this one, and that same line will be repeated below
 -- again. In other words, the line sticks at the bottom of the output

src/Stack/Types/Config/Build.hs

@@ -64,6 +64,8 @@ data BuildOpts =
             -- ^ Watch files for changes and automatically rebuild
             ,boptsKeepGoing :: !(Maybe Bool)
             -- ^ Keep building/running after failure
+            ,boptsKeepTmpFiles :: !(Maybe Bool)
+            -- ^ Keep intermediate files and build directories
             ,boptsForceDirty :: !Bool
             -- ^ Force treating all local packages as having dirty files
 
@@ -105,6 +107,7 @@ defaultBuildOpts = BuildOpts
     , boptsInstallCompilerTool = False
     , boptsPreFetch = False
     , boptsKeepGoing = Nothing
+    , boptsKeepTmpFiles = Nothing
     , boptsForceDirty = False
     , boptsTests = False
     , boptsTestOpts = defaultTestOpts
@@ -172,6 +175,7 @@ data BuildOptsMonoid = BuildOptsMonoid
     , buildMonoidInstallCompilerTool :: !(First Bool)
     , buildMonoidPreFetch :: !(First Bool)
     , buildMonoidKeepGoing :: !(First Bool)
+    , buildMonoidKeepTmpFiles :: !(First Bool)
     , buildMonoidForceDirty :: !(First Bool)
     , buildMonoidTests :: !(First Bool)
     , buildMonoidTestOpts :: !TestOptsMonoid
@@ -202,6 +206,7 @@ instance FromJSON (WithJSONWarnings BuildOptsMonoid) where
               buildMonoidInstallCompilerTool <- First <$> o ..:? buildMonoidInstallCompilerToolArgName
               buildMonoidPreFetch <- First <$> o ..:? buildMonoidPreFetchArgName
               buildMonoidKeepGoing <- First <$> o ..:? buildMonoidKeepGoingArgName
+              buildMonoidKeepTmpFiles <- First <$> o ..:? buildMonoidKeepTmpFilesArgName
               buildMonoidForceDirty <- First <$> o ..:? buildMonoidForceDirtyArgName
               buildMonoidTests <- First <$> o ..:? buildMonoidTestsArgName
               buildMonoidTestOpts <- jsonSubWarnings (o ..:? buildMonoidTestOptsArgName ..!= mempty)
@@ -255,6 +260,9 @@ buildMonoidPreFetchArgName = "prefetch"
 buildMonoidKeepGoingArgName :: Text
 buildMonoidKeepGoingArgName = "keep-going"
 
+buildMonoidKeepTmpFilesArgName :: Text
+buildMonoidKeepTmpFilesArgName = "keep-tmp-files"
+
 buildMonoidForceDirtyArgName :: Text
 buildMonoidForceDirtyArgName = "force-dirty"