Merge branch 'issue-241'
This commit is contained in:
commit
bedfb3d114
GPG Key ID:
3786C5262ECB4A3F
|
|
@ -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
|
||||
|
|
|
|||
135
lib/GHCup.hs
135
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-<ghcver> 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
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue