Merge remote-tracking branch 'origin/issue-1004'
This commit is contained in:
commit
4314146247
@ -908,7 +908,7 @@ compileGHC targetGhc crossTarget vps bstrap jobs mbuildConfig patches aargs buil
|
||||
GitDist GitBranch{..} -> do
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing
|
||||
(tver, ov) <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, ContentLengthError, DownloadFailed, GPGError] DownloadFailed $ do
|
||||
(tver, ov) <- cleanUpOnError tmpUnpack $ reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, ContentLengthError, DownloadFailed, GPGError] DownloadFailed $ do
|
||||
let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo
|
||||
lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
|
||||
lEM $ git [ "init" ]
|
||||
|
@ -437,7 +437,7 @@ compileHLS targetHLS ghcs jobs vps installDir cabalProject cabalProjectLocal upd
|
||||
GitDist GitBranch{..} -> do
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing
|
||||
reThrowAll @_ @'[ProcessError] DownloadFailed $ do
|
||||
cleanUpOnError tmpUnpack $ reThrowAll @_ @'[ProcessError] DownloadFailed $ do
|
||||
let rep = fromMaybe "https://github.com/haskell/haskell-language-server.git" repo
|
||||
lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
|
||||
lEM $ git [ "init" ]
|
||||
|
@ -1084,27 +1084,6 @@ cleanUpOnError bdir action = do
|
||||
flip onException (lift exAction) $ onE_ exAction action
|
||||
|
||||
|
||||
-- | Clean up the given directory if the action fails,
|
||||
-- depending on the Settings.
|
||||
cleanFinally :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadIO m
|
||||
, MonadMask m
|
||||
, HasLog env
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> GHCupPath -- ^ build directory (cleaned up depending on Settings)
|
||||
-> Excepts e m a
|
||||
-> Excepts e m a
|
||||
cleanFinally bdir action = do
|
||||
Settings {..} <- lift getSettings
|
||||
let exAction = when (keepDirs == Never) $ rmBDir bdir
|
||||
flip finally (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) => GHCupPath -> m ()
|
||||
|
Loading…
Reference in New Issue
Block a user