Merge branch 'issue-241'

This commit is contained in:
Julian Ospald 2021-09-25 22:44:59 +02:00
commit bedfb3d114
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
5 changed files with 241 additions and 25 deletions

View File

@ -117,6 +117,7 @@ data Command
| Interactive | Interactive
#endif #endif
| Prefetch PrefetchCommand | Prefetch PrefetchCommand
| GC GCOptions
data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal
| ToolTag Tag | ToolTag Tag
@ -145,6 +146,15 @@ data InstallOptions = InstallOptions
, forceInstall :: Bool , forceInstall :: Bool
} }
data GCOptions = GCOptions
{ gcOldGHC :: Bool
, gcProfilingLibs :: Bool
, gcShareDir :: Bool
, gcHLSNoGHC :: Bool
, gcCache :: Bool
, gcTmp :: Bool
}
data SetCommand = SetGHC SetOptions data SetCommand = SetGHC SetOptions
| SetCabal SetOptions | SetCabal SetOptions
| SetHLS SetOptions | SetHLS SetOptions
@ -438,6 +448,16 @@ com =
(progDesc "Prefetch assets" (progDesc "Prefetch assets"
<> footerDoc ( Just $ text prefetchFooter )) <> footerDoc ( Just $ text prefetchFooter ))
) )
<> command
"gc"
(info
( (GC
<$> gcP
) <**> helper
)
(progDesc "Garbage collection"
<> footerDoc ( Just $ text gcFooter ))
)
<> commandGroup "Main commands:" <> commandGroup "Main commands:"
) )
<|> subparser <|> subparser
@ -542,6 +562,10 @@ Examples:
ghcup prefetch ghc 8.10.5 ghcup prefetch ghc 8.10.5
ghcup --offline install 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 :: String
configFooter = [s|Examples: 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 :: Parser GHCCompileOptions
ghcCompileOpts = ghcCompileOpts =
@ -1979,6 +2025,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, FileDoesNotExistError , FileDoesNotExistError
] ]
let runGC =
runAppState
. runResourceT
. runE
@'[ NotInstalled
]
----------------------- -----------------------
-- Command functions -- -- Command functions --
@ -2698,6 +2751,20 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VLeft e -> do VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15 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 case res of

View File

@ -83,9 +83,7 @@ import System.Directory hiding ( findFiles )
import System.Environment import System.Environment
import System.FilePath import System.FilePath
import System.IO.Error import System.IO.Error
#if defined(IS_WINDOWS)
import System.IO.Temp import System.IO.Temp
#endif
import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix import Text.Regex.Posix
@ -1230,7 +1228,7 @@ setHLS ver = do
lift $ rmLink (binDir </> f) lift $ rmLink (binDir </> f)
-- set haskell-language-server-<ghcver> symlinks -- set haskell-language-server-<ghcver> symlinks
bins <- lift $ hlsServerBinaries ver bins <- lift $ hlsServerBinaries ver Nothing
when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver) when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver)
forM_ bins $ \f -> do forM_ bins $ \f -> do
@ -2705,3 +2703,134 @@ throwIfFileAlreadyExists :: ( MonadIO m ) =>
throwIfFileAlreadyExists fp = whenM (checkFileAlreadyExists fp) throwIfFileAlreadyExists fp = whenM (checkFileAlreadyExists fp)
(throwE $ FileAlreadyExistsError 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

View File

@ -492,33 +492,50 @@ hlsGHCVersions :: ( MonadReader env m
) )
=> m [Version] => m [Version]
hlsGHCVersions = do 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. -- | Get all server binaries for an hls version, if any.
hlsServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m) hlsServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m)
=> Version => Version
-> Maybe Version -- ^ optional GHC version
-> m [FilePath] -> m [FilePath]
hlsServerBinaries ver = do hlsServerBinaries ver mghcVer = do
Dirs {..} <- getDirs Dirs {..} <- getDirs
liftIO $ handleIO (\_ -> pure []) $ findFiles liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts (makeRegexOpts
compExtended compExtended
execBlank 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. -- | Get all binaries for an hls version, if any.
hlsAllBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => Version -> m [FilePath] hlsAllBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => Version -> m [FilePath]
hlsAllBinaries ver = do hlsAllBinaries ver = do
hls <- hlsServerBinaries ver hls <- hlsServerBinaries ver Nothing
wrapper <- hlsWrapperBinary ver wrapper <- hlsWrapperBinary ver
pure (maybeToList wrapper ++ hls) 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, -- | Get the tool version that has this tag. If multiple have it,
-- picks the greatest version. -- picks the greatest version.
getTagged :: Tag getTagged :: Tag
-> AffineFold (Map.Map Version VersionInfo) (Version, VersionInfo) -> Fold (Map.Map Version VersionInfo) (Version, VersionInfo)
getTagged tag = 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 :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getLatest av tool = headOf (ix tool % getTagged Latest) av 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') = getChangeLog dls tool (Left v') =
preview (ix tool % ix v' % viChangeLog % _Just) dls preview (ix tool % ix v' % viChangeLog % _Just) dls
getChangeLog dls tool (Right tag) = 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: -- | Execute a build action while potentially cleaning up:

View File

@ -105,6 +105,11 @@ findFiles path regex = do
contents <- listDirectory path contents <- listDirectory path
pure $ filter (match regex) contents 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' :: FilePath -> MP.Parsec Void Text a -> IO [FilePath]
findFiles' path parser = do findFiles' path parser = do
contents <- listDirectory path contents <- listDirectory path

View File

@ -25,7 +25,6 @@ import GHCup.Types
import GHCup.Errors import GHCup.Errors
import GHCup.Types.Optics import GHCup.Types.Optics
import {-# SOURCE #-} GHCup.Utils.Logger import {-# SOURCE #-} GHCup.Utils.Logger
import GHCup.Errors
import Control.Applicative import Control.Applicative
import Control.Exception.Safe import Control.Exception.Safe