ghcup-hs/lib/GHCup.hs

2943 lines
103 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
{-# LANGUAGE TemplateHaskell #-}
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.
-}
2020-01-11 20:15:05 +00:00
module GHCup where
import GHCup.Download
import GHCup.Errors
import GHCup.Platform
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.File
2021-09-23 10:53:01 +00:00
import GHCup.Utils.Logger
2020-01-11 20:15:05 +00:00
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import GHCup.Utils.Version.QQ
import GHCup.Version
import Codec.Archive ( ArchiveResult )
2020-01-11 20:15:05 +00:00
import Control.Applicative
2021-07-15 11:32:48 +00:00
import Control.DeepSeq ( force )
2021-06-15 12:00:30 +00:00
import Control.Exception ( evaluate )
2020-01-11 20:15:05 +00:00
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 )
2021-07-22 13:45:08 +00:00
import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )
2020-01-11 20:15:05 +00:00
import Data.ByteString ( ByteString )
import Data.Either
2020-01-11 20:15:05 +00:00
import Data.List
import Data.Maybe
import Data.List.NonEmpty ( NonEmpty((:|)) )
2021-04-28 16:45:48 +00:00
import Data.String ( fromString )
2020-04-25 10:06:41 +00:00
import Data.Text ( Text )
import Data.Time.Clock
import Data.Time.Format.ISO8601
2021-11-12 18:52:00 +00:00
import Data.Versions hiding ( patch )
2021-09-19 19:24:21 +00:00
import Distribution.Types.Version hiding ( Version )
import Distribution.Types.PackageId
import Distribution.Types.PackageDescription
import Distribution.Types.GenericPackageDescription
import Distribution.PackageDescription.Parsec
2020-01-11 20:15:05 +00:00
import GHC.IO.Exception
import Haskus.Utils.Variant.Excepts
2021-09-04 13:09:14 +00:00
import Language.Haskell.TH
import Language.Haskell.TH.Syntax ( Quasi(qAddDependentFile) )
2020-01-11 20:15:05 +00:00
import Optics
import Prelude hiding ( abs
, writeFile
)
import Safe hiding ( at )
2021-05-14 21:09:45 +00:00
import System.Directory hiding ( findFiles )
import System.Environment
import System.FilePath
2020-01-11 20:15:05 +00:00
import System.IO.Error
import System.IO.Temp
2021-08-24 18:18:14 +00:00
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix
import URI.ByteString
2020-01-11 20:15:05 +00:00
import qualified Crypto.Hash.SHA256 as SHA256
2021-09-19 19:24:21 +00:00
import qualified Data.List.NonEmpty as NE
import qualified Data.ByteString.Base16 as B16
2020-01-11 20:15:05 +00:00
import qualified Data.ByteString as B
2020-04-25 10:06:41 +00:00
import qualified Data.ByteString.Lazy as BL
2020-01-11 20:15:05 +00:00
import qualified Data.Map.Strict as Map
2020-04-25 10:06:41 +00:00
import qualified Data.Text as T
2021-08-25 16:54:58 +00:00
import qualified Data.Text.IO as T
2020-01-11 20:15:05 +00:00
import qualified Data.Text.Encoding as E
2021-04-28 16:45:48 +00:00
import qualified Text.Megaparsec as MP
import GHCup.Utils.MegaParsec
import Control.Concurrent (threadDelay)
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
)
=> Version
-> Tool
-> Maybe FilePath
-> Excepts
'[ DigestError
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
dlinfo <- liftE $ getDownloadInfo t v
liftE $ downloadCached' dlinfo Nothing mfp
fetchGHCSrc :: ( 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
)
=> Version
-> Maybe FilePath
-> Excepts
'[ DigestError
2021-09-18 17:45:32 +00:00
, GPGError
2021-07-19 14:49:18 +00:00
, DownloadFailed
, NoDownload
]
m
FilePath
fetchGHCSrc v mfp = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
dlInfo <-
preview (ix GHC % ix v % viSourceDL % _Just) dls
?? NoDownload
liftE $ downloadCached' dlInfo Nothing mfp
2020-01-11 20:15:05 +00:00
-------------------------
--[ Tool installation ]--
-------------------------
2020-07-21 23:08:58 +00:00
-- | Like 'installGHCBin', except takes the 'DownloadInfo' as
-- argument instead of looking it up from 'GHCupDownloads'.
installGHCBindist :: ( MonadFail m
2020-07-21 23:08:58 +00:00
, MonadMask m
, MonadCatch m
, MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
2021-08-30 20:41:58 +00:00
, HasLog env
2020-07-21 23:08:58 +00:00
, MonadResource m
, MonadIO m
, MonadUnliftIO m
2020-07-21 23:08:58 +00:00
)
=> DownloadInfo -- ^ where/how to download
-> Version -- ^ the version to install
-> InstallDir
2021-09-11 17:50:06 +00:00
-> Bool -- ^ Force install
2020-07-21 23:08:58 +00:00
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, DigestError
2021-09-18 17:45:32 +00:00
, GPGError
2020-07-21 23:08:58 +00:00
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
2020-08-06 11:28:20 +00:00
, TarDirDoesNotExist
2021-08-11 10:24:51 +00:00
, DirNotEmpty
2020-07-21 23:08:58 +00:00
, ArchiveResult
2021-10-10 18:02:15 +00:00
, ProcessError
2020-07-21 23:08:58 +00:00
]
m
()
installGHCBindist dlinfo ver installDir forceInstall = do
2021-03-11 16:03:51 +00:00
let tver = mkTVer ver
2021-08-30 20:41:58 +00:00
lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver
2021-09-11 17:50:06 +00:00
regularGHCInstalled <- lift $ checkIfToolInstalled GHC ver
2021-09-11 17:50:06 +00:00
if
| not forceInstall
, regularGHCInstalled
, GHCupInternal <- installDir -> do
2021-09-18 13:47:54 +00:00
throwE $ AlreadyInstalled GHC ver
2021-09-11 17:50:06 +00:00
| forceInstall
, regularGHCInstalled
, GHCupInternal <- installDir -> do
2021-09-18 13:47:54 +00:00
lift $ logInfo "Removing the currently installed GHC version first!"
2021-09-11 17:50:06 +00:00
liftE $ rmGHCVer tver
| otherwise -> pure ()
2020-01-11 20:15:05 +00:00
-- download (or use cached version)
2021-07-18 21:29:09 +00:00
dl <- liftE $ downloadCached dlinfo Nothing
2020-01-11 20:15:05 +00:00
2020-10-30 20:07:49 +00:00
toolchainSanityChecks
2021-09-11 17:50:06 +00:00
case installDir of
IsolateDir isoDir -> do -- isolated install
2021-08-30 20:41:58 +00:00
lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir
liftE $ installPackedGHC dl (view dlSubdir dlinfo) (IsolateDirResolved isoDir) ver forceInstall
GHCupInternal -> do -- regular install
-- prepare paths
ghcdir <- lift $ ghcupGHCDir tver
liftE $ installPackedGHC dl (view dlSubdir dlinfo) (GHCupDir ghcdir) ver forceInstall
2020-01-11 20:15:05 +00:00
-- make symlinks & stuff when regular install,
liftE $ postGHCInstall tver
2020-01-11 20:15:05 +00:00
2020-10-30 20:07:49 +00:00
where
toolchainSanityChecks = do
2021-05-14 21:09:45 +00:00
r <- forM ["CC", "LD"] (liftIO . lookupEnv)
2020-10-30 20:07:49 +00:00
case catMaybes r of
[] -> pure ()
_ -> do
2021-08-30 20:41:58 +00:00
lift $ logWarn $ "CC/LD environment variable is set. This will change the compiler/linker"
<> "\n" <> "GHC uses internally and can cause defunct GHC in some cases (e.g. in Anaconda"
<> "\n" <> "environments). If you encounter problems, unset CC and LD and reinstall."
2020-10-30 20:07:49 +00:00
-- | Install a packed GHC distribution. This only deals with unpacking and the GHC
-- build system and nothing else.
installPackedGHC :: ( MonadMask m
, MonadCatch m
, MonadReader env m
, HasDirs env
, HasPlatformReq env
, HasSettings env
, MonadThrow m
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadIO m
, MonadUnliftIO m
2021-09-19 19:24:21 +00:00
, MonadFail m
)
2021-05-14 21:09:45 +00:00
=> FilePath -- ^ Path to the packed GHC bindist
-> Maybe TarDir -- ^ Subdir of the archive
-> InstallDirResolved
-> Version -- ^ The GHC version
2021-09-11 17:50:06 +00:00
-> Bool -- ^ Force install
-> Excepts
'[ BuildFailed
, UnknownArchive
, TarDirDoesNotExist
2021-08-11 10:24:51 +00:00
, DirNotEmpty
, ArchiveResult
2021-10-10 18:02:15 +00:00
, ProcessError
] m ()
2021-09-11 17:50:06 +00:00
installPackedGHC dl msubdir inst ver forceInstall = do
PlatformRequest {..} <- lift getPlatformReq
2021-05-14 21:09:45 +00:00
2021-09-11 17:50:06 +00:00
unless forceInstall
(liftE $ installDestSanityCheck inst)
2021-08-11 10:24:51 +00:00
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
2021-10-10 18:02:15 +00:00
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
2020-01-11 20:15:05 +00:00
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack)
(liftE . intoSubdir tmpUnpack)
2021-03-11 16:03:51 +00:00
msubdir
liftE $ runBuildAction tmpUnpack
(case inst of
IsolateDirResolved _ -> Nothing -- don't clean up for isolated installs, since that'd potentially delete other
-- user files if '--force' is supplied
GHCupDir d -> Just d
)
2021-05-14 21:09:45 +00:00
(installUnpackedGHC workdir inst ver)
-- | Install an unpacked GHC distribution. This only deals with the GHC
-- build system and nothing else.
installUnpackedGHC :: ( MonadReader env m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, MonadThrow m
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadIO m
2021-07-22 13:45:08 +00:00
, MonadUnliftIO m
, MonadMask m
)
=> FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-> InstallDirResolved -- ^ Path to install to
-> Version -- ^ The GHC version
-> Excepts '[ProcessError] m ()
installUnpackedGHC path (fromInstallDir -> inst) ver
2021-10-17 18:39:49 +00:00
| isWindows = do
lift $ logInfo "Installing GHC (this may take a while)"
-- Windows bindists are relocatable and don't need
-- to run configure.
-- We also must make sure to preserve mtime to not confuse ghc-pkg.
lift $ withRunInIO $ \run -> flip onException (run $ recyclePathForcibly inst) $ copyDirectoryRecursive path inst $ \source dest -> do
mtime <- getModificationTime source
moveFilePortable source dest
setModificationTime dest mtime
| otherwise = do
PlatformRequest {..} <- lift getPlatformReq
let alpineArgs
| ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform
= ["--disable-ld-override"]
| otherwise
= []
lift $ logInfo "Installing GHC (this may take a while)"
lEM $ execLogged "sh"
("./configure" : ("--prefix=" <> inst)
2021-10-17 18:39:49 +00:00
: alpineArgs
)
(Just path)
"ghc-configure"
Nothing
lEM $ make ["install"] (Just path)
pure ()
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
-- following symlinks in @~\/.ghcup\/bin@:
--
-- * @ghc-x.y.z -> ..\/ghc\/x.y.z\/bin/ghc@
-- * @ghc-x.y -> ..\/ghc\/x.y.z\/bin/ghc@ (if x.y.z is the latest x.y version)
installGHCBin :: ( MonadFail m
, MonadMask m
, MonadCatch m
, MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
, HasDirs env
, HasSettings env
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
)
2021-05-14 21:09:45 +00:00
=> Version -- ^ the version to install
-> InstallDir
2021-09-11 17:50:06 +00:00
-> Bool -- ^ force install
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, DigestError
2021-09-18 17:45:32 +00:00
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
2020-08-06 11:28:20 +00:00
, TarDirDoesNotExist
2021-08-11 10:24:51 +00:00
, DirNotEmpty
, ArchiveResult
2021-10-10 18:02:15 +00:00
, ProcessError
]
m
()
installGHCBin ver installDir forceInstall = do
2021-07-19 14:49:18 +00:00
dlinfo <- liftE $ getDownloadInfo GHC ver
liftE $ installGHCBindist dlinfo ver installDir forceInstall
2020-07-21 23:08:58 +00:00
-- | Like 'installCabalBin', except takes the 'DownloadInfo' as
-- argument instead of looking it up from 'GHCupDownloads'.
installCabalBindist :: ( MonadMask m
, MonadCatch m
, MonadReader env m
, HasPlatformReq env
, HasDirs env
, HasSettings env
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
, MonadFail m
)
=> DownloadInfo
-> Version
-> InstallDir
-> Bool -- ^ Force install
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
2021-09-18 17:45:32 +00:00
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
2020-08-06 11:28:20 +00:00
, TarDirDoesNotExist
, ArchiveResult
, FileAlreadyExistsError
]
m
()
installCabalBindist dlinfo ver installDir forceInstall = do
2021-08-30 20:41:58 +00:00
lift $ logDebug $ "Requested to install cabal version " <> prettyVer ver
PlatformRequest {..} <- lift getPlatformReq
2021-07-18 21:29:09 +00:00
Dirs {..} <- lift getDirs
-- check if we already have a regular cabal already installed
regularCabalInstalled <- lift $ checkIfToolInstalled Cabal ver
if
| not forceInstall
, regularCabalInstalled
, GHCupInternal <- installDir -> do
throwE $ AlreadyInstalled Cabal ver
| forceInstall
, regularCabalInstalled
, GHCupInternal <- installDir -> do
2021-09-18 13:47:54 +00:00
lift $ logInfo "Removing the currently installed version first!"
liftE $ rmCabalVer ver
| otherwise -> pure ()
2020-01-11 20:15:05 +00:00
-- download (or use cached version)
2021-07-18 21:29:09 +00:00
dl <- liftE $ downloadCached dlinfo Nothing
2020-01-11 20:15:05 +00:00
-- unpack
2021-07-18 21:29:09 +00:00
tmpUnpack <- lift withGHCupTmpDir
2021-10-10 18:02:15 +00:00
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
2020-01-11 20:15:05 +00:00
-- the subdir of the archive where we do the work
2020-08-06 11:28:20 +00:00
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
2020-01-11 20:15:05 +00:00
case installDir of
IsolateDir isoDir -> do -- isolated install
2021-08-30 20:41:58 +00:00
lift $ logInfo $ "isolated installing Cabal to " <> T.pack isoDir
liftE $ installCabalUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall
GHCupInternal -> do -- regular install
liftE $ installCabalUnpacked workdir (GHCupDir binDir) ver forceInstall
-- | Install an unpacked cabal distribution.Symbol
installCabalUnpacked :: (MonadCatch m, HasLog env, MonadIO m, MonadReader env m)
=> FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides)
-> InstallDirResolved -- ^ Path to install to
-> Version
-> Bool -- ^ Force Install
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installCabalUnpacked path inst ver forceInstall = do
2021-08-30 20:41:58 +00:00
lift $ logInfo "Installing cabal"
let cabalFile = "cabal"
liftIO $ createDirRecursive' (fromInstallDir inst)
2021-08-11 10:24:51 +00:00
let destFileName = cabalFile
<> (case inst of
IsolateDirResolved _ -> ""
GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver
)
2021-08-11 10:24:51 +00:00
<> exeExt
let destPath = fromInstallDir inst </> destFileName
unless forceInstall -- Overwrite it when it IS a force install
(liftE $ throwIfFileAlreadyExists destPath)
2021-09-25 15:27:02 +00:00
copyFileE
(path </> cabalFile <> exeExt)
destPath
lift $ chmod_755 destPath
2020-01-11 20:15:05 +00:00
2020-07-22 00:34:17 +00:00
-- | Installs cabal into @~\/.ghcup\/bin/cabal-\<ver\>@ and
2020-07-21 23:08:58 +00:00
-- creates a default @cabal -> cabal-x.y.z.q@ symlink for
-- the latest installed version.
installCabalBin :: ( MonadMask m
, MonadCatch m
, MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
, HasDirs env
, HasSettings env
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
, MonadFail m
)
2021-05-14 21:09:45 +00:00
=> Version
-> InstallDir
-> Bool -- force install
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
2021-09-18 17:45:32 +00:00
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
2020-08-06 11:28:20 +00:00
, TarDirDoesNotExist
, ArchiveResult
, FileAlreadyExistsError
]
m
()
installCabalBin ver installDir forceInstall = do
2021-07-19 14:49:18 +00:00
dlinfo <- liftE $ getDownloadInfo Cabal ver
installCabalBindist dlinfo ver installDir forceInstall
-- | Like 'installHLSBin, except takes the 'DownloadInfo' as
-- argument instead of looking it up from 'GHCupDownloads'.
installHLSBindist :: ( MonadMask m
, MonadCatch m
, MonadReader env m
, HasPlatformReq env
, HasDirs env
, HasSettings env
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
, MonadFail m
)
=> DownloadInfo
-> Version
-> InstallDir -- ^ isolated install path, if user passed any
-> Bool -- ^ Force install
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
2021-09-18 17:45:32 +00:00
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
, ArchiveResult
2021-08-26 18:16:40 +00:00
, FileAlreadyExistsError
2022-02-05 00:53:04 +00:00
, ProcessError
, DirNotEmpty
]
m
()
installHLSBindist dlinfo ver installDir forceInstall = do
2021-08-30 20:41:58 +00:00
lift $ logDebug $ "Requested to install hls version " <> prettyVer ver
PlatformRequest {..} <- lift getPlatformReq
2021-07-18 21:29:09 +00:00
Dirs {..} <- lift getDirs
2021-09-11 15:59:53 +00:00
regularHLSInstalled <- lift $ checkIfToolInstalled HLS ver
2021-09-11 15:59:53 +00:00
if
| not forceInstall
, regularHLSInstalled
, GHCupInternal <- installDir -> do -- regular install
throwE $ AlreadyInstalled HLS ver
2021-09-11 15:59:53 +00:00
| forceInstall
, regularHLSInstalled
, GHCupInternal <- installDir -> do -- regular forced install
2021-09-11 15:59:53 +00:00
lift $ logInfo "Removing the currently installed version of HLS before force installing!"
liftE $ rmHLSVer ver
2021-09-11 15:59:53 +00:00
| otherwise -> pure ()
-- download (or use cached version)
2021-07-18 21:29:09 +00:00
dl <- liftE $ downloadCached dlinfo Nothing
-- unpack
2021-07-18 21:29:09 +00:00
tmpUnpack <- lift withGHCupTmpDir
2021-10-10 18:02:15 +00:00
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
2022-02-05 00:53:04 +00:00
legacy <- liftIO $ isLegacyHLSBindist workdir
if
| not forceInstall
, not legacy
, (IsolateDir fp) <- installDir -> liftE $ installDestSanityCheck (IsolateDirResolved fp)
2022-02-05 00:53:04 +00:00
| otherwise -> pure ()
case installDir of
IsolateDir isoDir -> do
2021-08-30 20:41:58 +00:00
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
2022-02-05 00:53:04 +00:00
if legacy
then liftE $ installHLSUnpackedLegacy workdir (IsolateDirResolved isoDir) ver forceInstall
else liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir (IsolateDirResolved isoDir) ver
GHCupInternal -> do
2022-02-05 00:53:04 +00:00
if legacy
then liftE $ installHLSUnpackedLegacy workdir (GHCupDir binDir) ver forceInstall
2022-02-05 00:53:04 +00:00
else do
inst <- ghcupHLSDir ver
liftE $ runBuildAction tmpUnpack (Just inst)
$ installHLSUnpacked workdir (GHCupDir inst) ver
2022-02-09 17:57:59 +00:00
liftE $ setHLS ver SetHLS_XYZ Nothing
2022-02-05 00:53:04 +00:00
isLegacyHLSBindist :: FilePath -- ^ Path to the unpacked hls bindist
-> IO Bool
isLegacyHLSBindist path = do
not <$> doesFileExist (path </> "GNUmakefile")
2021-07-23 10:53:03 +00:00
-- | Install an unpacked hls distribution.
2022-02-05 00:53:04 +00:00
installHLSUnpacked :: (MonadMask m, MonadUnliftIO m, MonadReader env m, MonadFail m, HasLog env, HasDirs env, HasSettings env, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
-> InstallDirResolved -- ^ Path to install to
2022-02-05 00:53:04 +00:00
-> Version
-> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled] m ()
installHLSUnpacked path (fromInstallDir -> inst) _ = do
2022-02-05 00:53:04 +00:00
lift $ logInfo "Installing HLS"
liftIO $ createDirRecursive' inst
lEM $ make ["PREFIX=" <> inst, "install"] (Just path)
-- | Install an unpacked hls distribution (legacy).
installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
-> InstallDirResolved -- ^ Path to install to
-> Version
2022-02-05 00:53:04 +00:00
-> Bool -- ^ is it a force install
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installHLSUnpackedLegacy path installDir ver forceInstall = do
2021-08-30 20:41:58 +00:00
lift $ logInfo "Installing HLS"
liftIO $ createDirRecursive' (fromInstallDir installDir)
2021-07-23 10:53:03 +00:00
-- install haskell-language-server-<ghcver>
bins@(_:_) <- liftIO $ findFiles
path
(makeRegexOpts compExtended
execBlank
([s|^haskell-language-server-[0-9].*$|] :: ByteString)
)
forM_ bins $ \f -> do
let toF = dropSuffix exeExt f
<> (case installDir of
IsolateDirResolved _ -> ""
GHCupDir _ -> ("~" <>) . T.unpack . prettyVer $ ver
)
2021-08-11 10:24:51 +00:00
<> exeExt
let srcPath = path </> f
let destPath = fromInstallDir installDir </> toF
2021-09-11 15:59:53 +00:00
unless forceInstall -- if it is a force install, overwrite it.
(liftE $ throwIfFileAlreadyExists destPath)
2021-09-25 15:27:02 +00:00
copyFileE
srcPath
destPath
lift $ chmod_755 destPath
2021-07-23 10:53:03 +00:00
-- install haskell-language-server-wrapper
let wrapper = "haskell-language-server-wrapper"
2021-08-11 10:24:51 +00:00
toF = wrapper
<> (case installDir of
IsolateDirResolved _ -> ""
GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver
)
2021-08-11 10:24:51 +00:00
<> exeExt
srcWrapperPath = path </> wrapper <> exeExt
destWrapperPath = fromInstallDir installDir </> toF
2021-09-11 15:59:53 +00:00
unless forceInstall
(liftE $ throwIfFileAlreadyExists destWrapperPath)
2021-09-25 15:27:02 +00:00
copyFileE
srcWrapperPath
destWrapperPath
lift $ chmod_755 destWrapperPath
2021-09-19 19:24:21 +00:00
-- | Installs hls binaries @haskell-language-server-\<ghcver\>@
-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.
installHLSBin :: ( MonadMask m
, MonadCatch m
, MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
, HasDirs env
, HasSettings env
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
, MonadFail m
)
2021-05-14 21:09:45 +00:00
=> Version
-> InstallDir
2021-09-11 15:59:53 +00:00
-> Bool -- force install
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
2021-09-18 17:45:32 +00:00
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
, ArchiveResult
2021-08-26 18:16:40 +00:00
, FileAlreadyExistsError
2022-02-05 00:53:04 +00:00
, ProcessError
, DirNotEmpty
]
m
()
installHLSBin ver installDir forceInstall = do
2021-07-19 14:49:18 +00:00
dlinfo <- liftE $ getDownloadInfo HLS ver
installHLSBindist dlinfo ver installDir forceInstall
2021-09-19 19:24:21 +00:00
compileHLS :: ( MonadMask m
, MonadCatch m
, MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, HasGHCupInfo env
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
, MonadFail m
)
=> Either Version GitBranch
-> [Version]
-> Maybe Int
-> Maybe Version
-> InstallDir
-> Maybe (Either FilePath URI)
-> Maybe URI
2021-11-12 18:52:00 +00:00
-> Maybe (Either FilePath [URI]) -- ^ patches
-> [Text] -- ^ additional args to cabal install
2021-09-19 19:24:21 +00:00
-> Excepts '[ NoDownload
, GPGError
, DownloadFailed
, DigestError
, UnknownArchive
, TarDirDoesNotExist
, ArchiveResult
, BuildFailed
, NotInstalled
] m Version
compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patches cabalArgs = do
2021-09-19 19:24:21 +00:00
PlatformRequest { .. } <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
Dirs { .. } <- lift getDirs
2021-09-19 19:24:21 +00:00
(workdir, tver) <- case targetHLS of
-- unpack from version tarball
Left tver -> do
lift $ logDebug $ "Requested to compile: " <> prettyVer tver
-- download source tarball
dlInfo <-
preview (ix HLS % ix tver % viSourceDL % _Just) dls
?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
2021-10-10 18:02:15 +00:00
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
2021-09-19 19:24:21 +00:00
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
workdir <- maybe (pure tmpUnpack)
(liftE . intoSubdir tmpUnpack)
(view dlSubdir dlInfo)
pure (workdir, tver)
-- clone from git
Right GitBranch{..} -> do
tmpUnpack <- lift mkGhcupTmpDir
let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing
tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do
let rep = fromMaybe "https://github.com/haskell/haskell-language-server.git" repo
lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
lEM $ git [ "init" ]
lEM $ git [ "remote"
, "add"
, "origin"
, fromString rep ]
let fetch_args =
2021-09-19 19:24:21 +00:00
[ "fetch"
, "--depth"
, "1"
, "--quiet"
, "origin"
, fromString ref ]
lEM $ git fetch_args
lEM $ git [ "checkout", "FETCH_HEAD" ]
(Just gpd) <- parseGenericPackageDescriptionMaybe <$> liftIO (B.readFile (tmpUnpack </> "haskell-language-server.cabal"))
pure . (\c -> Version Nothing c [] Nothing)
. NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral)
. versionNumbers
. pkgVersion
. package
. packageDescription
$ gpd
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to HLS version " <> prettyVer tver
pure (tmpUnpack, tver)
-- the version that's installed may differ from the
-- compiled version, so the user can overwrite it
let installVer = fromMaybe tver ov
liftE $ runBuildAction
workdir
Nothing
(reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do
let tmpInstallDir = workdir </> "out"
liftIO $ createDirRecursive' tmpInstallDir
2021-09-20 20:24:20 +00:00
-- apply patches
2021-11-12 18:52:00 +00:00
liftE $ applyAnyPatch patches workdir
2021-09-20 20:24:20 +00:00
-- set up project files
cp <- case cabalProject of
Just (Left cp)
2021-09-20 20:24:20 +00:00
| isAbsolute cp -> do
2021-09-25 15:27:02 +00:00
copyFileE cp (workdir </> "cabal.project")
2021-09-20 20:24:20 +00:00
pure "cabal.project"
| otherwise -> pure (takeFileName cp)
Just (Right uri) -> do
tmpUnpack <- lift withGHCupTmpDir
cp <- liftE $ download uri Nothing Nothing tmpUnpack (Just "cabal.project") False
copyFileE cp (workdir </> "cabal.project")
pure "cabal.project"
2021-09-20 20:24:20 +00:00
Nothing -> pure "cabal.project"
forM_ cabalProjectLocal $ \uri -> do
tmpUnpack <- lift withGHCupTmpDir
cpl <- liftE $ download uri Nothing Nothing tmpUnpack (Just (cp <.> "local")) False
copyFileE cpl (workdir </> cp <.> "local")
2021-09-19 19:24:21 +00:00
artifacts <- forM (sort ghcs) $ \ghc -> do
let ghcInstallDir = tmpInstallDir </> T.unpack (prettyVer ghc)
liftIO $ createDirRecursive' tmpInstallDir
2021-09-19 19:24:21 +00:00
lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc
liftE $ lEM @_ @'[ProcessError] $
execLogged "cabal" ( [ "v2-install"
2021-09-19 19:24:21 +00:00
, "-w"
, "ghc-" <> T.unpack (prettyVer ghc)
, "--install-method=copy"
2021-09-19 19:24:21 +00:00
] ++
maybe [] (\j -> ["--jobs=" <> show j]) jobs ++
[ "--overwrite-policy=always"
, "--disable-profiling"
, "--disable-tests"
, "--installdir=" <> ghcInstallDir
, "--project-file=" <> cp
] ++ fmap T.unpack cabalArgs ++ [
"exe:haskell-language-server"
, "exe:haskell-language-server-wrapper"]
2021-09-19 19:24:21 +00:00
)
(Just workdir) "cabal" Nothing
pure ghcInstallDir
forM_ artifacts $ \artifact -> do
liftIO $ renameFile (artifact </> "haskell-language-server" <.> exeExt)
(tmpInstallDir </> "haskell-language-server-" <> takeFileName artifact <.> exeExt)
2021-09-19 19:24:21 +00:00
liftIO $ renameFile (artifact </> "haskell-language-server-wrapper" <.> exeExt)
(tmpInstallDir </> "haskell-language-server-wrapper" <.> exeExt)
2021-09-19 19:24:21 +00:00
liftIO $ rmPathForcibly artifact
case installDir of
IsolateDir isoDir -> do
2021-09-19 19:24:21 +00:00
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
liftE $ installHLSUnpackedLegacy tmpInstallDir (IsolateDirResolved isoDir) installVer True
GHCupInternal -> do
liftE $ installHLSUnpackedLegacy tmpInstallDir (GHCupDir binDir) installVer True
2021-09-19 19:24:21 +00:00
)
pure installVer
2021-05-14 22:31:36 +00:00
-- | Installs stack into @~\/.ghcup\/bin/stack-\<ver\>@ and
-- creates a default @stack -> stack-x.y.z.q@ symlink for
-- the latest installed version.
installStackBin :: ( 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-05-14 22:31:36 +00:00
, MonadResource m
, MonadIO m
, MonadUnliftIO m
, MonadFail m
)
2021-05-14 21:09:45 +00:00
=> Version
-> InstallDir
2021-09-11 16:28:11 +00:00
-> Bool -- ^ Force install
2021-05-14 22:31:36 +00:00
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
2021-09-18 17:45:32 +00:00
, GPGError
2021-05-14 22:31:36 +00:00
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
, ArchiveResult
2021-08-26 18:16:40 +00:00
, FileAlreadyExistsError
2021-05-14 22:31:36 +00:00
]
m
()
installStackBin ver installDir forceInstall = do
2021-07-19 14:49:18 +00:00
dlinfo <- liftE $ getDownloadInfo Stack ver
installStackBindist dlinfo ver installDir forceInstall
2021-05-14 22:31:36 +00:00
-- | Like 'installStackBin', except takes the 'DownloadInfo' as
-- argument instead of looking it up from 'GHCupDownloads'.
installStackBindist :: ( MonadMask m
, MonadCatch m
, MonadReader env m
, HasPlatformReq env
, HasDirs env
, HasSettings env
2021-08-30 20:41:58 +00:00
, HasLog env
2021-05-14 22:31:36 +00:00
, MonadResource m
, MonadIO m
, MonadUnliftIO m
, MonadFail m
)
=> DownloadInfo
-> Version
-> InstallDir
2021-09-11 16:28:11 +00:00
-> Bool -- ^ Force install
2021-05-14 22:31:36 +00:00
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
2021-09-18 17:45:32 +00:00
, GPGError
2021-05-14 22:31:36 +00:00
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
, ArchiveResult
2021-08-26 18:16:40 +00:00
, FileAlreadyExistsError
2021-05-14 22:31:36 +00:00
]
m
()
installStackBindist dlinfo ver installDir forceInstall = do
2021-08-30 20:41:58 +00:00
lift $ logDebug $ "Requested to install stack version " <> prettyVer ver
2021-05-14 22:31:36 +00:00
PlatformRequest {..} <- lift getPlatformReq
2021-07-18 21:29:09 +00:00
Dirs {..} <- lift getDirs
2021-05-14 22:31:36 +00:00
2021-09-11 16:28:11 +00:00
regularStackInstalled <- lift $ checkIfToolInstalled Stack ver
2021-09-11 16:28:11 +00:00
if
| not forceInstall
, regularStackInstalled
, GHCupInternal <- installDir -> do
2021-09-11 16:28:11 +00:00
throwE $ AlreadyInstalled Stack ver
| forceInstall
, regularStackInstalled
, GHCupInternal <- installDir -> do
2021-09-18 13:47:54 +00:00
lift $ logInfo "Removing the currently installed version of Stack first!"
2021-09-11 16:28:11 +00:00
liftE $ rmStackVer ver
| otherwise -> pure ()
2021-05-14 22:31:36 +00:00
-- download (or use cached version)
2021-07-18 21:29:09 +00:00
dl <- liftE $ downloadCached dlinfo Nothing
2021-05-14 22:31:36 +00:00
-- unpack
2021-07-18 21:29:09 +00:00
tmpUnpack <- lift withGHCupTmpDir
2021-10-10 18:02:15 +00:00
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
2021-05-14 22:31:36 +00:00
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
case installDir of
IsolateDir isoDir -> do -- isolated install
2021-08-30 20:41:58 +00:00
lift $ logInfo $ "isolated installing Stack to " <> T.pack isoDir
liftE $ installStackUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall
GHCupInternal -> do -- regular install
liftE $ installStackUnpacked workdir (GHCupDir binDir) ver forceInstall
2021-05-14 22:31:36 +00:00
2021-07-23 11:13:43 +00:00
-- | Install an unpacked stack distribution.
2021-08-30 20:41:58 +00:00
installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m)
2021-07-23 11:13:43 +00:00
=> FilePath -- ^ Path to the unpacked stack bindist (where the executable resides)
-> InstallDirResolved
-> Version
2021-09-11 16:28:11 +00:00
-> Bool -- ^ Force install
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installStackUnpacked path installDir ver forceInstall = do
2021-08-30 20:41:58 +00:00
lift $ logInfo "Installing stack"
2021-07-23 11:13:43 +00:00
let stackFile = "stack"
liftIO $ createDirRecursive' (fromInstallDir installDir)
2021-08-11 10:24:51 +00:00
let destFileName = stackFile
<> (case installDir of
IsolateDirResolved _ -> ""
GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver
)
2021-08-11 10:24:51 +00:00
<> exeExt
destPath = fromInstallDir installDir </> destFileName
2021-09-11 16:28:11 +00:00
unless forceInstall
(liftE $ throwIfFileAlreadyExists destPath)
2021-09-25 15:27:02 +00:00
copyFileE
2021-07-23 11:13:43 +00:00
(path </> stackFile <> exeExt)
destPath
lift $ chmod_755 destPath
2020-01-11 20:15:05 +00:00
---------------------
--[ Set GHC/cabal ]--
---------------------
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | Set GHC symlinks in @~\/.ghcup\/bin@ for the requested GHC version. The behavior depends
2020-01-11 20:15:05 +00:00
-- on `SetGHC`:
--
2020-07-21 23:08:58 +00:00
-- * SetGHCOnly: @~\/.ghcup\/bin\/ghc -> ~\/.ghcup\/ghc\/\<ver\>\/bin\/ghc@
-- * SetGHC_XY: @~\/.ghcup\/bin\/ghc-X.Y -> ~\/.ghcup\/ghc\/\<ver\>\/bin\/ghc@
-- * SetGHC_XYZ: @~\/.ghcup\/bin\/ghc-\<ver\> -> ~\/.ghcup\/ghc\/\<ver\>\/bin\/ghc@
2020-01-11 20:15:05 +00:00
--
2020-07-21 23:08:58 +00:00
-- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\<ver\>\/share symlink@
-- for 'SetGHCOnly' constructor.
setGHC :: ( MonadReader env m
, HasDirs env
2021-08-30 20:41:58 +00:00
, HasLog env
2020-08-06 11:28:20 +00:00
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadCatch m
2021-05-14 21:09:45 +00:00
, MonadMask m
, MonadUnliftIO m
2020-08-06 11:28:20 +00:00
)
2020-04-25 10:06:41 +00:00
=> GHCTargetVersion
2020-01-11 20:15:05 +00:00
-> SetGHC
2022-02-09 17:57:59 +00:00
-> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin
-- and don't want mess with other versions
2020-04-25 10:06:41 +00:00
-> Excepts '[NotInstalled] m GHCTargetVersion
2022-02-09 17:57:59 +00:00
setGHC ver sghc mBinDir = do
2021-05-14 21:09:45 +00:00
let verS = T.unpack $ prettyVer (_tvVersion ver)
2020-08-06 11:28:20 +00:00
ghcdir <- lift $ ghcupGHCDir ver
2020-01-11 20:15:05 +00:00
2021-03-11 16:03:51 +00:00
whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver))
2020-01-11 20:15:05 +00:00
-- symlink destination
2022-02-09 17:57:59 +00:00
binDir <- case mBinDir of
Just x -> pure x
Nothing -> do
Dirs {binDir = f} <- lift getDirs
pure f
2020-01-11 20:15:05 +00:00
-- first delete the old symlinks (this fixes compatibility issues
-- with old ghcup)
2022-02-10 20:49:19 +00:00
when (isNothing mBinDir) $
2022-02-09 17:57:59 +00:00
case sghc of
SetGHCOnly -> liftE $ rmPlainGHC (_tvTarget ver)
SetGHC_XY -> liftE $ rmMajorGHCSymlinks ver
SetGHC_XYZ -> liftE $ rmMinorGHCSymlinks ver
2020-01-11 20:15:05 +00:00
-- for ghc tools (ghc, ghci, haddock, ...)
verfiles <- ghcToolFiles ver
forM_ verfiles $ \file -> do
2020-08-06 11:28:20 +00:00
mTargetFile <- case sghc of
SetGHCOnly -> pure $ Just file
2020-01-11 20:15:05 +00:00
SetGHC_XY -> do
2021-05-14 21:09:45 +00:00
handle
2021-08-30 20:41:58 +00:00
(\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)
$ do
2021-05-14 21:09:45 +00:00
(mj, mi) <- getMajorMinorV (_tvVersion ver)
let major' = intToText mj <> "." <> intToText mi
pure $ Just (file <> "-" <> T.unpack major')
2020-08-06 11:28:20 +00:00
SetGHC_XYZ ->
2021-05-14 21:09:45 +00:00
pure $ Just (file <> "-" <> verS)
2020-01-11 20:15:05 +00:00
-- create symlink
2021-11-12 00:04:27 +00:00
forM_ mTargetFile $ \targetFile -> do
2022-02-05 18:11:56 +00:00
bindir <- ghcInternalBinDir ver
2021-05-14 21:09:45 +00:00
let fullF = binDir </> targetFile <> exeExt
2022-02-05 18:11:56 +00:00
fileWithExt = bindir </> file <> exeExt
2022-02-09 17:57:59 +00:00
destL <- binarySymLinkDestination binDir fileWithExt
2021-05-14 21:09:45 +00:00
lift $ createLink destL fullF
2020-01-11 20:15:05 +00:00
2022-02-10 20:49:19 +00:00
when (isNothing mBinDir) $ do
2022-02-09 17:57:59 +00:00
-- create symlink for share dir
when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verS
2020-01-11 20:15:05 +00:00
2022-02-09 17:57:59 +00:00
when (sghc == SetGHCOnly) $ lift warnAboutHlsCompatibility
pure ver
2020-01-11 20:15:05 +00:00
where
symlinkShareDir :: ( MonadReader env m
, HasDirs env
, MonadIO m
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadCatch m
, MonadMask m
)
2021-05-14 21:09:45 +00:00
=> FilePath
-> String
2020-01-11 20:15:05 +00:00
-> m ()
2021-05-14 21:09:45 +00:00
symlinkShareDir ghcdir ver' = do
Dirs {..} <- getDirs
let destdir = baseDir
2020-01-11 20:15:05 +00:00
case sghc of
SetGHCOnly -> do
2021-05-14 21:09:45 +00:00
let sharedir = "share"
2020-01-11 20:15:05 +00:00
let fullsharedir = ghcdir </> sharedir
logDebug $ "Checking for sharedir existence: " <> T.pack fullsharedir
2020-01-11 20:15:05 +00:00
whenM (liftIO $ doesDirectoryExist fullsharedir) $ do
let fullF = destdir </> sharedir
2021-05-14 21:09:45 +00:00
let targetF = "." </> "ghc" </> ver' </> sharedir
2021-08-30 20:41:58 +00:00
logDebug $ "rm -f " <> T.pack fullF
hideError doesNotExistErrorType $ rmDirectoryLink fullF
2021-08-30 20:41:58 +00:00
logDebug $ "ln -s " <> T.pack targetF <> " " <> T.pack fullF
2021-10-17 18:39:49 +00:00
if isWindows
then liftIO
-- On windows we need to be more permissive
-- in case symlinks can't be created, be just
-- give up here. This symlink isn't strictly necessary.
$ hideError permissionErrorType
$ hideError illegalOperationErrorType
$ createDirectoryLink targetF fullF
else liftIO
$ createDirectoryLink targetF fullF
2020-01-11 20:15:05 +00:00
_ -> pure ()
2021-09-19 11:50:51 +00:00
unsetGHC :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadMask m
)
=> Maybe Text
-> Excepts '[NotInstalled] m ()
2022-02-05 00:53:04 +00:00
unsetGHC = rmPlainGHC
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | Set the @~\/.ghcup\/bin\/cabal@ symlink.
2021-05-14 21:09:45 +00:00
setCabal :: ( MonadMask m
, MonadReader env m
, HasDirs env
2021-08-30 20:41:58 +00:00
, HasLog env
2021-05-14 21:09:45 +00:00
, MonadFail m
, MonadIO m
, MonadUnliftIO m)
=> Version
-> Excepts '[NotInstalled] m ()
setCabal ver = do
2021-05-14 21:09:45 +00:00
let targetFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
-- symlink destination
Dirs {..} <- lift getDirs
2021-03-11 16:03:51 +00:00
whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile))
$ throwE
$ NotInstalled Cabal (GHCTargetVersion Nothing ver)
2021-05-14 21:09:45 +00:00
let cabalbin = binDir </> "cabal" <> exeExt
2021-05-14 21:09:45 +00:00
-- create link
let destL = targetFile
lift $ createLink destL cabalbin
pure ()
2021-09-19 11:50:51 +00:00
unsetCabal :: ( MonadMask m
, MonadReader env m
, HasDirs env
, MonadIO m)
=> m ()
unsetCabal = do
Dirs {..} <- getDirs
let cabalbin = binDir </> "cabal" <> exeExt
hideError doesNotExistErrorType $ rmLink cabalbin
-- | Set the haskell-language-server symlinks.
2021-09-19 11:50:51 +00:00
setHLS :: ( MonadReader env m
, HasDirs env
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadIO m
2021-05-14 21:09:45 +00:00
, MonadMask m
2021-09-19 11:50:51 +00:00
, MonadFail m
2021-05-14 21:09:45 +00:00
, MonadUnliftIO m
)
=> Version
-> SetHLS
2022-02-09 17:57:59 +00:00
-> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin
-- and don't want mess with other versions
-> Excepts '[NotInstalled] m ()
2022-02-09 17:57:59 +00:00
setHLS ver shls mBinDir = do
2022-02-05 00:53:04 +00:00
whenM (lift $ not <$> hlsInstalled ver) (throwE (NotInstalled HLS (GHCTargetVersion Nothing ver)))
-- symlink destination
2022-02-09 17:57:59 +00:00
binDir <- case mBinDir of
Just x -> pure x
Nothing -> do
Dirs {binDir = f} <- lift getDirs
pure f
2022-02-05 00:53:04 +00:00
-- first delete the old symlinks
2022-02-10 20:49:19 +00:00
when (isNothing mBinDir) $
2022-02-09 17:57:59 +00:00
case shls of
-- not for legacy
SetHLS_XYZ -> liftE $ rmMinorHLSSymlinks ver
-- legacy and new
SetHLSOnly -> liftE rmPlainHLS
2022-02-05 00:53:04 +00:00
case shls of
-- not for legacy
SetHLS_XYZ -> do
2022-02-05 18:11:56 +00:00
bins <- lift $ hlsInternalServerScripts ver Nothing
2022-02-05 00:53:04 +00:00
forM_ bins $ \f -> do
2022-02-05 18:11:56 +00:00
let fname = takeFileName f
2022-02-09 17:57:59 +00:00
destL <- binarySymLinkDestination binDir f
2022-02-05 18:11:56 +00:00
let target = if "haskell-language-server-wrapper" `isPrefixOf` fname
then fname <> "-" <> T.unpack (prettyVer ver) <> exeExt
else fname <> "~" <> T.unpack (prettyVer ver) <> exeExt
2022-02-05 00:53:04 +00:00
lift $ createLink destL (binDir </> target)
2022-02-05 00:53:04 +00:00
-- legacy and new
SetHLSOnly -> do
-- set haskell-language-server-<ghcver> symlinks
bins <- lift $ hlsServerBinaries ver Nothing
when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver)
2022-02-05 00:53:04 +00:00
forM_ bins $ \f -> do
let destL = f
let target = (<> exeExt) . head . splitOn "~" $ f
lift $ createLink destL (binDir </> target)
2022-02-05 00:53:04 +00:00
-- set haskell-language-server-wrapper symlink
let destL = "haskell-language-server-wrapper-" <> T.unpack (prettyVer ver) <> exeExt
let wrapper = binDir </> "haskell-language-server-wrapper" <> exeExt
2022-02-05 00:53:04 +00:00
lift $ createLink destL wrapper
2022-02-10 20:49:19 +00:00
when (isNothing mBinDir) $
2022-02-09 17:57:59 +00:00
lift warnAboutHlsCompatibility
2021-09-19 11:50:51 +00:00
unsetHLS :: ( MonadMask m
, MonadReader env m
, HasDirs env
, MonadIO m)
=> m ()
unsetHLS = do
Dirs {..} <- getDirs
let wrapper = binDir </> "haskell-language-server-wrapper" <> exeExt
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles'
binDir
(MP.chunk "haskell-language-server-" <* pvp' <* MP.chunk (T.pack exeExt) <* MP.eof)
forM_ bins (hideError doesNotExistErrorType . rmLink . (binDir </>))
hideError doesNotExistErrorType $ rmLink wrapper
2021-05-14 22:31:36 +00:00
-- | Set the @~\/.ghcup\/bin\/stack@ symlink.
2021-05-14 21:09:45 +00:00
setStack :: ( MonadMask m
, MonadReader env m
, HasDirs env
2021-08-30 20:41:58 +00:00
, HasLog env
2021-05-14 21:09:45 +00:00
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadUnliftIO m
)
2021-05-14 22:31:36 +00:00
=> Version
-> Excepts '[NotInstalled] m ()
setStack ver = do
2021-05-14 21:09:45 +00:00
let targetFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
2021-05-14 22:31:36 +00:00
-- symlink destination
Dirs {..} <- lift getDirs
2021-05-14 22:31:36 +00:00
whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile))
$ throwE
$ NotInstalled Stack (GHCTargetVersion Nothing ver)
2021-05-14 21:09:45 +00:00
let stackbin = binDir </> "stack" <> exeExt
2021-05-14 22:31:36 +00:00
2021-05-14 21:09:45 +00:00
lift $ createLink targetFile stackbin
2021-05-14 22:31:36 +00:00
pure ()
2021-09-19 11:50:51 +00:00
unsetStack :: ( MonadMask m
, MonadReader env m
, HasDirs env
, MonadIO m)
=> m ()
unsetStack = do
Dirs {..} <- getDirs
let stackbin = binDir </> "stack" <> exeExt
hideError doesNotExistErrorType $ rmLink stackbin
-- | Warn if the installed and set HLS is not compatible with the installed and
-- set GHC version.
warnAboutHlsCompatibility :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadThrow m
, MonadCatch m
, MonadIO m
)
=> m ()
warnAboutHlsCompatibility = do
supportedGHC <- hlsGHCVersions
currentGHC <- fmap _tvVersion <$> ghcSet Nothing
currentHLS <- hlsSet
case (currentGHC, currentHLS) of
(Just gv, Just hv) | gv `notElem` supportedGHC -> do
2021-09-14 10:36:14 +00:00
logWarn $
"GHC " <> T.pack (prettyShow gv) <> " is not compatible with " <>
"Haskell Language Server " <> T.pack (prettyShow hv) <> "." <> "\n" <>
"Haskell IDE support may not work until this is fixed." <> "\n" <>
"Install a different HLS version, or install and set one of the following GHCs:" <> "\n" <>
T.pack (prettyShow supportedGHC)
_ -> return ()
2020-01-11 20:15:05 +00:00
------------------
--[ List tools ]--
------------------
2020-07-21 23:08:58 +00:00
-- | Filter data type for 'listVersions'.
2020-01-11 20:15:05 +00:00
data ListCriteria = ListInstalled
| ListSet
2021-09-24 18:49:32 +00:00
| ListAvailable
2020-01-11 20:15:05 +00:00
deriving Show
2020-07-21 23:08:58 +00:00
-- | A list result describes a single tool version
-- and various of its properties.
2020-01-11 20:15:05 +00:00
data ListResult = ListResult
{ lTool :: Tool
, lVer :: Version
2020-04-25 10:06:41 +00:00
, lCross :: Maybe Text -- ^ currently only for GHC
2020-01-11 20:15:05 +00:00
, lTag :: [Tag]
, lInstalled :: Bool
2020-04-21 21:37:48 +00:00
, lSet :: Bool -- ^ currently active version
, fromSrc :: Bool -- ^ compiled from source
, lStray :: Bool -- ^ not in download info
, lNoBindist :: Bool -- ^ whether the version is available for this platform/arch
, hlsPowered :: Bool
2020-01-11 20:15:05 +00:00
}
2020-04-21 21:37:48 +00:00
deriving (Eq, Ord, Show)
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | Extract all available tool versions and their tags.
availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version VersionInfo
2020-04-21 21:37:48 +00:00
availableToolVersions av tool = view
(at tool % non Map.empty)
2020-01-11 20:15:05 +00:00
av
2020-04-21 21:37:48 +00:00
-- | List all versions from the download info, as well as stray
-- versions.
listVersions :: ( MonadCatch m
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadThrow m
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadIO m
, MonadReader env m
, HasDirs env
, HasPlatformReq env
, HasGHCupInfo env
)
2021-05-14 21:09:45 +00:00
=> Maybe Tool
2020-01-11 20:15:05 +00:00
-> Maybe ListCriteria
2020-07-13 16:27:21 +00:00
-> m [ListResult]
2021-05-14 21:09:45 +00:00
listVersions lt' criteria = do
-- some annoying work to avoid too much repeated IO
cSet <- cabalSet
2021-06-12 20:26:50 +00:00
cabals <- getInstalledCabals
hlsSet' <- hlsSet
hlses <- getInstalledHLSs
2021-05-14 22:31:36 +00:00
sSet <- stackSet
stacks <- getInstalledStacks
2021-05-14 22:31:36 +00:00
go lt' cSet cabals hlsSet' hlses sSet stacks
2020-01-11 20:15:05 +00:00
where
2021-05-14 22:31:36 +00:00
go lt cSet cabals hlsSet' hlses sSet stacks = do
case lt of
Just t -> do
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
-- get versions from GHCupDownloads
2021-05-14 21:09:45 +00:00
let avTools = availableToolVersions dls t
2021-05-14 22:31:36 +00:00
lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks)
case t of
GHC -> do
slr <- strayGHCs avTools
pure (sort (slr ++ lr))
Cabal -> do
slr <- strayCabals avTools cSet cabals
pure (sort (slr ++ lr))
HLS -> do
2021-07-20 09:54:14 +00:00
slr <- strayHLS avTools hlsSet' hlses
pure (sort (slr ++ lr))
2021-05-14 22:31:36 +00:00
Stack -> do
2021-07-20 09:54:14 +00:00
slr <- strayStacks avTools sSet stacks
2021-05-14 22:31:36 +00:00
pure (sort (slr ++ lr))
GHCup -> do
2021-07-28 20:36:59 +00:00
let cg = maybeToList $ currentGHCup avTools
pure (sort (cg ++ lr))
Nothing -> do
2021-05-14 22:31:36 +00:00
ghcvers <- go (Just GHC) cSet cabals hlsSet' hlses sSet stacks
cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses sSet stacks
hlsvers <- go (Just HLS) cSet cabals hlsSet' hlses sSet stacks
ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses sSet stacks
stackvers <- go (Just Stack) cSet cabals hlsSet' hlses sSet stacks
pure (ghcvers <> cabalvers <> hlsvers <> stackvers <> ghcupvers)
strayGHCs :: ( MonadCatch m
, MonadReader env m
, HasDirs env
, MonadThrow m
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadIO m
)
=> Map.Map Version VersionInfo
2020-04-21 21:37:48 +00:00
-> m [ListResult]
strayGHCs avTools = do
2020-04-25 10:06:41 +00:00
ghcs <- getInstalledGHCs
fmap catMaybes $ forM ghcs $ \case
Right tver@GHCTargetVersion{ _tvTarget = Nothing, .. } -> do
case Map.lookup _tvVersion avTools of
Just _ -> pure Nothing
Nothing -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing
fromSrc <- ghcSrcInstalled tver
2021-03-11 16:03:51 +00:00
hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions
2020-04-25 10:06:41 +00:00
pure $ Just $ ListResult
{ lTool = GHC
, lVer = _tvVersion
, lCross = Nothing
, lTag = []
, lInstalled = True
2021-03-11 16:03:51 +00:00
, lStray = isNothing (Map.lookup _tvVersion avTools)
, lNoBindist = False
2020-04-25 10:06:41 +00:00
, ..
}
Right tver@GHCTargetVersion{ .. } -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget
fromSrc <- ghcSrcInstalled tver
2021-03-11 16:03:51 +00:00
hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions
2020-04-25 10:06:41 +00:00
pure $ Just $ ListResult
{ lTool = GHC
, lVer = _tvVersion
, lCross = _tvTarget
, lTag = []
, lInstalled = True
, lStray = True -- NOTE: cross currently cannot be installed via bindist
, lNoBindist = False
2020-04-25 10:06:41 +00:00
, ..
}
Left e -> do
2021-08-30 20:41:58 +00:00
logWarn
2021-08-25 16:54:58 +00:00
$ "Could not parse version of stray directory" <> T.pack e
2020-04-25 10:06:41 +00:00
pure Nothing
strayCabals :: ( MonadReader env m
, HasDirs env
, MonadCatch m
, MonadThrow m
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadIO m
)
=> Map.Map Version VersionInfo
-> Maybe Version
2021-05-14 21:09:45 +00:00
-> [Either FilePath Version]
2020-08-14 14:53:32 +00:00
-> m [ListResult]
strayCabals avTools cSet cabals = do
2020-08-14 14:53:32 +00:00
fmap catMaybes $ forM cabals $ \case
Right ver ->
case Map.lookup ver avTools of
Just _ -> pure Nothing
Nothing -> do
let lSet = cSet == Just ver
2020-08-14 14:53:32 +00:00
pure $ Just $ ListResult
{ lTool = Cabal
, lVer = ver
, lCross = Nothing
, lTag = []
, lInstalled = True
2021-03-11 16:03:51 +00:00
, lStray = isNothing (Map.lookup ver avTools)
2020-08-14 14:53:32 +00:00
, lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False
, ..
}
Left e -> do
2021-08-30 20:41:58 +00:00
logWarn
2021-08-25 16:54:58 +00:00
$ "Could not parse version of stray directory" <> T.pack e
pure Nothing
strayHLS :: ( MonadReader env m
, HasDirs env
, MonadCatch m
, MonadThrow m
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadIO m)
=> Map.Map Version VersionInfo
2021-07-20 09:54:14 +00:00
-> Maybe Version
-> [Either FilePath Version]
-> m [ListResult]
2021-07-20 09:54:14 +00:00
strayHLS avTools hlsSet' hlss = do
fmap catMaybes $ forM hlss $ \case
Right ver ->
case Map.lookup ver avTools of
Just _ -> pure Nothing
Nothing -> do
2021-07-20 09:54:14 +00:00
let lSet = hlsSet' == Just ver
pure $ Just $ ListResult
{ lTool = HLS
, lVer = ver
, lCross = Nothing
, lTag = []
, lInstalled = True
2021-03-11 16:03:51 +00:00
, lStray = isNothing (Map.lookup ver avTools)
, lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False
2020-08-14 14:53:32 +00:00
, ..
}
Left e -> do
2021-08-30 20:41:58 +00:00
logWarn
2021-08-25 16:54:58 +00:00
$ "Could not parse version of stray directory" <> T.pack e
2020-08-14 14:53:32 +00:00
pure Nothing
strayStacks :: ( MonadReader env m
, HasDirs env
, MonadCatch m
, MonadThrow m
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadIO m
)
=> Map.Map Version VersionInfo
2021-07-20 09:54:14 +00:00
-> Maybe Version
-> [Either FilePath Version]
2021-05-14 22:31:36 +00:00
-> m [ListResult]
2021-07-20 09:54:14 +00:00
strayStacks avTools stackSet' stacks = do
2021-05-14 22:31:36 +00:00
fmap catMaybes $ forM stacks $ \case
Right ver ->
case Map.lookup ver avTools of
Just _ -> pure Nothing
Nothing -> do
2021-07-20 09:54:14 +00:00
let lSet = stackSet' == Just ver
2021-05-14 22:31:36 +00:00
pure $ Just $ ListResult
{ lTool = Stack
, lVer = ver
, lCross = Nothing
, lTag = []
, lInstalled = True
, lStray = isNothing (Map.lookup ver avTools)
, lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False
, ..
}
Left e -> do
2021-08-30 20:41:58 +00:00
logWarn
2021-08-25 16:54:58 +00:00
$ "Could not parse version of stray directory" <> T.pack e
2021-05-14 22:31:36 +00:00
pure Nothing
2021-07-28 20:36:59 +00:00
currentGHCup :: Map.Map Version VersionInfo -> Maybe ListResult
currentGHCup av =
2021-11-02 00:22:06 +00:00
let currentVer = fromJust $ pvpToVersion ghcUpVer ""
listVer = Map.lookup currentVer av
latestVer = fst <$> headOf (getTagged Latest) av
recommendedVer = fst <$> headOf (getTagged Latest) av
isOld = maybe True (> currentVer) latestVer && maybe True (> currentVer) recommendedVer
2021-07-28 20:48:28 +00:00
in if | Map.member currentVer av -> Nothing
| otherwise -> Just $ ListResult { lVer = currentVer
, lTag = maybe (if isOld then [Old] else []) _viTags listVer
, lCross = Nothing
, lTool = GHCup
, fromSrc = False
, lStray = isNothing listVer
, lSet = True
, lInstalled = True
, lNoBindist = False
, hlsPowered = False
}
2020-04-25 10:06:41 +00:00
-- NOTE: this are not cross ones, because no bindists
2021-08-30 20:41:58 +00:00
toListResult :: ( HasLog env
, MonadReader env m
, HasDirs env
, HasGHCupInfo env
, HasPlatformReq env
, MonadIO m
, MonadCatch m
)
=> Tool
-> Maybe Version
2021-05-14 21:09:45 +00:00
-> [Either FilePath Version]
-> Maybe Version
2021-05-14 21:09:45 +00:00
-> [Either FilePath Version]
2021-05-14 22:31:36 +00:00
-> Maybe Version
2021-05-14 21:09:45 +00:00
-> [Either FilePath Version]
-> (Version, VersionInfo)
-> m ListResult
toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, _viTags -> tags) = do
2021-05-14 21:09:45 +00:00
case t of
GHC -> do
2021-07-19 14:49:18 +00:00
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v
2021-05-14 21:09:45 +00:00
let tver = mkTVer v
lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing
lInstalled <- ghcInstalled tver
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem v) hlsGHCVersions
pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. }
Cabal -> do
2021-07-19 14:49:18 +00:00
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Cabal v
2021-05-14 21:09:45 +00:00
let lSet = cSet == Just v
let lInstalled = elem v $ rights cabals
pure ListResult { lVer = v
, lCross = Nothing
, lTag = tags
, lTool = t
, fromSrc = False
, lStray = False
, hlsPowered = False
, ..
}
GHCup -> do
let lSet = prettyPVP ghcUpVer == prettyVer v
let lInstalled = lSet
pure ListResult { lVer = v
, lTag = tags
, lCross = Nothing
, lTool = t
, fromSrc = False
, lStray = False
, lNoBindist = False
, hlsPowered = False
, ..
}
HLS -> do
2021-07-19 14:49:18 +00:00
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo HLS v
2021-05-14 21:09:45 +00:00
let lSet = hlsSet' == Just v
let lInstalled = elem v $ rights hlses
pure ListResult { lVer = v
, lCross = Nothing
, lTag = tags
, lTool = t
, fromSrc = False
, lStray = False
, hlsPowered = False
, ..
}
Stack -> do
2021-07-19 14:49:18 +00:00
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Stack v
2021-05-14 21:09:45 +00:00
let lSet = stackSet' == Just v
let lInstalled = elem v $ rights stacks
pure ListResult { lVer = v
, lCross = Nothing
, lTag = tags
, lTool = t
, fromSrc = False
, lStray = False
, hlsPowered = False
, ..
}
2020-01-11 20:15:05 +00:00
filter' :: [ListResult] -> [ListResult]
filter' lr = case criteria of
Nothing -> lr
Just ListInstalled -> filter (\ListResult {..} -> lInstalled) lr
Just ListSet -> filter (\ListResult {..} -> lSet) lr
2021-09-24 18:49:32 +00:00
Just ListAvailable -> filter (\ListResult {..} -> not lNoBindist) lr
2020-01-11 20:15:05 +00:00
--------------------
--[ GHC/cabal rm ]--
--------------------
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | Delete a ghc version and all its symlinks.
--
-- This may leave GHCup without a "set" version.
-- Will try to fix the ghc-x.y symlink after removal (e.g. to an
-- older version).
rmGHCVer :: ( MonadReader env m
, HasDirs env
2020-08-06 11:28:20 +00:00
, MonadThrow m
2021-08-30 20:41:58 +00:00
, HasLog env
2020-08-06 11:28:20 +00:00
, MonadIO m
, MonadFail m
, MonadCatch m
2021-05-14 21:09:45 +00:00
, MonadMask m
, MonadUnliftIO m
2020-08-06 11:28:20 +00:00
)
2020-04-25 10:06:41 +00:00
=> GHCTargetVersion
2020-01-11 20:15:05 +00:00
-> Excepts '[NotInstalled] m ()
rmGHCVer ver = do
2021-03-11 16:03:51 +00:00
isSetGHC <- lift $ fmap (== Just ver) $ ghcSet (_tvTarget ver)
whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC ver))
dir <- lift $ ghcupGHCDir ver
-- this isn't atomic, order matters
when isSetGHC $ do
2021-08-30 20:41:58 +00:00
lift $ logInfo "Removing ghc symlinks"
2022-02-05 00:53:04 +00:00
liftE $ rmPlainGHC (_tvTarget ver)
2021-08-30 20:41:58 +00:00
lift $ logInfo "Removing ghc-x.y.z symlinks"
2022-02-05 00:53:04 +00:00
liftE $ rmMinorGHCSymlinks ver
2021-08-30 20:41:58 +00:00
lift $ logInfo "Removing/rewiring ghc-x.y symlinks"
-- first remove
2022-02-05 00:53:04 +00:00
handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorGHCSymlinks ver
-- then fix them (e.g. with an earlier version)
2021-08-30 20:41:58 +00:00
lift $ logInfo $ "Removing directory recursively: " <> T.pack dir
2021-07-22 13:45:08 +00:00
lift $ recyclePathForcibly dir
v' <-
handle
2021-08-30 20:41:58 +00:00
(\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)
$ fmap Just
$ getMajorMinorV (_tvVersion ver)
forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) (_tvTarget ver))
2022-02-09 17:57:59 +00:00
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing)
Dirs {..} <- lift getDirs
2021-07-22 13:45:08 +00:00
lift $ hideError doesNotExistErrorType $ rmDirectoryLink (baseDir </> "share")
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | Delete a cabal version. Will try to fix the @cabal@ symlink
-- after removal (e.g. setting it to an older version).
2021-05-14 21:09:45 +00:00
rmCabalVer :: ( MonadMask m
, MonadReader env m
, HasDirs env
2021-05-14 21:09:45 +00:00
, MonadThrow m
2021-08-30 20:41:58 +00:00
, HasLog env
2021-05-14 21:09:45 +00:00
, MonadIO m
, MonadFail m
, MonadCatch m
, MonadUnliftIO m
)
=> Version
-> Excepts '[NotInstalled] m ()
rmCabalVer ver = do
whenM (lift $ fmap not $ cabalInstalled ver) $ throwE (NotInstalled Cabal (GHCTargetVersion Nothing ver))
2021-03-11 16:03:51 +00:00
cSet <- lift cabalSet
Dirs {..} <- lift getDirs
2021-05-14 21:09:45 +00:00
let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
2021-07-22 13:45:08 +00:00
lift $ hideError doesNotExistErrorType $ recycleFile (binDir </> cabalFile)
2021-03-11 16:03:51 +00:00
when (Just ver == cSet) $ do
cVers <- lift $ fmap rights getInstalledCabals
case headMay . reverse . sort $ cVers of
Just latestver -> setCabal latestver
Nothing -> lift $ rmLink (binDir </> "cabal" <> exeExt)
2020-01-11 20:15:05 +00:00
-- | Delete a hls version. Will try to fix the hls symlinks
-- after removal (e.g. setting it to an older version).
2021-05-14 21:09:45 +00:00
rmHLSVer :: ( MonadMask m
, MonadReader env m
, HasDirs env
2021-05-14 21:09:45 +00:00
, MonadThrow m
2021-08-30 20:41:58 +00:00
, HasLog env
2021-05-14 21:09:45 +00:00
, MonadIO m
, MonadFail m
, MonadCatch m
, MonadUnliftIO m
)
=> Version
-> Excepts '[NotInstalled] m ()
rmHLSVer ver = do
whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (GHCTargetVersion Nothing ver))
2022-02-05 00:53:04 +00:00
isHlsSet <- lift hlsSet
2022-02-05 00:53:04 +00:00
liftE $ rmMinorHLSSymlinks ver
hlsDir <- ghcupHLSDir ver
recyclePathForcibly hlsDir
2021-03-11 16:03:51 +00:00
when (Just ver == isHlsSet) $ do
-- delete all set symlinks
2022-02-05 00:53:04 +00:00
rmPlainHLS
-- set latest hls
2021-03-11 16:03:51 +00:00
hlsVers <- lift $ fmap rights getInstalledHLSs
case headMay . reverse . sort $ hlsVers of
2022-02-09 17:57:59 +00:00
Just latestver -> setHLS latestver SetHLSOnly Nothing
Nothing -> pure ()
2021-05-14 22:31:36 +00:00
-- | Delete a stack version. Will try to fix the @stack@ symlink
-- after removal (e.g. setting it to an older version).
2021-05-14 21:09:45 +00:00
rmStackVer :: ( MonadMask m
, MonadReader env m
, HasDirs env
2021-05-14 21:09:45 +00:00
, MonadThrow m
2021-08-30 20:41:58 +00:00
, HasLog env
2021-05-14 21:09:45 +00:00
, MonadIO m
, MonadFail m
, MonadCatch m
, MonadUnliftIO m
)
2021-05-14 22:31:36 +00:00
=> Version
-> Excepts '[NotInstalled] m ()
rmStackVer ver = do
whenM (lift $ fmap not $ stackInstalled ver) $ throwE (NotInstalled Stack (GHCTargetVersion Nothing ver))
sSet <- lift stackSet
Dirs {..} <- lift getDirs
2021-05-14 22:31:36 +00:00
2021-05-14 21:09:45 +00:00
let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
2021-07-22 13:45:08 +00:00
lift $ hideError doesNotExistErrorType $ recycleFile (binDir </> stackFile)
2021-05-14 22:31:36 +00:00
when (Just ver == sSet) $ do
sVers <- lift $ fmap rights getInstalledStacks
case headMay . reverse . sort $ sVers of
Just latestver -> setStack latestver
Nothing -> lift $ rmLink (binDir </> "stack" <> exeExt)
2021-05-14 22:31:36 +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
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadMask m
2021-07-22 13:45:08 +00:00
, MonadUnliftIO m
)
=> m ()
rmGhcup = do
Dirs { .. } <- getDirs
let ghcupFilename = "ghcup" <> exeExt
let ghcupFilepath = binDir </> ghcupFilename
2021-06-15 12:00:30 +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
2021-07-02 21:26:07 +00:00
(handlePathNotPresent ghcupFilepath)
(liftIO $ canonicalizePath ghcupFilepath)
let areEqualPaths = equalFilePath p1 p2
2021-08-30 20:41:58 +00:00
unless areEqualPaths $ logWarn $ nonStandardInstallLocationMsg currentRunningExecPath
2021-07-02 21:26:07 +00:00
2021-10-17 18:39:49 +00:00
if isWindows
then do
-- since it doesn't seem possible to delete a running exe on windows
-- we move it to temp dir, to be deleted at next reboot
tempFilepath <- mkGhcupTmpDir
hideError UnsupportedOperation $
liftIO $ hideError NoSuchThing $
moveFile ghcupFilepath (tempFilepath </> "ghcup")
else
-- delete it.
hideError doesNotExistErrorType $ rmFile ghcupFilepath
where
handlePathNotPresent fp _err = do
2021-08-30 20:41:58 +00:00
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."
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 ] m ()
rmTool ListResult {lVer, lTool, lCross} = do
case lTool of
2021-07-02 21:26:07 +00:00
GHC ->
let ghcTargetVersion = GHCTargetVersion lCross lVer
2021-07-02 21:26:07 +00:00
in rmGHCVer ghcTargetVersion
HLS -> rmHLSVer lVer
Cabal -> rmCabalVer lVer
Stack -> rmStackVer lVer
GHCup -> 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
} <- getDirs
let envFilePath = 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
2021-07-22 13:45:08 +00:00
handleRm $ rmDir logsDir
2021-07-29 09:51:47 +00:00
handleRm $ rmDir cacheDir
2021-07-22 13:45:08 +00:00
handleRm $ rmBinDir binDir
handleRm $ rmDir recycleDir
2021-10-17 18:39:49 +00:00
when isWindows $ do
logInfo $ "removing " <> T.pack (baseDir </> "msys64")
handleRm $ rmPathForcibly (baseDir </> "msys64")
2021-07-22 13:45:08 +00:00
handleRm $ removeEmptyDirsRecursive 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 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"
2021-07-26 15:44:37 +00:00
hideErrorDef [permissionErrorType] () $ deleteFile 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"
2021-07-26 15:44:37 +00:00
hideErrorDef [permissionErrorType] () $ deleteFile confFilePath
2021-08-30 20:41:58 +00:00
rmDir :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
2021-07-15 11:32:48 +00:00
rmDir dir =
-- 'getDirectoryContentsRecursive' is lazy IO. In case
-- an error leaks through, we catch it here as well,
-- althought 'deleteFile' should already handle it.
hideErrorDef [doesNotExistErrorType] () $ do
2021-08-30 20:41:58 +00:00
logInfo $ "removing " <> T.pack dir
2021-07-15 11:32:48 +00:00
contents <- liftIO $ getDirectoryContentsRecursive dir
forM_ contents (deleteFile . (dir </>))
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
if not isXDGStyle
then removeDirIfEmptyOrIsSymlink binDir
else pure ()
2021-07-02 21:26:07 +00:00
reportRemainingFiles :: MonadIO m => FilePath -> m [FilePath]
reportRemainingFiles dir = do
2021-07-15 11:32:48 +00:00
-- force the files so the errors don't leak
(force -> !remainingFiles) <- liftIO
(getDirectoryContentsRecursive dir >>= evaluate)
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)
removeEmptyDirsRecursive :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
2021-07-02 21:26:07 +00:00
removeEmptyDirsRecursive fp = do
cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
2021-07-02 21:26:07 +00:00
forM_ cs removeEmptyDirsRecursive
hideError InappropriateType $ removeDirIfEmptyOrIsSymlink fp
-- we expect only files inside cache/log dir
-- we report remaining files/dirs later,
-- hence the force/quiet mode in these delete functions below.
deleteFile :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m) => FilePath -> m ()
deleteFile filepath = do
2021-07-15 11:32:48 +00:00
hideError doesNotExistErrorType
$ hideError InappropriateType $ rmFile filepath
removeDirIfEmptyOrIsSymlink :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
removeDirIfEmptyOrIsSymlink filepath =
hideError UnsatisfiedConstraints $
handleIO' InappropriateType
(handleIfSym filepath)
2021-07-22 13:45:08 +00:00
(liftIO $ rmDirectory filepath)
where
handleIfSym fp e = do
isSym <- liftIO $ pathIsSymbolicLink fp
if isSym
then deleteFile fp
else liftIO $ ioError e
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 = baseDir
let diBinDir = binDir
diGHCDir <- lift ghcupGHCBaseDir
let diCacheDir = 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 { .. }
---------------
--[ Compile ]--
---------------
2020-07-22 00:34:17 +00:00
-- | Compile a GHC from source. This behaves wrt symlinks and installation
2020-07-21 23:08:58 +00:00
-- the same as 'installGHCBin'.
2020-01-11 20:15:05 +00:00
compileGHC :: ( MonadMask m
, MonadReader env m
, HasDirs env
, HasPlatformReq env
, HasGHCupInfo env
, HasSettings env
2020-01-11 20:15:05 +00:00
, MonadThrow m
, MonadResource m
2021-08-30 20:41:58 +00:00
, HasLog env
2020-01-11 20:15:05 +00:00
, MonadIO m
, MonadUnliftIO m
2020-01-11 20:15:05 +00:00
, MonadFail m
)
2021-05-14 21:09:45 +00:00
=> Either GHCTargetVersion GitBranch -- ^ version to install
2021-06-05 20:26:35 +00:00
-> Maybe Version -- ^ overwrite version
2021-05-14 21:09:45 +00:00
-> Either Version FilePath -- ^ version to bootstrap with
-> Maybe Int -- ^ jobs
2021-05-14 21:09:45 +00:00
-> Maybe FilePath -- ^ build config
2021-11-12 18:52:00 +00:00
-> Maybe (Either FilePath [URI]) -- ^ patches
-> [Text] -- ^ additional args to ./configure
-> Maybe String -- ^ build flavour
-> Bool
-> InstallDir
2020-01-11 20:15:05 +00:00
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, DigestError
2021-09-18 17:45:32 +00:00
, GPGError
2020-01-11 20:15:05 +00:00
, DownloadFailed
, GHCupSetError
, NoDownload
2020-04-10 20:44:43 +00:00
, NotFoundInPATH
, PatchFailed
2020-01-11 20:15:05 +00:00
, UnknownArchive
2020-08-06 11:28:20 +00:00
, TarDirDoesNotExist
, NotInstalled
2021-08-11 10:24:51 +00:00
, DirNotEmpty
, ArchiveResult
2021-10-10 18:02:15 +00:00
, FileDoesNotExistError
, HadrianNotFound
, InvalidBuildConfig
, ProcessError
, CopyError
, BuildFailed
2020-01-11 20:15:05 +00:00
]
m
2021-04-28 16:45:48 +00:00
GHCTargetVersion
compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian installDir
= do
PlatformRequest { .. } <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-04-28 16:45:48 +00:00
(workdir, tmpUnpack, tver) <- case targetGhc of
-- unpack from version tarball
Left tver -> do
2021-08-30 20:41:58 +00:00
lift $ logDebug $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap
2021-04-28 16:45:48 +00:00
-- download source tarball
dlInfo <-
preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls
?? NoDownload
2021-07-18 21:29:09 +00:00
dl <- liftE $ downloadCached dlInfo Nothing
2021-04-28 16:45:48 +00:00
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
2021-10-10 18:02:15 +00:00
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
2021-04-28 16:45:48 +00:00
workdir <- maybe (pure tmpUnpack)
(liftE . intoSubdir tmpUnpack)
(view dlSubdir dlInfo)
2021-11-12 18:52:00 +00:00
liftE $ applyAnyPatch patches workdir
2021-04-28 16:45:48 +00:00
pure (workdir, tmpUnpack, tver)
-- clone from git
Right GitBranch{..} -> do
tmpUnpack <- lift mkGhcupTmpDir
2021-05-14 21:09:45 +00:00
let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing
2021-11-12 18:52:00 +00:00
tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] DownloadFailed $ do
2021-04-28 16:45:48 +00:00
let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo
2021-08-30 20:41:58 +00:00
lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
2021-04-28 16:45:48 +00:00
lEM $ git [ "init" ]
lEM $ git [ "remote"
, "add"
, "origin"
, fromString rep ]
let fetch_args =
2021-04-28 16:45:48 +00:00
[ "fetch"
, "--depth"
, "1"
, "--quiet"
, "origin"
, fromString ref ]
lEM $ git fetch_args
lEM $ git [ "checkout", "FETCH_HEAD" ]
lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]
2021-11-12 18:52:00 +00:00
liftE $ applyAnyPatch patches tmpUnpack
lEM $ execWithGhcEnv "python3" ["./boot"] (Just tmpUnpack) "ghc-bootstrap"
lEM $ execWithGhcEnv "sh" ["./configure"] (Just tmpUnpack) "ghc-bootstrap"
2021-05-14 21:09:45 +00:00
CapturedProcess {..} <- lift $ makeOut
2021-04-28 16:45:48 +00:00
["show!", "--quiet", "VALUE=ProjectVersion" ] (Just tmpUnpack)
case _exitCode of
2021-05-14 21:09:45 +00:00
ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe' $ _stdOut
ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr))
2021-04-28 16:45:48 +00:00
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
2021-08-30 20:41:58 +00:00
lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to GHC version " <> prettyVer tver
2021-04-28 16:45:48 +00:00
pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver)
2021-06-05 20:26:35 +00:00
-- the version that's installed may differ from the
-- compiled version, so the user can overwrite it
let installVer = maybe tver (\ov' -> tver { _tvVersion = ov' }) ov
2021-06-05 20:26:35 +00:00
alreadyInstalled <- lift $ ghcInstalled installVer
alreadySet <- fmap (== Just installVer) $ lift $ ghcSet (_tvTarget installVer)
when alreadyInstalled $ do
case installDir of
IsolateDir isoDir ->
lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Isolate installing to " <> T.pack isoDir
GHCupInternal ->
lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Will overwrite existing version."
2021-08-30 20:41:58 +00:00
lift $ logWarn
"...waiting for 10 seconds before continuing, you can still abort..."
liftIO $ threadDelay 10000000 -- give the user a sec to intervene
ghcdir <- case installDir of
IsolateDir isoDir -> pure $ IsolateDirResolved isoDir
GHCupInternal -> GHCupDir <$> lift (ghcupGHCDir installVer)
(mBindist, bmk) <- liftE $ runBuildAction
tmpUnpack
2020-09-17 19:20:38 +00:00
Nothing
(do
b <- if hadrian
then compileHadrianBindist tver workdir ghcdir
else compileMakeBindist tver workdir ghcdir
bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk workdir)
pure (b, bmk)
)
2020-01-11 20:15:05 +00:00
case installDir of
GHCupInternal ->
-- only remove old ghc in regular installs
when alreadyInstalled $ do
2021-08-30 20:41:58 +00:00
lift $ logInfo "Deleting existing installation"
liftE $ rmGHCVer installVer
_ -> pure ()
forM_ mBindist $ \bindist -> do
liftE $ installPackedGHC bindist
(Just $ RegexDir "ghc-.*")
ghcdir
(installVer ^. tvVersion)
2021-09-11 17:50:06 +00:00
False -- not a force install, since we already overwrite when compiling.
2020-01-11 20:15:05 +00:00
liftIO $ B.writeFile (fromInstallDir ghcdir </> ghcUpSrcBuiltFile) bmk
case installDir of
-- set and make symlinks for regular (non-isolated) installs
GHCupInternal -> do
reThrowAll GHCupSetError $ postGHCInstall installVer
-- restore
2022-02-09 17:57:59 +00:00
when alreadySet $ liftE $ void $ setGHC installVer SetGHCOnly Nothing
_ -> pure ()
2020-01-11 20:15:05 +00:00
pure installVer
2021-04-28 16:45:48 +00:00
2020-01-11 20:15:05 +00:00
where
defaultConf =
2021-09-04 13:27:57 +00:00
let cross_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/cross" >> runIO (readFile "data/build_mk/cross")))
2021-09-04 13:09:14 +00:00
default_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/default" >> runIO (readFile "data/build_mk/default")))
in case targetGhc of
Left (GHCTargetVersion (Just _) _) -> cross_mk
_ -> default_mk
2020-01-11 20:15:05 +00:00
compileHadrianBindist :: ( MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, MonadThrow m
, MonadCatch m
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadIO m
, MonadFail m
)
=> GHCTargetVersion
-> FilePath
-> InstallDirResolved
-> Excepts
'[ FileDoesNotExistError
, HadrianNotFound
, InvalidBuildConfig
, PatchFailed
, ProcessError
, NotFoundInPATH
, CopyError]
m
(Maybe FilePath) -- ^ output path of bindist, None for cross
compileHadrianBindist tver workdir ghcdir = do
lEM $ execWithGhcEnv "python3" ["./boot"] (Just workdir) "ghc-bootstrap"
liftE $ configureBindist tver workdir ghcdir
2021-08-30 20:41:58 +00:00
lift $ logInfo "Building (this may take a while)..."
hadrian_build <- liftE $ findHadrianFile workdir
lEM $ execWithGhcEnv hadrian_build
2021-08-25 16:54:58 +00:00
( maybe [] (\j -> ["-j" <> show j] ) jobs
++ maybe [] (\bf -> ["--flavour=" <> bf]) buildFlavour
++ ["binary-dist"]
)
(Just workdir) "ghc-make"
[tar] <- liftIO $ findFiles
(workdir </> "_build" </> "bindist")
(makeRegexOpts compExtended
execBlank
([s|^ghc-.*\.tar\..*$|] :: ByteString)
)
liftE $ fmap Just $ copyBindist tver tar (workdir </> "_build" </> "bindist")
2020-03-18 16:31:17 +00:00
findHadrianFile :: (MonadIO m)
=> FilePath
-> Excepts
'[HadrianNotFound]
m
FilePath
findHadrianFile workdir = do
2021-10-17 18:39:49 +00:00
let possible_files = if isWindows
then ((workdir </> "hadrian") </>) <$> ["build.bat"]
else ((workdir </> "hadrian") </>) <$> ["build", "build.sh"]
exsists <- forM possible_files (\f -> liftIO (doesFileExist f) <&> (,f))
case filter fst exsists of
[] -> throwE HadrianNotFound
((_, x):_) -> pure x
compileMakeBindist :: ( MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, MonadThrow m
, MonadCatch m
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadIO m
, MonadFail m
)
=> GHCTargetVersion
-> FilePath
-> InstallDirResolved
-> Excepts
'[ FileDoesNotExistError
, HadrianNotFound
, InvalidBuildConfig
, PatchFailed
, ProcessError
, NotFoundInPATH
, CopyError]
m
(Maybe FilePath) -- ^ output path of bindist, None for cross
compileMakeBindist tver workdir ghcdir = do
liftE $ configureBindist tver workdir ghcdir
2020-01-11 20:15:05 +00:00
case mbuildConfig of
Just bc -> liftIOException
doesNotExistErrorType
2021-05-14 21:09:45 +00:00
(FileDoesNotExistError bc)
(liftIO $ copyFile bc (build_mk workdir))
2020-01-11 20:15:05 +00:00
Nothing ->
2021-08-25 16:54:58 +00:00
liftIO $ T.writeFile (build_mk workdir) (addBuildFlavourToConf defaultConf)
liftE $ checkBuildConfig (build_mk workdir)
2020-01-11 20:15:05 +00:00
2021-08-30 20:41:58 +00:00
lift $ logInfo "Building (this may take a while)..."
lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)
if | isCross tver -> do
2021-08-30 20:41:58 +00:00
lift $ logInfo "Installing cross toolchain..."
lEM $ make ["install"] (Just workdir)
pure Nothing
| otherwise -> do
2021-08-30 20:41:58 +00:00
lift $ logInfo "Creating bindist..."
lEM $ make ["binary-dist"] (Just workdir)
[tar] <- liftIO $ findFiles
workdir
(makeRegexOpts compExtended
execBlank
([s|^ghc-.*\.tar\..*$|] :: ByteString)
)
liftE $ fmap Just $ copyBindist tver tar workdir
2020-01-11 20:15:05 +00:00
2021-05-14 21:09:45 +00:00
build_mk workdir = workdir </> "mk" </> "build.mk"
2020-01-11 20:15:05 +00:00
copyBindist :: ( MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, MonadIO m
, MonadThrow m
, MonadCatch m
2021-08-30 20:41:58 +00:00
, HasLog env
)
=> GHCTargetVersion
-> FilePath -- ^ tar file
-> FilePath -- ^ workdir
-> Excepts
'[CopyError]
m
FilePath
copyBindist tver tar workdir = do
Dirs {..} <- lift getDirs
pfreq <- lift getPlatformReq
c <- liftIO $ BL.readFile (workdir </> tar)
cDigest <-
fmap (T.take 8)
. lift
. throwEither
. E.decodeUtf8'
. B16.encode
. SHA256.hashlazy
$ c
cTime <- liftIO getCurrentTime
2021-08-25 16:54:58 +00:00
let tarName = makeValid ("ghc-"
<> T.unpack (tVerToText tver)
<> "-"
<> pfReqToString pfreq
<> "-"
<> iso8601Show cTime
<> "-"
<> T.unpack cDigest
<> ".tar"
<> takeExtension tar)
let tarPath = cacheDir </> tarName
2021-09-25 15:27:02 +00:00
copyFileE (workdir </> tar)
tarPath
2021-08-30 20:41:58 +00:00
lift $ logInfo $ "Copied bindist to " <> T.pack tarPath
pure tarPath
2021-08-30 20:41:58 +00:00
checkBuildConfig :: (MonadReader env m, MonadCatch m, MonadIO m, HasLog env)
=> FilePath
-> Excepts
'[FileDoesNotExistError, InvalidBuildConfig]
2020-04-25 10:06:41 +00:00
m
()
checkBuildConfig bc = do
c <- liftIOException
doesNotExistErrorType
(FileDoesNotExistError bc)
(liftIO $ B.readFile bc)
2020-04-25 10:06:41 +00:00
let lines' = fmap T.strip . T.lines $ decUTF8Safe c
-- for cross, we need Stage1Only
2021-04-28 16:45:48 +00:00
case targetGhc of
Left (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE
2020-04-25 10:06:41 +00:00
(InvalidBuildConfig
[s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|]
)
2021-04-28 16:45:48 +00:00
_ -> pure ()
2020-04-25 10:06:41 +00:00
forM_ buildFlavour $ \bf ->
2021-08-25 16:54:58 +00:00
when (T.pack ("BuildFlavour = " <> bf) `notElem` lines') $ do
2021-08-30 20:41:58 +00:00
lift $ logWarn $ "Customly specified build config overwrites --flavour=" <> T.pack bf <> " switch! Waiting 5 seconds..."
liftIO $ threadDelay 5000000
addBuildFlavourToConf bc = case buildFlavour of
2021-08-25 16:54:58 +00:00
Just bf -> "BuildFlavour = " <> T.pack bf <> "\n" <> bc
Nothing -> bc
isCross :: GHCTargetVersion -> Bool
isCross = isJust . _tvTarget
2020-04-25 10:06:41 +00:00
configureBindist :: ( MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, MonadThrow m
, MonadCatch m
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadIO m
, MonadFail m
)
=> GHCTargetVersion
-> FilePath
-> InstallDirResolved
-> Excepts
'[ FileDoesNotExistError
, InvalidBuildConfig
, PatchFailed
, ProcessError
, NotFoundInPATH
, CopyError
]
m
()
configureBindist tver workdir (fromInstallDir -> ghcdir) = do
2021-08-30 20:41:58 +00:00
lift $ logInfo [s|configuring build|]
if | _tvVersion tver >= [vver|8.8.0|] -> do
lEM $ execWithGhcEnv
"sh"
("./configure" : maybe mempty
(\x -> ["--target=" <> T.unpack x])
(_tvTarget tver)
++ ["--prefix=" <> ghcdir]
2021-10-17 18:39:49 +00:00
++ (if isWindows then ["--enable-tarballs-autodownload"] else [])
++ fmap T.unpack aargs
)
(Just workdir)
"ghc-conf"
| otherwise -> do
lEM $ execLogged
"sh"
( [ "./configure", "--with-ghc=" <> either id id bghc
]
++ maybe mempty
(\x -> ["--target=" <> T.unpack x])
(_tvTarget tver)
++ ["--prefix=" <> ghcdir]
2021-10-17 18:39:49 +00:00
++ (if isWindows then ["--enable-tarballs-autodownload"] else [])
++ fmap T.unpack aargs
)
(Just workdir)
"ghc-conf"
Nothing
pure ()
execWithGhcEnv :: ( MonadReader env m
, HasSettings env
, HasDirs env
2021-11-11 23:58:21 +00:00
, HasLog env
, MonadIO m
, MonadThrow m)
=> FilePath -- ^ thing to execute
-> [String] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this
-> FilePath -- ^ log filename (opened in append mode)
-> m (Either ProcessError ())
execWithGhcEnv fp args dir logf = do
env <- ghcEnv
execLogged fp args dir logf (Just env)
bghc = case bstrap of
Right g -> Right g
Left bver -> Left ("ghc-" <> (T.unpack . prettyVer $ bver) <> exeExt)
ghcEnv :: (MonadThrow m, MonadIO m) => m [(String, String)]
ghcEnv = do
cEnv <- liftIO getEnvironment
bghcPath <- case bghc of
Right ghc' -> pure ghc'
Left bver -> do
spaths <- liftIO getSearchPath
throwMaybeM (NotFoundInPATH bver) $ liftIO (searchPath spaths bver)
pure (("GHC", bghcPath) : cEnv)
2020-04-25 10:06:41 +00:00
2020-01-11 20:15:05 +00:00
---------------------
--[ Upgrade GHCup ]--
---------------------
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
2021-09-18 17:45:32 +00:00
, GPGError
, GPGError
2020-01-11 20:15:05 +00:00
, DownloadFailed
, NoDownload
, NoUpdate
, GHCupShadowed
2020-01-11 20:15:05 +00:00
]
m
Version
upgradeGHCup mtarget force' fatal = do
Dirs {..} <- lift getDirs
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-08-30 20:41:58 +00:00
lift $ logInfo "Upgrading GHCup..."
2022-04-29 14:47:11 +00:00
let latestVer = fst (fromJust (getLatest dls 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 <- lift withGHCupTmpDir
2021-05-14 21:09:45 +00:00
let fn = "ghcup" <> exeExt
2021-09-18 17:45:32 +00:00
p <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash 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
2021-09-25 15:27:02 +00:00
copyFileE p
destFile
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
| fatal -> throwE (GHCupShadowed pa destFile latestVer)
| otherwise ->
lift $ logWarn $ "ghcup is shadowed by "
<> T.pack pa
<> ". The upgrade will not be in effect, unless you remove "
<> T.pack pa
<> " or make sure "
<> T.pack destDir
<> " comes before "
<> T.pack (takeDirectory pa)
<> " in PATH."
2020-01-11 20:15:05 +00:00
pure latestVer
-------------
--[ Other ]--
-------------
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for
2020-01-11 20:15:05 +00:00
-- both installing from source and bindist.
postGHCInstall :: ( MonadReader env m
, HasDirs env
2021-08-30 20:41:58 +00:00
, HasLog env
2020-08-06 11:28:20 +00:00
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadCatch m
2021-05-14 21:09:45 +00:00
, MonadMask m
, MonadUnliftIO m
2020-08-06 11:28:20 +00:00
)
2020-04-25 10:06:41 +00:00
=> GHCTargetVersion
2020-01-11 20:15:05 +00:00
-> Excepts '[NotInstalled] m ()
2020-08-06 11:28:20 +00:00
postGHCInstall ver@GHCTargetVersion {..} = do
2022-02-09 17:57:59 +00:00
void $ liftE $ setGHC ver SetGHC_XYZ Nothing
2020-01-11 20:15:05 +00:00
-- Create ghc-x.y symlinks. This may not be the current
-- version, create it regardless.
2020-08-06 11:28:20 +00:00
v' <-
2021-08-30 20:41:58 +00:00
handle (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)
2020-08-06 11:28:20 +00:00
$ fmap Just
$ getMajorMinorV _tvVersion
forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) _tvTarget)
2022-02-09 17:57:59 +00:00
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing)
-- | 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 <- 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 <- lift $ ghcupHLSDir _tvVersion
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
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-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
throwIfFileAlreadyExists :: ( MonadIO m ) =>
FilePath ->
Excepts '[FileAlreadyExistsError] 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
2022-02-05 18:12:13 +00:00
, MonadFail m
, MonadUnliftIO m
)
2022-02-05 18:12:13 +00:00
=> Excepts '[NotInstalled] 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 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
2021-11-12 18:52:00 +00:00
applyAnyPatch :: ( MonadReader env m
, HasDirs env
, HasLog env
, HasSettings env
, MonadUnliftIO m
, MonadCatch m
, MonadResource m
, MonadThrow m
, MonadMask m
, MonadIO m)
=> Maybe (Either FilePath [URI])
-> FilePath
-> Excepts '[PatchFailed, DownloadFailed, DigestError, GPGError] m ()
applyAnyPatch Nothing _ = pure ()
applyAnyPatch (Just (Left pdir)) workdir = liftE $ applyPatches pdir workdir
applyAnyPatch (Just (Right uris)) workdir = do
tmpUnpack <- lift withGHCupTmpDir
forM_ uris $ \uri -> do
patch <- liftE $ download uri Nothing Nothing tmpUnpack Nothing False
liftE $ applyPatch patch workdir