Implement --keep

app/ghcup-gen/Validate.hs

@@ -175,7 +175,7 @@ validateTarballs dls = do
 
  where
   downloadAll dli = do
-    let settings = Settings True False
+    let settings = Settings True False Never
     let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
                                            , colorOutter  = B.hPut stderr
                                            , rawOutter    = (\_ -> pure ())

app/ghcup/Main.hs

@@ -74,6 +74,7 @@ data Options = Options
   , optCache     :: Bool
   , optUrlSource :: Maybe URI
   , optNoVerify  :: Bool
+  , optKeepDirs  :: KeepDirs
   -- commands
   , optCommand   :: Command
   }
@@ -164,6 +165,14 @@ opts =
           (short 'n' <> long "no-verify" <> help
             "Skip tarball checksum verification"
           )
+    <*> option
+          (eitherReader keepOnParser)
+          (  long "keep"
+          <> metavar "<always|errors|never>"
+          <> help
+               "Keep build directories?"
+          <> value Never
+          )
     <*> com
  where
   parseUri s' =
@@ -507,6 +516,14 @@ criteriaParser s' | t == T.pack "installed" = Right ListInstalled
   where t = T.toLower (T.pack s')
 
 
+keepOnParser :: String -> Either String KeepDirs
+keepOnParser s' | t == T.pack "always" = Right Always
+                | t == T.pack "errors" = Right Errors
+                | t == T.pack "never"  = Right Never
+                | otherwise            = Left ("Unknown keep value: " <> s')
+  where t = T.toLower (T.pack s')
+
+
 platformParser :: String -> Either String PlatformRequest
 platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
   Right r -> pure r
@@ -584,6 +601,7 @@ toSettings :: Options -> Settings
 toSettings Options {..} =
   let cache    = optCache
       noVerify = optNoVerify
+      keepDirs = optKeepDirs
   in  Settings { .. }
 
 
@@ -654,7 +672,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
             (footerDoc (Just $ text main_footer))
       )
     >>= \opt@Options {..} -> do
-          let settings = toSettings opt
+          let settings@Settings{..} = toSettings opt
 
           -- create ~/.ghcup dir
           ghcdir <- ghcupBaseDir
@@ -792,10 +810,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                           [i|GHC ver #{prettyVer v} already installed|]
                         pure ExitSuccess
                       VLeft (V (BuildFailed tmpdir e)) -> do
-                        runLogger
+                        case keepDirs of
-                          ($(logError) [i|Build failed with #{e}
+                          Never -> runLogger ($(logError) [i|Build failed with #{e}|])
-Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.|]
+                          _ -> runLogger ($(logError) [i|Build failed with #{e}
-                          )
+Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.
+Make sure to clean up #{tmpdir} afterwards.|])
                         pure $ ExitFailure 3
                       VLeft (V NoDownload) -> do
 
@@ -902,11 +921,11 @@ Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues
                           [i|GHC ver #{prettyVer v} already installed|]
                         pure ExitSuccess
                       VLeft (V (BuildFailed tmpdir e)) -> do
-                        runLogger
+                        case keepDirs of
-                          ($(logError) [i|Build failed with #{e}
+                          Never -> runLogger ($(logError) [i|Build failed with #{e}|])
+                          _ -> runLogger ($(logError) [i|Build failed with #{e}
 Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.
-Make sure to clean up #{tmpdir} afterwards.|]
+Make sure to clean up #{tmpdir} afterwards.|])
-                          )
                         pure $ ExitFailure 9
                       VLeft e -> do
                         runLogger ($(logError) [i|#{e}|])
@@ -924,10 +943,11 @@ Make sure to clean up #{tmpdir} afterwards.|]
                           )
                         pure ExitSuccess
                       VLeft (V (BuildFailed tmpdir e)) -> do
-                        runLogger
+                        case keepDirs of
-                          ($(logError) [i|Build failed with #{e}
+                          Never -> runLogger ($(logError) [i|Build failed with #{e}|])
-Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.|]
+                          _ -> runLogger ($(logError) [i|Build failed with #{e}
-                          )
+Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.
+Make sure to clean up #{tmpdir} afterwards.|])
                         pure $ ExitFailure 10
                       VLeft e -> do
                         runLogger ($(logError) [i|#{e}|])

lib/GHCup.hs

@@ -97,15 +97,15 @@ installGHCBin bDls ver mpfReq = do
   lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
   whenM (liftIO $ toolAlreadyInstalled GHC ver)
     $ (throwE $ AlreadyInstalled GHC ver)
-  Settings {..} <- lift ask
+  Settings {..}                <- lift ask
   pfreq@(PlatformRequest {..}) <- maybe (liftE $ platformRequest) pure mpfReq
 
   -- download (or use cached version)
-  dlinfo        <- lE $ getDownloadInfo GHC ver pfreq bDls
+  dlinfo                       <- lE $ getDownloadInfo GHC ver pfreq bDls
-  dl            <- liftE $ downloadCached dlinfo Nothing
+  dl                           <- liftE $ downloadCached dlinfo Nothing
 
   -- unpack
-  tmpUnpack     <- lift mkGhcupTmpDir
+  tmpUnpack                    <- lift mkGhcupTmpDir
   liftE $ unpackToDir tmpUnpack dl
   void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
 
@@ -115,19 +115,7 @@ installGHCBin bDls ver mpfReq = do
   -- the subdir of the archive where we do the work
   let workdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
 
-  -- Be careful about cleanup. We must catch both pure exceptions
+  liftE $ runBuildAction tmpUnpack (Just ghcdir) (installGHC' workdir ghcdir)
-  -- as well as async ones.
-  flip onException
-       (liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
-    $ catchAllE
-        (\es -> do
-          liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
-            >> throwE (BuildFailed workdir es)
-        )
-    $ installGHC' workdir ghcdir
-
-  -- only clean up dir if the build succeeded
-  liftIO $ deleteDirRecursive tmpUnpack
 
   liftE $ postGHCInstall ver
 
@@ -533,20 +521,10 @@ compileGHC dls tver bstrap jobs mbuildConfig patchdir = do
   let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
   ghcdir <- liftIO $ ghcupGHCDir tver
 
-  -- Be careful about cleanup. We must catch both pure exceptions
+  liftE $ runBuildAction
-  -- as well as async ones.
+    tmpUnpack
-  flip onException
+    (Just ghcdir)
-       (liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
+    (compile bghc ghcdir workdir >> markSrcBuilt ghcdir workdir)
-    $ catchAllE
-        (\es ->
-          liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
-            >> throwE (BuildFailed workdir es)
-        )
-    $ compile bghc ghcdir workdir
-  markSrcBuilt ghcdir workdir
-
-  -- only clean up dir if the build succeeded
-  liftIO $ deleteDirRecursive tmpUnpack
 
   reThrowAll GHCupSetError $ postGHCInstall tver
   pure ()
@@ -666,7 +644,11 @@ compileCabal dls tver bghc jobs patchdir = do
 
   let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
 
-  reThrowAll (BuildFailed workdir) $ compile workdir
+
+  liftE $ runBuildAction
+    tmpUnpack
+    Nothing
+    (compile workdir)
 
   -- only clean up dir if the build succeeded
   liftIO $ deleteDirRecursive tmpUnpack

lib/GHCup/Types.hs

@@ -142,10 +142,17 @@ data URLSource = GHCupURL
 data Settings = Settings
   { cache    :: Bool
   , noVerify :: Bool
+  , keepDirs :: KeepDirs
   }
   deriving Show
 
 
+data KeepDirs = Always
+              | Errors
+              | Never
+  deriving (Eq, Show, Ord)
+
+
 data DebugInfo = DebugInfo
   { diBaseDir  :: Path Abs
   , diBinDir   :: Path Abs

lib/GHCup/Utils.hs

@@ -406,3 +406,40 @@ getChangeLog dls tool (Right tag) = preview
   % viChangeLog
   % _Just
   ) dls
+
+
+-- | Execute a build action while potentially cleaning up:
+--
+--   1. the build directory, depending on the KeepDirs setting
+--   2. the install destination, depending on whether the build failed
+runBuildAction :: (Show (V e), MonadReader Settings m, MonadIO m, MonadMask m)
+               => Path Abs          -- ^ build directory
+               -> Maybe (Path Abs)  -- ^ install location (e.g. for GHC)
+               -> Excepts e m ()
+               -> Excepts '[BuildFailed] m ()
+runBuildAction bdir instdir action = do
+  Settings {..} <- lift ask
+  flip
+      onException
+      (do
+        forM_ instdir $ \dir ->
+          liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir
+        when (keepDirs == Never)
+          $ liftIO
+          $ hideError doesNotExistErrorType
+          $ deleteDirRecursive bdir
+      )
+    $ catchAllE
+        (\es -> do
+          forM_ instdir $ \dir ->
+            liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir
+          when (keepDirs == Never)
+            $ liftIO
+            $ hideError doesNotExistErrorType
+            $ deleteDirRecursive bdir
+          throwE (BuildFailed bdir es)
+        )
+    $ action
+
+  when (keepDirs == Never || keepDirs == Errors) $ liftIO $ deleteDirRecursive
+    bdir