ghcup-hs/lib/GHCup.hs

678 lines
22 KiB
Haskell
Raw Normal View History

2020-04-09 17:53:22 +00:00
{-# LANGUAGE CPP #-}
2021-07-15 11:32:48 +00:00
{-# LANGUAGE BangPatterns #-}
2020-01-11 20:15:05 +00:00
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
2020-03-21 21:19:37 +00:00
{-# LANGUAGE OverloadedStrings #-}
2022-02-05 18:39:00 +00:00
{-# LANGUAGE QuasiQuotes #-}
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
{-|
Module : GHCup
Description : GHCup installation functions
Copyright : (c) Julian Ospald, 2020
2020-07-30 18:04:02 +00:00
License : LGPL-3.0
2020-07-21 23:08:58 +00:00
Maintainer : hasufell@hasufell.de
Stability : experimental
2021-05-14 21:09:45 +00:00
Portability : portable
2020-07-21 23:08:58 +00:00
This module contains the main functions that correspond
to the command line interface, like installation, listing versions
and so on.
These are the entry points.
-}
2022-05-21 20:54:18 +00:00
module GHCup (
module GHCup,
module GHCup.Cabal,
module GHCup.GHC,
module GHCup.HLS,
module GHCup.Stack,
module GHCup.List
) where
import GHCup.Cabal
import GHCup.GHC hiding ( GHCVer(..) )
import GHCup.HLS hiding ( HLSVer(..) )
2022-05-21 20:54:18 +00:00
import GHCup.Stack
import GHCup.List
2020-01-11 20:15:05 +00:00
import GHCup.Download
import GHCup.Errors
import GHCup.Platform
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Utils
2022-05-21 20:54:18 +00:00
import GHCup.Prelude
import GHCup.Prelude.File
import GHCup.Prelude.Logger
import GHCup.Prelude.String.QQ
2020-01-11 20:15:05 +00:00
import GHCup.Version
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
2020-04-09 17:53:22 +00:00
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
2020-01-11 20:15:05 +00:00
import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
import Data.ByteString ( ByteString )
import Data.Either
2020-01-11 20:15:05 +00:00
import Data.List
import Data.Maybe
2021-11-12 18:52:00 +00:00
import Data.Versions hiding ( patch )
2020-01-11 20:15:05 +00:00
import GHC.IO.Exception
import Haskus.Utils.Variant.Excepts
import Optics
import Prelude hiding ( abs
, writeFile
)
2021-05-14 21:09:45 +00:00
import System.Environment
import System.FilePath
2020-01-11 20:15:05 +00:00
import System.IO.Error
2022-11-15 13:30:19 +00:00
import System.IO.Temp
import Text.Regex.Posix
2022-05-21 20:54:18 +00:00
2020-04-25 10:06:41 +00:00
import qualified Data.Text as T
2022-05-14 15:58:11 +00:00
import qualified Streamly.Prelude as S
2022-05-21 20:54:18 +00:00
2020-01-11 20:15:05 +00:00
2021-07-19 14:49:18 +00:00
---------------------
--[ Tool fetching ]--
---------------------
fetchToolBindist :: ( MonadFail m
, MonadMask m
, MonadCatch m
, MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, HasGHCupInfo env
2021-08-30 20:41:58 +00:00
, HasLog env
2021-07-19 14:49:18 +00:00
, MonadResource m
, MonadIO m
, MonadUnliftIO m
)
2023-11-12 10:21:49 +00:00
=> GHCTargetVersion
2021-07-19 14:49:18 +00:00
-> Tool
-> Maybe FilePath
-> Excepts
'[ DigestError
, ContentLengthError
2021-09-18 17:45:32 +00:00
, GPGError
2021-07-19 14:49:18 +00:00
, DownloadFailed
, NoDownload
]
m
FilePath
fetchToolBindist v t mfp = do
2023-11-12 10:21:49 +00:00
dlinfo <- liftE $ getDownloadInfo' t v
2021-07-19 14:49:18 +00:00
liftE $ downloadCached' dlinfo Nothing mfp
2020-01-11 20:15:05 +00:00
2022-05-21 20:54:18 +00:00
------------
--[ Nuke ]--
------------
2020-01-11 20:15:05 +00:00
rmTool :: ( MonadReader env m
, HasDirs env
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadFail m
, MonadMask m
, MonadUnliftIO m)
=> ListResult
-> Excepts '[NotInstalled, UninstallFailed] m ()
rmTool ListResult {lVer, lTool, lCross} = do
2023-07-17 15:10:43 +00:00
let printRmTool = logInfo $ "removing " <> T.pack (show lTool) <> " version " <> prettyVer lVer
case lTool of
2023-07-17 15:10:43 +00:00
GHC -> do
let ghcTargetVersion = GHCTargetVersion lCross lVer
2023-07-17 15:10:43 +00:00
logInfo $ "removing " <> T.pack (show lTool) <> " version " <> tVerToText ghcTargetVersion
rmGHCVer ghcTargetVersion
HLS -> do
printRmTool
rmHLSVer lVer
Cabal -> do
printRmTool
liftE $ rmCabalVer lVer
Stack -> do
printRmTool
liftE $ rmStackVer lVer
GHCup -> do
printRmTool
lift rmGhcup
rmGhcupDirs :: ( MonadReader env m
, HasDirs env
, MonadIO m
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadCatch m
, MonadMask m )
2021-07-02 21:26:07 +00:00
=> m [FilePath]
rmGhcupDirs = do
2021-07-02 21:26:07 +00:00
Dirs
{ baseDir
, binDir
, logsDir
, cacheDir
2021-07-22 13:45:08 +00:00
, recycleDir
2022-05-16 15:14:40 +00:00
, dbDir
2022-05-20 21:19:33 +00:00
, tmpDir
} <- getDirs
let envFilePath = fromGHCupPath baseDir </> "env"
confFilePath <- getConfigFilePath
2021-07-22 13:45:08 +00:00
handleRm $ rmEnvFile envFilePath
handleRm $ rmConfFile confFilePath
2021-07-29 09:51:47 +00:00
-- for xdg dirs, the order matters here
2022-05-16 15:14:40 +00:00
handleRm $ rmPathForcibly logsDir
2022-05-20 21:19:33 +00:00
handleRm $ rmPathForcibly tmpDir
2022-05-16 15:14:40 +00:00
handleRm $ rmPathForcibly cacheDir
2021-07-29 09:51:47 +00:00
2021-07-22 13:45:08 +00:00
handleRm $ rmBinDir binDir
2022-05-16 15:14:40 +00:00
handleRm $ rmPathForcibly recycleDir
handleRm $ rmPathForcibly dbDir
2021-10-17 18:39:49 +00:00
when isWindows $ do
logInfo $ "removing " <> T.pack (fromGHCupPath baseDir </> "msys64")
handleRm $ rmPathForcibly (baseDir `appendGHCupPath` "msys64")
2022-05-19 22:46:50 +00:00
handleRm $ removeEmptyDirsRecursive (fromGHCupPath baseDir)
2021-07-02 21:26:07 +00:00
-- report files in baseDir that are left-over after
-- the standard location deletions above
hideErrorDef [doesNotExistErrorType] [] $ reportRemainingFiles (fromGHCupPath baseDir)
where
2021-08-30 20:41:58 +00:00
handleRm :: (MonadReader env m, MonadCatch m, HasLog env, MonadIO m) => m () -> m ()
handleRm = handleIO (\e -> logDebug $ "Part of the cleanup action failed with error: " <> T.pack (displayException e) <> "\n"
2021-08-25 16:54:58 +00:00
<> "continuing regardless...")
2021-08-30 20:41:58 +00:00
rmEnvFile :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmEnvFile enFilePath = do
2021-08-30 20:41:58 +00:00
logInfo "Removing Ghcup Environment File"
hideErrorDef [permissionErrorType] () $ rmFileForce enFilePath
2021-08-30 20:41:58 +00:00
rmConfFile :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmConfFile confFilePath = do
2021-08-30 20:41:58 +00:00
logInfo "removing Ghcup Config File"
hideErrorDef [permissionErrorType] () $ rmFileForce confFilePath
rmBinDir :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
2021-10-17 18:39:49 +00:00
rmBinDir binDir
| isWindows = removeDirIfEmptyOrIsSymlink binDir
| otherwise = do
isXDGStyle <- liftIO useXDG
2022-07-11 17:49:08 +00:00
when (not isXDGStyle) $
removeDirIfEmptyOrIsSymlink binDir
2022-05-14 15:58:11 +00:00
reportRemainingFiles :: (MonadMask m, MonadIO m) => FilePath -> m [FilePath]
2021-07-02 21:26:07 +00:00
reportRemainingFiles dir = do
2022-05-14 15:58:11 +00:00
remainingFiles <- liftIO $ S.toList (getDirectoryContentsRecursiveUnsafe dir)
let normalizedFilePaths = fmap normalise remainingFiles
2021-06-15 12:00:30 +00:00
let sortedByDepthRemainingFiles = sortBy (flip compareFn) normalizedFilePaths
2021-07-02 21:26:07 +00:00
let remainingFilesAbsolute = fmap (dir </>) sortedByDepthRemainingFiles
pure remainingFilesAbsolute
where
calcDepth :: FilePath -> Int
calcDepth = length . filter isPathSeparator
compareFn :: FilePath -> FilePath -> Ordering
compareFn fp1 fp2 = compare (calcDepth fp1) (calcDepth fp2)
2020-01-11 20:15:05 +00:00
2021-07-02 21:26:07 +00:00
2020-01-11 20:15:05 +00:00
------------------
--[ Debug info ]--
------------------
getDebugInfo :: ( Alternative m
, MonadFail m
, MonadReader env m
, HasDirs env
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadCatch m
, MonadIO m
)
2020-01-11 20:15:05 +00:00
=> Excepts
'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
m
DebugInfo
getDebugInfo = do
Dirs {..} <- lift getDirs
let diBaseDir = fromGHCupPath baseDir
let diBinDir = binDir
diGHCDir <- fromGHCupPath <$> lift ghcupGHCBaseDir
let diCacheDir = fromGHCupPath cacheDir
diArch <- lE getArchitecture
2021-03-11 16:03:51 +00:00
diPlatform <- liftE getPlatform
2020-01-11 20:15:05 +00:00
pure $ DebugInfo { .. }
2022-05-21 20:54:18 +00:00
-------------------------
--[ GHCup upgrade etc ]--
-------------------------
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@,
-- if no path is provided.
2020-01-11 20:15:05 +00:00
upgradeGHCup :: ( MonadMask m
, MonadReader env m
, HasDirs env
, HasPlatformReq env
, HasGHCupInfo env
, HasSettings env
2020-01-11 20:15:05 +00:00
, MonadCatch m
2021-08-30 20:41:58 +00:00
, HasLog env
2020-01-11 20:15:05 +00:00
, MonadThrow m
, MonadFail m
2020-01-11 20:15:05 +00:00
, MonadResource m
, MonadIO m
, MonadUnliftIO m
2020-01-11 20:15:05 +00:00
)
2021-05-14 21:09:45 +00:00
=> Maybe FilePath -- ^ full file destination to write ghcup into
-> Bool -- ^ whether to force update regardless
-- of currently installed version
-> Bool -- ^ whether to throw an error if ghcup is shadowed
2020-01-11 20:15:05 +00:00
-> Excepts
'[ CopyError
, DigestError
, ContentLengthError
2021-09-18 17:45:32 +00:00
, GPGError
, GPGError
2020-01-11 20:15:05 +00:00
, DownloadFailed
, NoDownload
, NoUpdate
2022-05-23 14:48:29 +00:00
, ToolShadowed
2020-01-11 20:15:05 +00:00
]
m
Version
upgradeGHCup mtarget force' fatal = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2024-03-02 08:23:28 +00:00
let latestVer = _tvVersion $ fst (fromJust (getLatest dls GHCup))
upgradeGHCup' mtarget force' fatal latestVer
2024-03-02 08:23:28 +00:00
-- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@,
-- if no path is provided.
upgradeGHCup' :: ( MonadMask m
, MonadReader env m
, HasDirs env
, HasPlatformReq env
, HasGHCupInfo env
, HasSettings env
, MonadCatch m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadResource m
, MonadIO m
, MonadUnliftIO m
)
=> Maybe FilePath -- ^ full file destination to write ghcup into
-> Bool -- ^ whether to force update regardless
-- of currently installed version
-> Bool -- ^ whether to throw an error if ghcup is shadowed
-> Version
-> Excepts
'[ CopyError
, DigestError
, ContentLengthError
, GPGError
, GPGError
, DownloadFailed
, NoDownload
, NoUpdate
, ToolShadowed
]
m
Version
upgradeGHCup' mtarget force' fatal latestVer = do
Dirs {..} <- lift getDirs
2021-08-30 20:41:58 +00:00
lift $ logInfo "Upgrading GHCup..."
2021-11-02 00:22:06 +00:00
(Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer ""
when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate
2021-07-19 14:49:18 +00:00
dli <- liftE $ getDownloadInfo GHCup latestVer
tmp <- fromGHCupPath <$> lift withGHCupTmpDir
2021-05-14 21:09:45 +00:00
let fn = "ghcup" <> exeExt
p <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (_dlCSize dli) tmp (Just fn) False
2021-05-14 21:09:45 +00:00
let destDir = takeDirectory destFile
2021-07-22 13:45:08 +00:00
destFile = fromMaybe (binDir </> fn) mtarget
2021-08-30 20:41:58 +00:00
lift $ logDebug $ "mkdir -p " <> T.pack destDir
liftIO $ createDirRecursive' destDir
2021-08-30 20:41:58 +00:00
lift $ logDebug $ "rm -f " <> T.pack destFile
2021-07-22 13:45:08 +00:00
lift $ hideError NoSuchThing $ recycleFile destFile
2021-08-30 20:41:58 +00:00
lift $ logDebug $ "cp " <> T.pack p <> " " <> T.pack destFile
copyFileE p destFile False
lift $ chmod_755 destFile
2021-03-11 16:03:51 +00:00
liftIO (isInPath destFile) >>= \b -> unless b $
2021-08-30 20:41:58 +00:00
lift $ logWarn $ T.pack (takeFileName destFile) <> " is not in PATH! You have to add it in order to use ghcup."
liftIO (isShadowed destFile) >>= \case
Nothing -> pure ()
Just pa
2022-05-23 14:48:29 +00:00
| fatal -> throwE (ToolShadowed GHCup pa destFile latestVer)
| otherwise ->
lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed GHCup pa destFile latestVer)
2020-01-11 20:15:05 +00:00
pure latestVer
2022-05-21 20:54:18 +00:00
-- assuming the current scheme of having just 1 ghcup bin, no version info is required.
rmGhcup :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadCatch m
, HasLog env
, MonadMask m
, MonadUnliftIO m
)
=> m ()
rmGhcup = do
Dirs { .. } <- getDirs
let ghcupFilename = "ghcup" <> exeExt
let ghcupFilepath = binDir </> ghcupFilename
2020-01-11 20:15:05 +00:00
2022-05-21 20:54:18 +00:00
currentRunningExecPath <- liftIO getExecutablePath
-- if paths do no exist, warn user, and continue to compare them, as is,
-- which should eventually fail and result in a non-standard install warning
p1 <- handleIO' doesNotExistErrorType
(handlePathNotPresent currentRunningExecPath)
(liftIO $ canonicalizePath currentRunningExecPath)
p2 <- handleIO' doesNotExistErrorType
(handlePathNotPresent ghcupFilepath)
(liftIO $ canonicalizePath ghcupFilepath)
let areEqualPaths = equalFilePath p1 p2
unless areEqualPaths $ logWarn $ nonStandardInstallLocationMsg currentRunningExecPath
if isWindows
then do
-- since it doesn't seem possible to delete a running exe on windows
2022-11-15 13:30:19 +00:00
-- we move it to system temp dir, to be deleted at next reboot
tmp <- liftIO $ getCanonicalTemporaryDirectory >>= \t -> createTempDirectory t "ghcup"
logDebug $ "mv " <> T.pack ghcupFilepath <> " " <> T.pack (tmp </> "ghcup")
2022-05-21 20:54:18 +00:00
hideError UnsupportedOperation $
liftIO $ hideError NoSuchThing $
2022-11-15 13:30:19 +00:00
moveFile ghcupFilepath (tmp </> "ghcup")
2022-05-21 20:54:18 +00:00
else
-- delete it.
hideError doesNotExistErrorType $ rmFile ghcupFilepath
where
handlePathNotPresent fp _err = do
logDebug $ "Error: The path does not exist, " <> T.pack fp
pure fp
nonStandardInstallLocationMsg path = T.pack $
"current ghcup is invoked from a non-standard location: \n"
<> path <>
"\n you may have to uninstall it manually."
2020-01-11 20:15:05 +00:00
2020-01-11 20:15:05 +00:00
2022-05-21 20:54:18 +00:00
---------------
--[ Whereis ]--
---------------
2020-01-11 20:15:05 +00:00
-- | Reports the binary location of a given tool:
--
-- * for GHC, this reports: @~\/.ghcup\/ghc\/\<ver\>\/bin\/ghc@
-- * for cabal, this reports @~\/.ghcup\/bin\/cabal-\<ver\>@
-- * for hls, this reports @~\/.ghcup\/bin\/haskell-language-server-wrapper-\<ver\>@
-- * for stack, this reports @~\/.ghcup\/bin\/stack-\<ver\>@
-- * for ghcup, this reports the location of the currently running executable
whereIsTool :: ( MonadReader env m
, HasDirs env
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadCatch m
, MonadMask m
, MonadUnliftIO m
)
=> Tool
-> GHCTargetVersion
-> Excepts '[NotInstalled] m FilePath
whereIsTool tool ver@GHCTargetVersion {..} = do
dirs <- lift getDirs
case tool of
GHC -> do
whenM (lift $ fmap not $ ghcInstalled ver)
$ throwE (NotInstalled GHC ver)
bdir <- fromGHCupPath <$> lift (ghcupGHCDir ver)
2021-07-15 20:38:42 +00:00
pure (bdir </> "bin" </> ghcBinaryName ver)
Cabal -> do
whenM (lift $ fmap not $ cabalInstalled _tvVersion)
$ throwE (NotInstalled Cabal (GHCTargetVersion Nothing _tvVersion))
pure (binDir dirs </> "cabal-" <> T.unpack (prettyVer _tvVersion) <> exeExt)
HLS -> do
whenM (lift $ fmap not $ hlsInstalled _tvVersion)
$ throwE (NotInstalled HLS (GHCTargetVersion Nothing _tvVersion))
2022-02-05 18:11:56 +00:00
ifM (lift $ isLegacyHLS _tvVersion)
(pure (binDir dirs </> "haskell-language-server-wrapper-" <> T.unpack (prettyVer _tvVersion) <> exeExt))
$ do
bdir <- fromGHCupPath <$> lift (ghcupHLSDir _tvVersion)
2022-02-05 18:11:56 +00:00
pure (bdir </> "bin" </> "haskell-language-server-wrapper" <> exeExt)
Stack -> do
whenM (lift $ fmap not $ stackInstalled _tvVersion)
$ throwE (NotInstalled Stack (GHCTargetVersion Nothing _tvVersion))
pure (binDir dirs </> "stack-" <> T.unpack (prettyVer _tvVersion) <> exeExt)
GHCup -> do
currentRunningExecPath <- liftIO getExecutablePath
liftIO $ canonicalizePath currentRunningExecPath
2022-05-21 20:54:18 +00:00
2021-09-18 13:46:53 +00:00
-- | Doesn't work for cross GHC.
checkIfToolInstalled :: ( MonadIO m
, MonadReader env m
, HasDirs env
, MonadCatch m) =>
Tool ->
Version ->
m Bool
2022-02-09 17:57:59 +00:00
checkIfToolInstalled tool ver = checkIfToolInstalled' tool (mkTVer ver)
2022-05-21 20:54:18 +00:00
2022-02-09 17:57:59 +00:00
checkIfToolInstalled' :: ( MonadIO m
, MonadReader env m
, HasDirs env
, MonadCatch m) =>
Tool ->
GHCTargetVersion ->
m Bool
checkIfToolInstalled' tool ver =
case tool of
2022-02-09 17:57:59 +00:00
Cabal -> cabalInstalled (_tvVersion ver)
HLS -> hlsInstalled (_tvVersion ver)
Stack -> stackInstalled (_tvVersion ver)
GHC -> ghcInstalled ver
_ -> pure False
--------------------------
--[ Garbage collection ]--
--------------------------
rmOldGHC :: ( MonadReader env m
, HasGHCupInfo env
, HasDirs env
, HasLog env
, MonadIO m
, MonadFail m
, MonadMask m
, MonadUnliftIO m
)
=> Excepts '[NotInstalled, UninstallFailed] m ()
rmOldGHC = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2023-07-07 08:41:58 +00:00
let oldGHCs = toListOf (ix GHC % getTagged Old % to fst) dls
ghcs <- lift $ fmap rights getInstalledGHCs
forM_ ghcs $ \ghc -> when (ghc `elem` oldGHCs) $ rmGHCVer ghc
rmUnsetTools :: ( MonadReader env m
, HasGHCupInfo env
, HasPlatformReq env
, HasDirs env
, HasLog env
, MonadIO m
, MonadFail m
, MonadMask m
, MonadUnliftIO m
)
=> Excepts '[NotInstalled, UninstallFailed] m ()
rmUnsetTools = do
vers <- lift $ listVersions Nothing [ListInstalled True, ListSet False] False True (Nothing, Nothing)
forM_ vers $ \ListResult{..} -> case lTool of
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer)
HLS -> liftE $ rmHLSVer lVer
Cabal -> liftE $ rmCabalVer lVer
Stack -> liftE $ rmStackVer lVer
GHCup -> pure ()
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
-- TODO: audit findFilesDeep
matches <- liftIO $ handleIO (\_ -> pure []) $ findFilesDeep
d
(makeRegexOpts compExtended
execBlank
regex
)
forM_ matches $ \m -> do
let p = fromGHCupPath 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 `appendGHCupPath` "share"
logDebug $ "rm -rf " <> T.pack (fromGHCupPath p)
rmPathForcibly p
rmHLSNoGHC :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadIO m
, MonadMask m
2022-02-05 18:12:13 +00:00
, MonadFail m
, MonadUnliftIO m
)
=> Excepts '[NotInstalled, UninstallFailed] m ()
rmHLSNoGHC = do
Dirs {..} <- getDirs
ghcs <- fmap rights getInstalledGHCs
hlses <- fmap rights getInstalledHLSs
forM_ hlses $ \hls -> do
hlsGHCs <- fmap mkTVer <$> hlsGHCVersions' hls
2022-02-05 18:39:00 +00:00
let candidates = filter (`notElem` ghcs) hlsGHCs
2022-02-05 18:12:13 +00:00
if (length hlsGHCs - length candidates) <= 0
then rmHLSVer hls
else
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
rmFile f
2022-02-05 18:12:13 +00:00
pure ()
rmCache :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadIO m
, MonadMask m
)
=> m ()
rmCache = do
Dirs {..} <- getDirs
contents <- liftIO $ listDirectory (fromGHCupPath cacheDir)
forM_ contents $ \f -> do
let p = fromGHCupPath cacheDir </> f
logDebug $ "rm " <> T.pack p
rmFile p
rmTmp :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadIO m
, MonadMask m
)
=> m ()
rmTmp = do
ghcup_dirs <- liftIO getGHCupTmpDirs
forM_ ghcup_dirs $ \f -> do
logDebug $ "rm -rf " <> T.pack (fromGHCupPath f)
rmPathForcibly f
2021-11-12 18:52:00 +00:00