Implement ghcup gc command

Fixes #241

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 <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                       , FileDoesNotExistError
                       ]
 
+          let runGC =
+                  runAppState
+                  . runResourceT
+                  . runE
+                    @'[ NotInstalled
+                      ]
+
 
           -----------------------
           -- Command functions --
@@ -2698,6 +2751,20 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                             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

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
 
@@ -512,7 +510,7 @@ installCabalUnpacked path inst mver' forceInstall = do
   unless forceInstall          -- Overwrite it when it IS a force install
     (liftE $ throwIfFileAlreadyExists destPath)
     
-  handleIO (throwE . CopyError . show) $ liftIO $ copyFile
+  copyFileE
     (path </> cabalFile <> exeExt)
     destPath
   lift $ chmod_755 destPath
@@ -662,7 +660,7 @@ installHLSUnpacked path inst mver' forceInstall = do
     unless forceInstall   -- if it is a force install, overwrite it.
       (liftE $ throwIfFileAlreadyExists destPath)
       
-    handleIO (throwE . CopyError . show) $ liftIO $ copyFile
+    copyFileE
       srcPath
       destPath
     lift $ chmod_755 destPath
@@ -678,7 +676,7 @@ installHLSUnpacked path inst mver' forceInstall = do
   unless forceInstall
     (liftE $ throwIfFileAlreadyExists destWrapperPath)
       
-  handleIO (throwE . CopyError . show) $ liftIO $ copyFile
+  copyFileE
     srcWrapperPath
     destWrapperPath
     
@@ -850,35 +848,37 @@ compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patc
       cp <- case cabalProject of
         Just cp
           | isAbsolute cp -> do
-              handleIO (throwE . CopyError . show) $ liftIO $ copyFile cp (workdir </> "cabal.project")
+              copyFileE cp (workdir </> "cabal.project")
               pure "cabal.project"
           | otherwise -> pure (takeFileName cp)
         Nothing -> pure "cabal.project"
-      forM_ cabalProjectLocal $ \cpl -> handleIO (throwE . CopyError . show) $ liftIO $ copyFile cpl (workdir </> cp <.> "local")
+      forM_ cabalProjectLocal $ \cpl -> copyFileE cpl (workdir </> cp <.> "local")
+
+      let targets = ["exe:haskell-language-server", "exe:haskell-language-server-wrapper"]
 
       artifacts <- forM (sort ghcs) $ \ghc -> do
         let ghcInstallDir = installDir </> T.unpack (prettyVer ghc)
-        liftIO $ createDirRecursive' installDir
+        liftIO $ createDirRecursive' ghcInstallDir
         lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc
         liftE $ lEM @_ @'[ProcessError] $
-          execLogged "cabal" ( [ "v2-install"
+          execLogged "cabal" ( [ "v2-build"
                                , "-w"
                                , "ghc-" <> T.unpack (prettyVer ghc)
-                               , "--install-method=copy"
                                ] ++
                                maybe [] (\j -> ["--jobs=" <> show j]) jobs ++
-                               [ "--overwrite-policy=always"
+                               [ "--project-file=" <> cp
-                               , "--disable-profiling"
+                               ] ++ targets
-                               , "--disable-tests"
-                               , "--enable-split-sections"
-                               , "--enable-executable-stripping"
-                               , "--enable-executable-static"
-                               , "--installdir=" <> ghcInstallDir
-                               , "--project-file=" <> cp
-                               , "exe:haskell-language-server"
-                               , "exe:haskell-language-server-wrapper"]
                              )
           (Just workdir) "cabal" Nothing
+        forM_ targets $ \target -> do
+          let cabal = "cabal"
+              args = ["list-bin", target]
+          CapturedProcess{..} <- lift $ executeOut cabal args  (Just workdir) 
+          case _exitCode of
+            ExitFailure i -> throwE (NonZeroExit i cabal args)
+            _ -> pure ()
+          let cbin = stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut
+          copyFileE cbin (ghcInstallDir </> takeFileName cbin)
         pure ghcInstallDir
 
       forM_ artifacts $ \artifact -> do
@@ -1039,7 +1039,7 @@ installStackUnpacked path inst mver' forceInstall = do
   unless forceInstall
     (liftE $ throwIfFileAlreadyExists destPath)
       
-  handleIO (throwE . CopyError . show) $ liftIO $ copyFile
+  copyFileE
     (path </> stackFile <> exeExt)
     destPath
   lift $ chmod_755 destPath
@@ -1228,7 +1228,7 @@ setHLS ver = do
     lift $ rmLink (binDir </> f)
 
   -- set haskell-language-server-<ghcver> symlinks
-  bins <- lift $ hlsServerBinaries ver
+  bins <- lift $ hlsServerBinaries ver Nothing
   when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver)
 
   forM_ bins $ \f -> do
@@ -2410,7 +2410,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
                             <> ".tar"
                             <> takeExtension tar)
     let tarPath = cacheDir </> tarName
-    handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar)
+    copyFileE (workdir </> tar)
                                                              tarPath
     lift $ logInfo $ "Copied bindist to " <> T.pack tarPath
     pure tarPath
@@ -2578,7 +2578,7 @@ upgradeGHCup mtarget force' = do
   lift $ logDebug $ "rm -f " <> T.pack destFile
   lift $ hideError NoSuchThing $ recycleFile destFile
   lift $ logDebug $ "cp " <> T.pack p <> " " <> T.pack destFile
-  handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
+  copyFileE p
                                                            destFile
   lift $ chmod_755 destFile
 
@@ -2703,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

lib/GHCup/Utils.hs

@@ -492,33 +492,50 @@ hlsGHCVersions :: ( MonadReader env m
                   )
                => m [Version]
 hlsGHCVersions = do
-  h                             <- hlsSet
+  h <- hlsSet
-  vers                          <- forM h $ \h' -> do
+  fromMaybe [] <$> forM h hlsGHCVersions'
-    bins <- hlsServerBinaries h'
+
-    pure $ fmap
+
-      (version
+hlsGHCVersions' :: ( MonadReader env m
-        . T.pack
+                   , HasDirs env
-        . fromJust
+                   , MonadIO m
-        . stripPrefix "haskell-language-server-"
+                   , MonadThrow m
-        . head
+                   , MonadCatch m
-        . splitOn "~"
+                   )
-        )
+                => Version
-      bins
+                -> m [Version]
-  pure . sortBy (flip compare) . rights . concat . maybeToList $ vers
+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 . Map.filter (\VersionInfo {..} -> tag `elem` _viTags))
-  % to Map.toDescList
+  % folding id
-  % _head
 
 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:

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

lib/GHCup/Utils/Prelude.hs

@@ -33,7 +33,7 @@ import           Control.Monad.IO.Class
 import           Control.Monad.Reader
 import           Data.Bifunctor
 import           Data.ByteString                ( ByteString )
-import           Data.List                      ( nub, intercalate, stripPrefix, isPrefixOf )
+import           Data.List                      ( nub, intercalate, stripPrefix, isPrefixOf, dropWhileEnd )
 import           Data.Maybe
 import           Data.Foldable
 import           Data.List.NonEmpty             ( NonEmpty( (:|) ))
@@ -528,6 +528,10 @@ recover action =
 #endif
 
 
+copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Excepts xs m ()
+copyFileE from = handleIO (throwE . CopyError . show) . liftIO . copyFile from
+
+
 -- | Gathering monoidal values
 --
 -- >>> traverseFold (pure . (:["0"])) ["1","2"]
@@ -548,6 +552,8 @@ forFold = \t -> (`traverseFold` t)
 --
 -- >>> stripNewline "foo\n\n\n"
 -- "foo"
+-- >>> stripNewline "foo\n\n\nfoo"
+-- "foofoo"
 -- >>> stripNewline "foo\r"
 -- "foo"
 -- >>> stripNewline "foo"
@@ -559,10 +565,29 @@ stripNewline :: String -> String
 stripNewline = filter (`notElem` "\n\r")
 
 
+-- | Strip @\\r@ and @\\n@ from end of 'String'.
+--
+-- >>> stripNewlineEnd "foo\n\n\n"
+-- "foo"
+-- >>> stripNewlineEnd "foo\n\n\nfoo"
+-- "foo\n\n\nfoo"
+-- >>> stripNewlineEnd "foo\r"
+-- "foo"
+-- >>> stripNewlineEnd "foo"
+-- "foo"
+--
+-- prop> \t -> stripNewlineEnd (t <> "\n") === stripNewlineEnd t
+-- prop> \t -> not (any (isNewLine . c2w) t) ==> stripNewlineEnd t == t
+stripNewlineEnd :: String -> String
+stripNewlineEnd = dropWhileEnd (`elem` "\n\r")
+
+
 -- | Strip @\\r@ and @\\n@ from 'Text's
 --
 -- >>> stripNewline' "foo\n\n\n"
 -- "foo"
+-- >>> stripNewline' "foo\n\n\nfoo"
+-- "foofoo"
 -- >>> stripNewline' "foo\r"
 -- "foo"
 -- >>> stripNewline' "foo"