Merge branch 'better-cleanup'

app/ghcup/BrickMain.hs

@@ -434,6 +434,7 @@ install' _ (_, ListResult {..}) = do
               , NoUpdate
               , TarDirDoesNotExist
               , FileAlreadyExistsError
+              , ProcessError
               ]
 
   run (do

app/ghcup/Main.hs

@@ -1852,6 +1852,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                       , NextVerNotFound
                       , NoToolVersionSet
                       , FileAlreadyExistsError
+                      , ProcessError
                       ]
 
           let runInstTool mInstPlatform action' = do
@@ -1953,6 +1954,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                       , NotInstalled
                       , DirNotEmpty
                       , ArchiveResult
+                      , FileDoesNotExistError
+                      , HadrianNotFound
+                      , InvalidBuildConfig
+                      , ProcessError
+                      , CopyError
+                      , BuildFailed
                       ]
 
           let runCompileHLS =

lib/GHCup.hs

@@ -205,6 +205,7 @@ installGHCBindist :: ( MonadFail m
                         , TarDirDoesNotExist
                         , DirNotEmpty
                         , ArchiveResult
+                        , ProcessError
                         ]
                        m
                        ()
@@ -283,6 +284,7 @@ installPackedGHC :: ( MonadMask m
                        , TarDirDoesNotExist
                        , DirNotEmpty
                        , ArchiveResult
+                       , ProcessError
                        ] m ()
 installPackedGHC dl msubdir inst ver forceInstall = do
   PlatformRequest {..} <- lift getPlatformReq
@@ -292,7 +294,7 @@ installPackedGHC dl msubdir inst ver forceInstall = do
 
   -- unpack
   tmpUnpack <- lift mkGhcupTmpDir
-  liftE $ unpackToDir tmpUnpack dl
+  liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
   liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
 
   -- the subdir of the archive where we do the work
@@ -402,12 +404,13 @@ installGHCBin :: ( MonadFail m
                     , TarDirDoesNotExist
                     , DirNotEmpty
                     , ArchiveResult
+                    , ProcessError
                     ]
                    m
                    ()
 installGHCBin ver isoFilepath forceInstall = do
   dlinfo <- liftE $ getDownloadInfo GHC ver
-  installGHCBindist dlinfo ver isoFilepath forceInstall
+  liftE $ installGHCBindist dlinfo ver isoFilepath forceInstall
 
 
 -- | Like 'installCabalBin', except takes the 'DownloadInfo' as
@@ -472,7 +475,7 @@ installCabalBindist dlinfo ver isoFilepath forceInstall = do
 
   -- unpack
   tmpUnpack <- lift withGHCupTmpDir
-  liftE $ unpackToDir tmpUnpack dl
+  liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
   liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
 
   -- the subdir of the archive where we do the work
@@ -614,7 +617,7 @@ installHLSBindist dlinfo ver isoFilepath forceInstall = do
 
   -- unpack
   tmpUnpack <- lift withGHCupTmpDir
-  liftE $ unpackToDir tmpUnpack dl
+  liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
   liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
 
   -- the subdir of the archive where we do the work
@@ -784,7 +787,7 @@ compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patc
 
       -- unpack
       tmpUnpack <- lift mkGhcupTmpDir
-      liftE $ unpackToDir tmpUnpack dl
+      liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
       liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
 
       workdir <- maybe (pure tmpUnpack)
@@ -1001,7 +1004,7 @@ installStackBindist dlinfo ver isoFilepath forceInstall = do
 
   -- unpack
   tmpUnpack <- lift withGHCupTmpDir
-  liftE $ unpackToDir tmpUnpack dl
+  liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
   liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
 
   -- the subdir of the archive where we do the work
@@ -2114,6 +2117,12 @@ compileGHC :: ( MonadMask m
                  , NotInstalled
                  , DirNotEmpty
                  , ArchiveResult
+                 , FileDoesNotExistError
+                 , HadrianNotFound
+                 , InvalidBuildConfig
+                 , ProcessError
+                 , CopyError
+                 , BuildFailed
                  ]
                 m
                 GHCTargetVersion
@@ -2135,7 +2144,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
 
         -- unpack
         tmpUnpack <- lift mkGhcupTmpDir
-        liftE $ unpackToDir tmpUnpack dl
+        liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
         liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
 
         workdir <- maybe (pure tmpUnpack)

lib/GHCup/Utils.hs

@@ -74,7 +74,6 @@ import           System.Win32.Console
 import           System.Win32.File     hiding ( copyFile )
 import           System.Win32.Types
 #endif
-import           Text.PrettyPrint.HughesPJClass hiding ( (<>) )
 import           Text.Regex.Posix
 import           URI.ByteString
 
@@ -926,11 +925,7 @@ getChangeLog dls tool (Right tag) =
 --
 --   1. the build directory, depending on the KeepDirs setting
 --   2. the install destination, depending on whether the build failed
-runBuildAction :: ( Pretty (V e)
-                  , Show (V e)
-                  , PopVariant BuildFailed e
-                  , ToVariantMaybe BuildFailed e
-                  , MonadReader env m
+runBuildAction :: ( MonadReader env m
                   , HasDirs env
                   , HasSettings env
                   , MonadIO m
@@ -943,26 +938,43 @@ runBuildAction :: ( Pretty (V e)
                => FilePath        -- ^ build directory (cleaned up depending on Settings)
                -> Maybe FilePath  -- ^ dir to *always* clean up on exception
                -> Excepts e m a
-               -> Excepts '[BuildFailed] m a
+               -> Excepts e m a
 runBuildAction bdir instdir action = do
   Settings {..} <- lift getSettings
   let exAction = do
         forM_ instdir $ \dir ->
-          lift $ hideError doesNotExistErrorType $ recyclePathForcibly dir
+          hideError doesNotExistErrorType $ recyclePathForcibly dir
         when (keepDirs == Never)
-          $ lift $ rmBDir bdir
+          $ rmBDir bdir
   v <-
-    flip onException exAction
-    $ catchAllE
-        (\es -> do
-          exAction
-          throwE (BuildFailed bdir es)
-        ) action
-
+    flip onException (lift exAction)
+    $ onE_ exAction action
   when (keepDirs == Never || keepDirs == Errors) $ lift $ rmBDir bdir
   pure v
 
 
+-- | Clean up the given directory if the action fails,
+-- depending on the Settings.
+cleanUpOnError :: ( MonadReader env m
+                  , HasDirs env
+                  , HasSettings env
+                  , MonadIO m
+                  , MonadMask m
+                  , HasLog env
+                  , MonadUnliftIO m
+                  , MonadFail m
+                  , MonadCatch m
+                  )
+               => FilePath        -- ^ build directory (cleaned up depending on Settings)
+               -> Excepts e m a
+               -> Excepts e m a
+cleanUpOnError bdir action = do
+  Settings {..} <- lift getSettings
+  let exAction = when (keepDirs == Never) $ rmBDir bdir
+  flip onException (lift exAction) $ onE_ exAction action
+
+
+
 -- | Remove a build directory, ignoring if it doesn't exist and gracefully
 -- printing other errors without crashing.
 rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => FilePath -> m ()