hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Improve rmHLSNoGHC

Browse Source
This commit is contained in:
Julian Ospald 2022-02-05 19:12:13 +01:00
parent 6831337289
commit 6b978b42bc
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
2 changed files with 17 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
app/ghcup/GHCup/OptParse/GC.hs
View File

@ -132,7 +132,7 @@ gc GCOptions{..} runAppState runLogger = runGC runAppState (do
when gcOldGHC rmOldGHC when gcOldGHC rmOldGHC
lift $ when gcProfilingLibs rmProfilingLibs lift $ when gcProfilingLibs rmProfilingLibs
lift $ when gcShareDir rmShareDir lift $ when gcShareDir rmShareDir
lift $ when gcHLSNoGHC rmHLSNoGHC liftE $ when gcHLSNoGHC rmHLSNoGHC
lift $ when gcCache rmCache lift $ when gcCache rmCache
lift $ when gcTmp rmTmp lift $ when gcTmp rmTmp
) >>= \case ) >>= \case

22
lib/GHCup.hs
View File

@ -2836,21 +2836,31 @@ rmHLSNoGHC :: ( MonadReader env m
, HasLog env , HasLog env
, MonadIO m , MonadIO m
, MonadMask m , MonadMask m
, MonadFail m
, MonadUnliftIO m
) )
=> m () => Excepts '[NotInstalled] m ()
rmHLSNoGHC = do rmHLSNoGHC = do
Dirs {..} <- getDirs Dirs {..} <- getDirs
ghcs <- fmap rights getInstalledGHCs ghcs <- fmap rights getInstalledGHCs
hlses <- fmap rights getInstalledHLSs hlses <- fmap rights getInstalledHLSs
forM_ hlses $ \hls -> do forM_ hlses $ \hls -> do
hlsGHCs <- fmap mkTVer <$> hlsGHCVersions' hls hlsGHCs <- fmap mkTVer <$> hlsGHCVersions' hls
forM_ hlsGHCs $ \ghc -> do let candidates = filter (`notElem` ghcs) $ hlsGHCs
when (ghc `notElem` ghcs) $ do if (length hlsGHCs - length candidates) <= 0
bins <- hlsServerBinaries hls (Just $ _tvVersion ghc) then rmHLSVer hls
forM_ bins $ \bin -> do else
let f = binDir </> bin forM_ candidates $ \ghc -> do
bins1 <- fmap (binDir </>) <$> hlsServerBinaries hls (Just $ _tvVersion ghc)
bins2 <- ifM (isLegacyHLS hls) (pure []) $ do
shs <- hlsInternalServerScripts hls (Just $ _tvVersion ghc)
bins <- hlsInternalServerBinaries hls (Just $ _tvVersion ghc)
libs <- hlsInternalServerLibs hls (_tvVersion ghc)
pure (shs ++ bins ++ libs)
forM_ (bins1 ++ bins2) $ \f -> do
logDebug $ "rm " <> T.pack f logDebug $ "rm " <> T.pack f
rmFile f rmFile f
pure ()
rmCache :: ( MonadReader env m rmCache :: ( MonadReader env m