diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 659d873..2760ebb 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -117,6 +117,7 @@ data Command | Interactive #endif | Prefetch PrefetchCommand + | GC GCOptions data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal | ToolTag Tag @@ -145,6 +146,15 @@ data InstallOptions = InstallOptions , forceInstall :: Bool } +data GCOptions = GCOptions + { gcOldGHC :: Bool + , gcProfilingLibs :: Bool + , gcShareDir :: Bool + , gcHLSNoGHC :: Bool + , gcCache :: Bool + , gcTmp :: Bool + } + data SetCommand = SetGHC SetOptions | SetCabal SetOptions | SetHLS SetOptions @@ -438,6 +448,16 @@ com = (progDesc "Prefetch assets" <> footerDoc ( Just $ text prefetchFooter )) ) + <> command + "gc" + (info + ( (GC + <$> gcP + ) <**> helper + ) + (progDesc "Garbage collection" + <> footerDoc ( Just $ text gcFooter )) + ) <> commandGroup "Main commands:" ) <|> subparser @@ -542,6 +562,10 @@ Examples: ghcup prefetch ghc 8.10.5 ghcup --offline install ghc 8.10.5|] + gcFooter :: String + gcFooter = [s|Discussion: + Performs garbage collection. If no switches are specified, does nothing.|] + configFooter :: String configFooter = [s|Examples: @@ -1122,6 +1146,28 @@ prefetchP = subparser ) ) +gcP :: Parser GCOptions +gcP = + GCOptions + <$> + switch + (short 'o' <> long "ghc-old" <> help "Remove GHC versions marked as 'old'") + <*> + switch + (short 'p' <> long "profiling-libs" <> help "Remove profiling libs of GHC versions") + <*> + switch + (short 's' <> long "share-dir" <> help "Remove GHC share directories (documentation)") + <*> + switch + (short 'h' <> long "hls-no-ghc" <> help "Remove HLS versions that don't have a corresponding installed GHC version") + <*> + switch + (short 'c' <> long "cache" <> help "GC the GHCup cache") + <*> + switch + (short 't' <> long "tmpdirs" <> help "Remove tmpdir leftovers") + ghcCompileOpts :: Parser GHCCompileOptions ghcCompileOpts = @@ -1979,6 +2025,13 @@ Report bugs at |] , FileDoesNotExistError ] + let runGC = + runAppState + . runResourceT + . runE + @'[ NotInstalled + ] + ----------------------- -- Command functions -- @@ -2698,6 +2751,20 @@ Report bugs at |] VLeft e -> do runLogger $ logError $ T.pack $ prettyShow e pure $ ExitFailure 15 + GC GCOptions{..} -> + runGC (do + when gcOldGHC rmOldGHC + lift $ when gcProfilingLibs rmProfilingLibs + lift $ when gcShareDir rmShareDir + lift $ when gcHLSNoGHC rmHLSNoGHC + lift $ when gcCache rmCache + lift $ when gcTmp rmTmp + ) >>= \case + VRight _ -> do + pure ExitSuccess + VLeft e -> do + runLogger $ logError $ T.pack $ prettyShow e + pure $ ExitFailure 27 case res of diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 11a867e..e5b1e8b 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -83,9 +83,7 @@ import System.Directory hiding ( findFiles ) import System.Environment import System.FilePath import System.IO.Error -#if defined(IS_WINDOWS) import System.IO.Temp -#endif import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.Regex.Posix @@ -1230,7 +1228,7 @@ setHLS ver = do lift $ rmLink (binDir f) -- set haskell-language-server- symlinks - bins <- lift $ hlsServerBinaries ver + bins <- lift $ hlsServerBinaries ver Nothing when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver) forM_ bins $ \f -> do @@ -2705,3 +2703,134 @@ throwIfFileAlreadyExists :: ( MonadIO m ) => throwIfFileAlreadyExists fp = whenM (checkFileAlreadyExists fp) (throwE $ FileAlreadyExistsError fp) + + + -------------------------- + --[ Garbage collection ]-- + -------------------------- + + +rmOldGHC :: ( MonadReader env m + , HasGHCupInfo env + , HasDirs env + , HasLog env + , MonadIO m + , MonadFail m + , MonadMask m + , MonadUnliftIO m + ) + => Excepts '[NotInstalled] m () +rmOldGHC = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + let oldGHCs = mkTVer <$> toListOf (ix GHC % getTagged Old % to fst) dls + ghcs <- lift $ fmap rights getInstalledGHCs + forM_ ghcs $ \ghc -> when (ghc `elem` oldGHCs) $ rmGHCVer ghc + + + +rmProfilingLibs :: ( MonadReader env m + , HasDirs env + , HasLog env + , MonadIO m + , MonadFail m + , MonadMask m + , MonadUnliftIO m + ) + => m () +rmProfilingLibs = do + ghcs <- fmap rights getInstalledGHCs + + let regexes :: [ByteString] + regexes = [[s|.*_p\.a$|], [s|.*\.p_hi$|]] + + forM_ regexes $ \regex -> + forM_ ghcs $ \ghc -> do + d <- ghcupGHCDir ghc + matches <- liftIO $ handleIO (\_ -> pure []) $ findFilesDeep + d + (makeRegexOpts compExtended + execBlank + regex + ) + forM_ matches $ \m -> do + let p = d m + logDebug $ "rm " <> T.pack p + rmFile p + + + +rmShareDir :: ( MonadReader env m + , HasDirs env + , HasLog env + , MonadIO m + , MonadFail m + , MonadMask m + , MonadUnliftIO m + ) + => m () +rmShareDir = do + ghcs <- fmap rights getInstalledGHCs + forM_ ghcs $ \ghc -> do + d <- ghcupGHCDir ghc + let p = d "share" + logDebug $ "rm -rf " <> T.pack p + rmPathForcibly p + + +rmHLSNoGHC :: ( MonadReader env m + , HasDirs env + , HasLog env + , MonadIO m + , MonadMask m + ) + => m () +rmHLSNoGHC = do + Dirs {..} <- getDirs + ghcs <- fmap rights getInstalledGHCs + hlses <- fmap rights getInstalledHLSs + forM_ hlses $ \hls -> do + hlsGHCs <- fmap mkTVer <$> hlsGHCVersions' hls + forM_ hlsGHCs $ \ghc -> do + when (ghc `notElem` ghcs) $ do + bins <- hlsServerBinaries hls (Just $ _tvVersion ghc) + forM_ bins $ \bin -> do + let f = binDir bin + logDebug $ "rm " <> T.pack f + rmFile f + + +rmCache :: ( MonadReader env m + , HasDirs env + , HasLog env + , MonadIO m + , MonadMask m + ) + => m () +rmCache = do + Dirs {..} <- getDirs + contents <- liftIO $ listDirectory cacheDir + forM_ contents $ \f -> do + let p = cacheDir f + logDebug $ "rm " <> T.pack p + rmFile p + + +rmTmp :: ( MonadReader env m + , HasDirs env + , HasLog env + , MonadIO m + , MonadMask m + ) + => m () +rmTmp = do + tmpdir <- liftIO getCanonicalTemporaryDirectory + ghcup_dirs <- liftIO $ handleIO (\_ -> pure []) $ findFiles + tmpdir + (makeRegexOpts compExtended + execBlank + ([s|^ghcup-.*$|] :: ByteString) + ) + forM_ ghcup_dirs $ \f -> do + let p = tmpdir f + logDebug $ "rm -rf " <> T.pack p + rmPathForcibly p diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 57160c1..c106e2f 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -492,33 +492,50 @@ hlsGHCVersions :: ( MonadReader env m ) => m [Version] hlsGHCVersions = do - h <- hlsSet - vers <- forM h $ \h' -> do - bins <- hlsServerBinaries h' - pure $ fmap - (version - . T.pack - . fromJust - . stripPrefix "haskell-language-server-" - . head - . splitOn "~" - ) - bins - pure . sortBy (flip compare) . rights . concat . maybeToList $ vers + h <- hlsSet + fromMaybe [] <$> forM h hlsGHCVersions' + + +hlsGHCVersions' :: ( MonadReader env m + , HasDirs env + , MonadIO m + , MonadThrow m + , MonadCatch m + ) + => Version + -> m [Version] +hlsGHCVersions' v' = do + bins <- hlsServerBinaries v' Nothing + let vers = fmap + (version + . T.pack + . fromJust + . stripPrefix "haskell-language-server-" + . head + . splitOn "~" + ) + bins + pure . sortBy (flip compare) . rights $ vers -- | Get all server binaries for an hls version, if any. hlsServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m) => Version + -> Maybe Version -- ^ optional GHC version -> m [FilePath] -hlsServerBinaries ver = do +hlsServerBinaries ver mghcVer = do Dirs {..} <- getDirs liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts compExtended execBlank - ([s|^haskell-language-server-.*~|] <> escapeVerRex ver <> E.encodeUtf8 (T.pack exeExt) <> [s|$|] :: ByteString + ([s|^haskell-language-server-|] + <> maybe [s|.*|] escapeVerRex mghcVer + <> [s|~|] + <> escapeVerRex ver + <> E.encodeUtf8 (T.pack exeExt) + <> [s|$|] :: ByteString ) ) @@ -547,7 +564,7 @@ hlsWrapperBinary ver = do -- | Get all binaries for an hls version, if any. hlsAllBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => Version -> m [FilePath] hlsAllBinaries ver = do - hls <- hlsServerBinaries ver + hls <- hlsServerBinaries ver Nothing wrapper <- hlsWrapperBinary ver pure (maybeToList wrapper ++ hls) @@ -768,11 +785,10 @@ intoSubdir bdir tardir = case tardir of -- | Get the tool version that has this tag. If multiple have it, -- picks the greatest version. getTagged :: Tag - -> AffineFold (Map.Map Version VersionInfo) (Version, VersionInfo) + -> Fold (Map.Map Version VersionInfo) (Version, VersionInfo) getTagged tag = - to (Map.filter (\VersionInfo {..} -> tag `elem` _viTags)) - % to Map.toDescList - % _head + to (Map.toDescList . Map.filter (\VersionInfo {..} -> tag `elem` _viTags)) + % folding id getLatest :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo) getLatest av tool = headOf (ix tool % getTagged Latest) av @@ -903,7 +919,7 @@ getChangeLog :: GHCupDownloads -> Tool -> Either Version Tag -> Maybe URI getChangeLog dls tool (Left v') = preview (ix tool % ix v' % viChangeLog % _Just) dls getChangeLog dls tool (Right tag) = - preview (ix tool % getTagged tag % to snd % viChangeLog % _Just) dls + preview (ix tool % pre (getTagged tag) % to snd % viChangeLog % _Just) dls -- | Execute a build action while potentially cleaning up: diff --git a/lib/GHCup/Utils/File/Common.hs b/lib/GHCup/Utils/File/Common.hs index 00c86f6..23ba8af 100644 --- a/lib/GHCup/Utils/File/Common.hs +++ b/lib/GHCup/Utils/File/Common.hs @@ -105,6 +105,11 @@ findFiles path regex = do contents <- listDirectory path pure $ filter (match regex) contents +findFilesDeep :: FilePath -> Regex -> IO [FilePath] +findFilesDeep path regex = do + contents <- getDirectoryContentsRecursive path + pure $ filter (match regex) contents + findFiles' :: FilePath -> MP.Parsec Void Text a -> IO [FilePath] findFiles' path parser = do contents <- listDirectory path diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs index ecc2888..764a9e9 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Utils/Prelude.hs @@ -25,7 +25,6 @@ import GHCup.Types import GHCup.Errors import GHCup.Types.Optics import {-# SOURCE #-} GHCup.Utils.Logger -import GHCup.Errors import Control.Applicative import Control.Exception.Safe