{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module GHCup.HLS where
import GHCup.Download
import GHCup.Errors
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Prelude
import GHCup.Prelude.File
import GHCup.Prelude.Logger
import GHCup.Prelude.Process
import GHCup.Prelude.String.QQ
import Codec.Archive ( ArchiveResult )
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
import Data.ByteString ( ByteString )
import Data.Either
import Data.List
import Data.Ord
import Data.Maybe
import Data.String ( fromString )
import Data.Text ( Text )
import Data.Versions hiding ( patch )
import Distribution.Types.Version hiding ( Version )
import Distribution.Types.PackageId
import Distribution.Types.PackageDescription
import Distribution.Types.GenericPackageDescription
import Distribution.PackageDescription.Parsec
import GHC.IO.Exception
import Haskus.Utils.Variant.Excepts
import Optics
import Prelude hiding ( abs
, writeFile
)
import Safe hiding ( at )
import System.FilePath
import System.IO.Error
import Text.Regex.Posix
import URI.ByteString
import qualified Data.List.NonEmpty as NE
import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Text.Megaparsec as MP
data HLSVer = SourceDist Version
| GitDist GitBranch
| HackageDist Version
| RemoteDist URI
installHLSBindist :: ( MonadMask m
, MonadCatch m
, MonadReader env m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
, MonadFail m
)
=> DownloadInfo
-> Version
-> InstallDir
-> Bool
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
, ArchiveResult
, FileAlreadyExistsError
, ProcessError
, DirNotEmpty
, UninstallFailed
, MergeFileTreeError
]
m
()
installHLSBindist :: forall (m :: * -> *) env.
(MonadMask m, MonadCatch m, MonadReader env m, HasPlatformReq env,
HasDirs env, HasSettings env, HasLog env, MonadResource m,
MonadIO m, MonadUnliftIO m, MonadFail m) =>
DownloadInfo
-> Version
-> InstallDir
-> Bool
-> Excepts
'[AlreadyInstalled, CopyError, DigestError, ContentLengthError,
GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive,
TarDirDoesNotExist, ArchiveResult, FileAlreadyExistsError,
ProcessError, DirNotEmpty, UninstallFailed, MergeFileTreeError]
m
()
installHLSBindist DownloadInfo
dlinfo Version
ver InstallDir
installDir Bool
forceInstall = do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"Requested to install hls version " forall a. Semigroup a => a -> a -> a
<> Version -> Text
prettyVer Version
ver
PlatformRequest {Maybe Versioning
Platform
Architecture
$sel:_rVersion:PlatformRequest :: PlatformRequest -> Maybe Versioning
$sel:_rPlatform:PlatformRequest :: PlatformRequest -> Platform
$sel:_rArch:PlatformRequest :: PlatformRequest -> Architecture
_rVersion :: Maybe Versioning
_rPlatform :: Platform
_rArch :: Architecture
..} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "pfreq" A_Lens env PlatformRequest) =>
m PlatformRequest
getPlatformReq
Dirs {FilePath
GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: FilePath
baseDir :: GHCupPath
..} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
Bool
regularHLSInstalled <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) =>
Version -> m Bool
hlsInstalled Version
ver
if
| Bool -> Bool
not Bool
forceInstall
, Bool
regularHLSInstalled
, InstallDir
GHCupInternal <- InstallDir
installDir -> do
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE forall a b. (a -> b) -> a -> b
$ Tool -> Version -> AlreadyInstalled
AlreadyInstalled Tool
HLS Version
ver
| Bool
forceInstall
, Bool
regularHLSInstalled
, InstallDir
GHCupInternal <- InstallDir
installDir -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo Text
"Removing the currently installed version of HLS before force installing!"
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadMask m, MonadReader env m, HasDirs env, MonadThrow m,
HasLog env, MonadIO m, MonadFail m, MonadCatch m,
MonadUnliftIO m) =>
Version -> Excepts '[NotInstalled, UninstallFailed] m ()
rmHLSVer Version
ver
| Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
FilePath
dl <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadMask m,
MonadResource m, MonadThrow m, HasLog env, MonadIO m,
MonadUnliftIO m) =>
DownloadInfo
-> Maybe FilePath
-> Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
FilePath
downloadCached DownloadInfo
dlinfo forall a. Maybe a
Nothing
GHCupPath
tmpUnpack <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, HasSettings env,
MonadUnliftIO m, MonadCatch m, MonadResource m, MonadThrow m,
MonadMask m, MonadIO m) =>
m GHCupPath
withGHCupTmpDir
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (e :: [*]) (m :: * -> *) a env.
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
MonadMask m, HasLog env, MonadUnliftIO m, MonadFail m,
MonadCatch m) =>
GHCupPath -> Excepts e m a -> Excepts e m a
cleanUpOnError GHCupPath
tmpUnpack (forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m) =>
FilePath
-> FilePath -> Excepts '[UnknownArchive, ArchiveResult] m ()
unpackToDir (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack) FilePath
dl)
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (es :: [*]) (m :: * -> *) env.
(Pretty (V es), HFErrorProject (V es), MonadReader env m,
HasLog env, MonadIO m, Monad m) =>
Excepts es m () -> Excepts '[] m ()
catchWarn forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM @_ @'[ProcessError] forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
Platform -> FilePath -> m (Either ProcessError ())
darwinNotarization Platform
_rPlatform (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack)
FilePath
workdir <- GHCupPath -> FilePath
fromGHCupPath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure GHCupPath
tmpUnpack) (forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m,
MonadCatch m) =>
GHCupPath -> TarDir -> Excepts '[TarDirDoesNotExist] m GHCupPath
intoSubdir GHCupPath
tmpUnpack) (forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Lens' DownloadInfo (Maybe TarDir)
dlSubdir DownloadInfo
dlinfo)
Bool
legacy <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
isLegacyHLSBindist FilePath
workdir
if
| Bool -> Bool
not Bool
forceInstall
, Bool -> Bool
not Bool
legacy
, (IsolateDir FilePath
fp) <- InstallDir
installDir -> forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m, MonadMask m) =>
InstallDirResolved -> Excepts '[DirNotEmpty] m ()
installDestSanityCheck (FilePath -> InstallDirResolved
IsolateDirResolved FilePath
fp)
| Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
case InstallDir
installDir of
IsolateDir FilePath
isoDir -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"isolated installing HLS to " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
isoDir
if Bool
legacy
then forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, MonadFail m, HasLog env, MonadCatch m,
MonadIO m) =>
FilePath
-> InstallDirResolved
-> Version
-> Bool
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installHLSUnpackedLegacy FilePath
workdir (FilePath -> InstallDirResolved
IsolateDirResolved FilePath
isoDir) Version
ver Bool
forceInstall
else forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) (e :: [*]) a.
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
MonadMask m, HasLog env, MonadUnliftIO m, MonadFail m,
MonadCatch m) =>
GHCupPath -> Excepts e m a -> Excepts e m a
runBuildAction GHCupPath
tmpUnpack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadMask m, MonadUnliftIO m, MonadReader env m, MonadFail m,
HasLog env, HasDirs env, HasSettings env, MonadCatch m, MonadIO m,
MonadResource m, HasPlatformReq env) =>
FilePath
-> InstallDirResolved
-> Version
-> Bool
-> Excepts
'[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled,
MergeFileTreeError]
m
()
installHLSUnpacked FilePath
workdir (FilePath -> InstallDirResolved
IsolateDirResolved FilePath
isoDir) Version
ver Bool
forceInstall
InstallDir
GHCupInternal -> do
if Bool
legacy
then forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, MonadFail m, HasLog env, MonadCatch m,
MonadIO m) =>
FilePath
-> InstallDirResolved
-> Version
-> Bool
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installHLSUnpackedLegacy FilePath
workdir (FilePath -> InstallDirResolved
GHCupBinDir FilePath
binDir) Version
ver Bool
forceInstall
else do
GHCupPath
inst <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
Version -> m GHCupPath
ghcupHLSDir Version
ver
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) (e :: [*]) a.
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
MonadMask m, HasLog env, MonadUnliftIO m, MonadFail m,
MonadCatch m) =>
GHCupPath -> Excepts e m a -> Excepts e m a
runBuildAction GHCupPath
tmpUnpack
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadMask m, MonadUnliftIO m, MonadReader env m, MonadFail m,
HasLog env, HasDirs env, HasSettings env, MonadCatch m, MonadIO m,
MonadResource m, HasPlatformReq env) =>
FilePath
-> InstallDirResolved
-> Version
-> Bool
-> Excepts
'[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled,
MergeFileTreeError]
m
()
installHLSUnpacked FilePath
workdir (GHCupPath -> InstallDirResolved
GHCupDir GHCupPath
inst) Version
ver Bool
forceInstall
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadIO m,
MonadMask m, MonadFail m, MonadUnliftIO m) =>
Version -> SetHLS -> Maybe FilePath -> Excepts '[NotInstalled] m ()
setHLS Version
ver SetHLS
SetHLS_XYZ forall a. Maybe a
Nothing
isLegacyHLSBindist :: FilePath
-> IO Bool
isLegacyHLSBindist :: FilePath -> IO Bool
isLegacyHLSBindist FilePath
path = do
Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Bool
doesFileExist (FilePath
path FilePath -> FilePath -> FilePath
</> FilePath
"GNUmakefile")
installHLSUnpacked :: ( MonadMask m
, MonadUnliftIO m
, MonadReader env m
, MonadFail m
, HasLog env
, HasDirs env
, HasSettings env
, MonadCatch m
, MonadIO m
, MonadResource m
, HasPlatformReq env
)
=> FilePath
-> InstallDirResolved
-> Version
-> Bool
-> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled, MergeFileTreeError] m ()
installHLSUnpacked :: forall (m :: * -> *) env.
(MonadMask m, MonadUnliftIO m, MonadReader env m, MonadFail m,
HasLog env, HasDirs env, HasSettings env, MonadCatch m, MonadIO m,
MonadResource m, HasPlatformReq env) =>
FilePath
-> InstallDirResolved
-> Version
-> Bool
-> Excepts
'[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled,
MergeFileTreeError]
m
()
installHLSUnpacked FilePath
path InstallDirResolved
inst Version
ver Bool
forceInstall = do
PlatformRequest { Maybe Versioning
Platform
Architecture
_rVersion :: Maybe Versioning
_rPlatform :: Platform
_rArch :: Architecture
$sel:_rVersion:PlatformRequest :: PlatformRequest -> Maybe Versioning
$sel:_rPlatform:PlatformRequest :: PlatformRequest -> Platform
$sel:_rArch:PlatformRequest :: PlatformRequest -> Architecture
.. } <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "pfreq" A_Lens env PlatformRequest) =>
m PlatformRequest
getPlatformReq
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo Text
"Installing HLS"
GHCupPath
tmpInstallDest <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, HasSettings env,
MonadUnliftIO m, MonadCatch m, MonadResource m, MonadThrow m,
MonadMask m, MonadIO m) =>
m GHCupPath
withGHCupTmpDir
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadThrow m, MonadIO m, MonadReader env m, HasDirs env,
HasLog env, HasSettings env) =>
[FilePath] -> Maybe FilePath -> m (Either ProcessError ())
make [FilePath
"DESTDIR=" forall a. Semigroup a => a -> a -> a
<> GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpInstallDest, FilePath
"PREFIX=" forall a. Semigroup a => a -> a -> a
<> InstallDirResolved -> FilePath
fromInstallDir InstallDirResolved
inst, FilePath
"install"] (forall a. a -> Maybe a
Just FilePath
path)
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (es :: [*]) (m :: * -> *) env.
(Pretty (V es), HFErrorProject (V es), MonadReader env m,
HasLog env, MonadIO m, Monad m) =>
Excepts es m () -> Excepts '[] m ()
catchWarn forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM @_ @'[ProcessError] forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
Platform -> FilePath -> m (Either ProcessError ())
darwinNotarization Platform
_rPlatform (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpInstallDest)
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadMask m, MonadAsync m, MonadReader env m, HasDirs env,
HasLog env, MonadCatch m) =>
GHCupPath
-> InstallDirResolved
-> Tool
-> GHCTargetVersion
-> (FilePath -> FilePath -> m ())
-> Excepts '[MergeFileTreeError] m ()
mergeFileTree (GHCupPath
tmpInstallDest GHCupPath -> FilePath -> GHCupPath
`appendGHCupPath` FilePath -> FilePath
dropDrive (InstallDirResolved -> FilePath
fromInstallDir InstallDirResolved
inst))
InstallDirResolved
inst
Tool
HLS
(Version -> GHCTargetVersion
mkTVer Version
ver)
(\FilePath
f FilePath
t -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Maybe UTCTime
mtime <- forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (FilePath -> IO Bool
pathIsSymbolicLink FilePath
f) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO UTCTime
getModificationTime FilePath
f)
FilePath -> FilePath -> Bool -> IO ()
install FilePath
f FilePath
t (Bool -> Bool
not Bool
forceInstall)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe UTCTime
mtime forall a b. (a -> b) -> a -> b
$ FilePath -> UTCTime -> IO ()
setModificationTime FilePath
t)
installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
=> FilePath
-> InstallDirResolved
-> Version
-> Bool
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installHLSUnpackedLegacy :: forall env (m :: * -> *).
(MonadReader env m, MonadFail m, HasLog env, MonadCatch m,
MonadIO m) =>
FilePath
-> InstallDirResolved
-> Version
-> Bool
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installHLSUnpackedLegacy FilePath
path InstallDirResolved
installDir Version
ver Bool
forceInstall = do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo Text
"Installing HLS"
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
createDirRecursive' (InstallDirResolved -> FilePath
fromInstallDir InstallDirResolved
installDir)
bins :: [FilePath]
bins@(FilePath
_:[FilePath]
_) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> Regex -> IO [FilePath]
findFiles
FilePath
path
(forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended
ExecOption
execBlank
([s|^haskell-language-server-[0-9].*$|] :: ByteString)
)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
bins forall a b. (a -> b) -> a -> b
$ \FilePath
f -> do
let toF :: FilePath
toF = forall a. Eq a => [a] -> [a] -> [a]
dropSuffix FilePath
exeExt FilePath
f
forall a. Semigroup a => a -> a -> a
<> (case InstallDirResolved
installDir of
IsolateDirResolved FilePath
_ -> FilePath
""
InstallDirResolved
_ -> (FilePath
"~" forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Text
prettyVer forall a b. (a -> b) -> a -> b
$ Version
ver
)
forall a. Semigroup a => a -> a -> a
<> FilePath
exeExt
let srcPath :: FilePath
srcPath = FilePath
path FilePath -> FilePath -> FilePath
</> FilePath
f
let destPath :: FilePath
destPath = InstallDirResolved -> FilePath
fromInstallDir InstallDirResolved
installDir FilePath -> FilePath -> FilePath
</> FilePath
toF
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (MonadMask m, MonadIO m) => FilePath -> m ()
rmFileForce FilePath
destPath
forall (xs :: [*]) (m :: * -> *).
(CopyError :< xs, MonadCatch m, MonadIO m) =>
FilePath -> FilePath -> Bool -> Excepts xs m ()
copyFileE
FilePath
srcPath
FilePath
destPath
(Bool -> Bool
not Bool
forceInstall)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => FilePath -> m ()
chmod_755 FilePath
destPath
let wrapper :: FilePath
wrapper = FilePath
"haskell-language-server-wrapper"
toF :: FilePath
toF = FilePath
wrapper
forall a. Semigroup a => a -> a -> a
<> (case InstallDirResolved
installDir of
IsolateDirResolved FilePath
_ -> FilePath
""
InstallDirResolved
_ -> (FilePath
"-" forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Text
prettyVer forall a b. (a -> b) -> a -> b
$ Version
ver
)
forall a. Semigroup a => a -> a -> a
<> FilePath
exeExt
srcWrapperPath :: FilePath
srcWrapperPath = FilePath
path FilePath -> FilePath -> FilePath
</> FilePath
wrapper forall a. Semigroup a => a -> a -> a
<> FilePath
exeExt
destWrapperPath :: FilePath
destWrapperPath = InstallDirResolved -> FilePath
fromInstallDir InstallDirResolved
installDir FilePath -> FilePath -> FilePath
</> FilePath
toF
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (MonadMask m, MonadIO m) => FilePath -> m ()
rmFileForce FilePath
destWrapperPath
forall (xs :: [*]) (m :: * -> *).
(CopyError :< xs, MonadCatch m, MonadIO m) =>
FilePath -> FilePath -> Bool -> Excepts xs m ()
copyFileE
FilePath
srcWrapperPath
FilePath
destWrapperPath
(Bool -> Bool
not Bool
forceInstall)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => FilePath -> m ()
chmod_755 FilePath
destWrapperPath
installHLSBin :: ( MonadMask m
, MonadCatch m
, MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
, HasDirs env
, HasSettings env
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
, MonadFail m
)
=> Version
-> InstallDir
-> Bool
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
, ArchiveResult
, FileAlreadyExistsError
, ProcessError
, DirNotEmpty
, UninstallFailed
, MergeFileTreeError
]
m
()
installHLSBin :: forall (m :: * -> *) env.
(MonadMask m, MonadCatch m, MonadReader env m, HasPlatformReq env,
HasGHCupInfo env, HasDirs env, HasSettings env, HasLog env,
MonadResource m, MonadIO m, MonadUnliftIO m, MonadFail m) =>
Version
-> InstallDir
-> Bool
-> Excepts
'[AlreadyInstalled, CopyError, DigestError, ContentLengthError,
GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive,
TarDirDoesNotExist, ArchiveResult, FileAlreadyExistsError,
ProcessError, DirNotEmpty, UninstallFailed, MergeFileTreeError]
m
()
installHLSBin Version
ver InstallDir
installDir Bool
forceInstall = do
DownloadInfo
dlinfo <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasPlatformReq env, HasGHCupInfo env) =>
Tool -> Version -> Excepts '[NoDownload] m DownloadInfo
getDownloadInfo Tool
HLS Version
ver
forall (m :: * -> *) env.
(MonadMask m, MonadCatch m, MonadReader env m, HasPlatformReq env,
HasDirs env, HasSettings env, HasLog env, MonadResource m,
MonadIO m, MonadUnliftIO m, MonadFail m) =>
DownloadInfo
-> Version
-> InstallDir
-> Bool
-> Excepts
'[AlreadyInstalled, CopyError, DigestError, ContentLengthError,
GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive,
TarDirDoesNotExist, ArchiveResult, FileAlreadyExistsError,
ProcessError, DirNotEmpty, UninstallFailed, MergeFileTreeError]
m
()
installHLSBindist DownloadInfo
dlinfo Version
ver InstallDir
installDir Bool
forceInstall
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
)
=> HLSVer
-> [Version]
-> Maybe Int
-> Either Bool Version
-> InstallDir
-> Maybe (Either FilePath URI)
-> Maybe URI
-> Bool
-> Maybe (Either FilePath [URI])
-> [Text]
-> Excepts '[ NoDownload
, GPGError
, DownloadFailed
, DigestError
, ContentLengthError
, UnknownArchive
, TarDirDoesNotExist
, ArchiveResult
, BuildFailed
, NotInstalled
] m Version
compileHLS :: forall (m :: * -> *) env.
(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) =>
HLSVer
-> [Version]
-> Maybe Int
-> Either Bool Version
-> InstallDir
-> Maybe (Either FilePath URI)
-> Maybe URI
-> Bool
-> Maybe (Either FilePath [URI])
-> [Text]
-> Excepts
'[NoDownload, GPGError, DownloadFailed, DigestError,
ContentLengthError, UnknownArchive, TarDirDoesNotExist,
ArchiveResult, BuildFailed, NotInstalled]
m
Version
compileHLS HLSVer
targetHLS [Version]
ghcs Maybe Int
jobs Either Bool Version
ov InstallDir
installDir Maybe (Either FilePath URI)
cabalProject Maybe URI
cabalProjectLocal Bool
updateCabal Maybe (Either FilePath [URI])
patches [Text]
cabalArgs = do
PlatformRequest { Maybe Versioning
Platform
Architecture
_rVersion :: Maybe Versioning
_rPlatform :: Platform
_rArch :: Architecture
$sel:_rVersion:PlatformRequest :: PlatformRequest -> Maybe Versioning
$sel:_rPlatform:PlatformRequest :: PlatformRequest -> Platform
$sel:_rArch:PlatformRequest :: PlatformRequest -> Architecture
.. } <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "pfreq" A_Lens env PlatformRequest) =>
m PlatformRequest
getPlatformReq
GHCupInfo { $sel:_ghcupDownloads:GHCupInfo :: GHCupInfo -> GHCupDownloads
_ghcupDownloads = GHCupDownloads
dls } <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "ghcupInfo" A_Lens env GHCupInfo) =>
m GHCupInfo
getGHCupInfo
Dirs { FilePath
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: FilePath
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
.. } <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
updateCabal forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) (es' :: [*]) a (m :: * -> *).
(Monad m, e :< es') =>
(V es -> e) -> Excepts es m a -> Excepts es' m a
reThrowAll @_ @'[ProcessError] forall (xs :: [*]).
(HFErrorProject (V xs), ToVariantMaybe DownloadFailed xs,
PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) =>
V xs -> DownloadFailed
DownloadFailed forall a b. (a -> b) -> a -> b
$ do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo Text
"Updating cabal DB"
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> m (Either ProcessError ())
exec FilePath
"cabal" [FilePath
"update"] (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpDir) forall a. Maybe a
Nothing
(GHCupPath
workdir, GHCupPath
tmpUnpack, Version
tver, Maybe Text
git_describe) <- case HLSVer
targetHLS of
SourceDist Version
tver -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"Requested to compile: " forall a. Semigroup a => a -> a -> a
<> Version -> Text
prettyVer Version
tver
DownloadInfo
dlInfo <-
forall k (is :: [*]) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
HLS forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix (Version -> GHCTargetVersion
mkTVer Version
tver) forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' VersionInfo (Maybe DownloadInfo)
viSourceDL forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall a b. Prism (Maybe a) (Maybe b) a b
_Just) GHCupDownloads
dls
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
Maybe a -> e -> Excepts es m a
?? NoDownload
NoDownload
FilePath
dl <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadMask m,
MonadResource m, MonadThrow m, HasLog env, MonadIO m,
MonadUnliftIO m) =>
DownloadInfo
-> Maybe FilePath
-> Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
FilePath
downloadCached DownloadInfo
dlInfo forall a. Maybe a
Nothing
GHCupPath
tmpUnpack <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadUnliftIO m, HasLog env,
MonadCatch m, MonadThrow m, MonadMask m, MonadIO m) =>
m GHCupPath
mkGhcupTmpDir
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (e :: [*]) (m :: * -> *) a env.
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
MonadMask m, HasLog env, MonadUnliftIO m, MonadFail m,
MonadCatch m) =>
GHCupPath -> Excepts e m a -> Excepts e m a
cleanUpOnError GHCupPath
tmpUnpack (forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m) =>
FilePath
-> FilePath -> Excepts '[UnknownArchive, ArchiveResult] m ()
unpackToDir (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack) FilePath
dl)
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (es :: [*]) (m :: * -> *) env.
(Pretty (V es), HFErrorProject (V es), MonadReader env m,
HasLog env, MonadIO m, Monad m) =>
Excepts es m () -> Excepts '[] m ()
catchWarn forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM @_ @'[ProcessError] forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
Platform -> FilePath -> m (Either ProcessError ())
darwinNotarization Platform
_rPlatform (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack)
GHCupPath
workdir <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure GHCupPath
tmpUnpack)
(forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m,
MonadCatch m) =>
GHCupPath -> TarDir -> Excepts '[TarDirDoesNotExist] m GHCupPath
intoSubdir GHCupPath
tmpUnpack)
(forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Lens' DownloadInfo (Maybe TarDir)
dlSubdir DownloadInfo
dlInfo)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GHCupPath
workdir, GHCupPath
tmpUnpack, Version
tver, forall a. Maybe a
Nothing)
HackageDist Version
tver -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"Requested to compile (from hackage): " forall a. Semigroup a => a -> a -> a
<> Version -> Text
prettyVer Version
tver
GHCupPath
tmpUnpack <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadUnliftIO m, HasLog env,
MonadCatch m, MonadThrow m, MonadMask m, MonadIO m) =>
m GHCupPath
mkGhcupTmpDir
let hls :: FilePath
hls = FilePath
"haskell-language-server-" forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack (Version -> Text
prettyVer Version
tver)
forall e (es :: [*]) (es' :: [*]) a (m :: * -> *).
(Monad m, e :< es') =>
(V es -> e) -> Excepts es m a -> Excepts es' m a
reThrowAll @_ @'[ProcessError] forall (xs :: [*]).
(HFErrorProject (V xs), ToVariantMaybe DownloadFailed xs,
PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) =>
V xs -> DownloadFailed
DownloadFailed forall a b. (a -> b) -> a -> b
$ do
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> m (Either ProcessError ())
exec FilePath
"cabal" [FilePath
"unpack", FilePath
hls] (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack) forall a. Maybe a
Nothing
let workdir :: GHCupPath
workdir = GHCupPath -> FilePath -> GHCupPath
appendGHCupPath GHCupPath
tmpUnpack FilePath
hls
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GHCupPath
workdir, GHCupPath
tmpUnpack, Version
tver, forall a. Maybe a
Nothing)
RemoteDist URI
uri -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"Requested to compile (from uri): " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show URI
uri)
GHCupPath
tmpDownload <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, HasSettings env,
MonadUnliftIO m, MonadCatch m, MonadResource m, MonadThrow m,
MonadMask m, MonadIO m) =>
m GHCupPath
withGHCupTmpDir
GHCupPath
tmpUnpack <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadUnliftIO m, HasLog env,
MonadCatch m, MonadThrow m, MonadMask m, MonadIO m) =>
m GHCupPath
mkGhcupTmpDir
FilePath
tar <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasDirs env, MonadMask m,
MonadThrow m, HasLog env, MonadIO m) =>
URI
-> Maybe URI
-> Maybe Text
-> Maybe Integer
-> FilePath
-> Maybe FilePath
-> Bool
-> Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
FilePath
download URI
uri forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpDownload) forall a. Maybe a
Nothing Bool
False
(FilePath
cf, Version
tver) <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (e :: [*]) (m :: * -> *) a env.
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
MonadMask m, HasLog env, MonadUnliftIO m, MonadFail m,
MonadCatch m) =>
GHCupPath -> Excepts e m a -> Excepts e m a
cleanUpOnError GHCupPath
tmpUnpack forall a b. (a -> b) -> a -> b
$ do
forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m) =>
FilePath
-> FilePath -> Excepts '[UnknownArchive, ArchiveResult] m ()
unpackToDir (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack) FilePath
tar
let regex :: ByteString
regex = [s|^(.*/)*haskell-language-server\.cabal$|] :: B.ByteString
[FilePath
cabalFile] <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ GHCupPath -> Regex -> IO [FilePath]
findFilesDeep
GHCupPath
tmpUnpack
(forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended
ExecOption
execBlank
ByteString
regex
)
Version
tver <- forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
FilePath -> m Version
getCabalVersion (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack FilePath -> FilePath -> FilePath
</> FilePath
cabalFile)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
cabalFile, Version
tver)
let workdir :: GHCupPath
workdir = GHCupPath -> FilePath -> GHCupPath
appendGHCupPath GHCupPath
tmpUnpack (FilePath -> FilePath
takeDirectory FilePath
cf)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GHCupPath
workdir, GHCupPath
tmpUnpack, Version
tver, forall a. Maybe a
Nothing)
GitDist GitBranch{FilePath
Maybe FilePath
$sel:repo:GitBranch :: GitBranch -> Maybe FilePath
$sel:ref:GitBranch :: GitBranch -> FilePath
repo :: Maybe FilePath
ref :: FilePath
..} -> do
GHCupPath
tmpUnpack <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadUnliftIO m, HasLog env,
MonadCatch m, MonadThrow m, MonadMask m, MonadIO m) =>
m GHCupPath
mkGhcupTmpDir
let git :: [FilePath] -> m (Either ProcessError ())
git [FilePath]
args = forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasLog env, HasDirs env,
MonadIO m, MonadThrow m) =>
FilePath
-> [FilePath]
-> Maybe FilePath
-> FilePath
-> Maybe [(FilePath, FilePath)]
-> m (Either ProcessError ())
execLogged FilePath
"git" (FilePath
"--no-pager"forall a. a -> [a] -> [a]
:[FilePath]
args) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack) FilePath
"git" forall a. Maybe a
Nothing
forall e (es :: [*]) (es' :: [*]) a (m :: * -> *).
(Monad m, e :< es') =>
(V es -> e) -> Excepts es m a -> Excepts es' m a
reThrowAll @_ @'[ProcessError] forall (xs :: [*]).
(HFErrorProject (V xs), ToVariantMaybe DownloadFailed xs,
PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) =>
V xs -> DownloadFailed
DownloadFailed forall a b. (a -> b) -> a -> b
$ do
let rep :: FilePath
rep = forall a. a -> Maybe a -> a
fromMaybe FilePath
"https://github.com/haskell/haskell-language-server.git" Maybe FilePath
repo
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"Fetching git repo " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
rep forall a. Semigroup a => a -> a -> a
<> Text
" at ref " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
ref forall a. Semigroup a => a -> a -> a
<> Text
" (this may take a while)"
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM forall a b. (a -> b) -> a -> b
$ [FilePath] -> m (Either ProcessError ())
git [ FilePath
"init" ]
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM forall a b. (a -> b) -> a -> b
$ [FilePath] -> m (Either ProcessError ())
git [ FilePath
"remote"
, FilePath
"add"
, FilePath
"origin"
, forall a. IsString a => FilePath -> a
fromString FilePath
rep ]
[FilePath]
remoteBranches <- forall e (es' :: [*]) (es'' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, e :< es, LiftVariant (Remove e es) es',
LiftVariant es'' es') =>
(e -> Excepts es'' m a) -> Excepts es m a -> Excepts es' m a
catchE @ProcessError @'[ProcessError] @'[] (\ProcessError
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> [FilePath]
processBranches forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m) =>
[FilePath] -> FilePath -> Excepts '[ProcessError] m Text
gitOut [FilePath
"ls-remote", FilePath
"--heads", FilePath
"origin"] (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack)
let shallow_clone :: Bool
shallow_clone
| Bool
gitDescribeRequested = Bool
False
| FilePath -> Bool
isCommitHash FilePath
ref = Bool
True
| forall a. IsString a => FilePath -> a
fromString FilePath
ref forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
remoteBranches = Bool
True
| Bool
otherwise = Bool
False
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"Shallow clone: " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show Bool
shallow_clone)
let fetch_args :: [FilePath]
fetch_args
| Bool
shallow_clone = [FilePath
"fetch", FilePath
"--depth", FilePath
"1", FilePath
"--quiet", FilePath
"origin", forall a. IsString a => FilePath -> a
fromString FilePath
ref]
| Bool
otherwise = [FilePath
"fetch", FilePath
"--tags", FilePath
"--quiet", FilePath
"origin" ]
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM forall a b. (a -> b) -> a -> b
$ [FilePath] -> m (Either ProcessError ())
git [FilePath]
fetch_args
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM forall a b. (a -> b) -> a -> b
$ [FilePath] -> m (Either ProcessError ())
git [ FilePath
"checkout", forall a. IsString a => FilePath -> a
fromString FilePath
ref ]
Maybe Text
git_describe <- if Bool
shallow_clone
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m) =>
[FilePath] -> FilePath -> Excepts '[ProcessError] m Text
gitOut [FilePath
"describe", FilePath
"--tags"] (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack)
Text
chash <- forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m) =>
[FilePath] -> FilePath -> Excepts '[ProcessError] m Text
gitOut [FilePath
"rev-parse", FilePath
"HEAD" ] (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack)
Version
tver <- forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
FilePath -> m Version
getCabalVersion (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack FilePath -> FilePath -> FilePath
</> FilePath
"haskell-language-server.cabal")
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (es :: [*]) (m :: * -> *) env.
(Pretty (V es), HFErrorProject (V es), MonadReader env m,
HasLog env, MonadIO m, Monad m) =>
Excepts es m () -> Excepts '[] m ()
catchWarn forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM @_ @'[ProcessError] forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
Platform -> FilePath -> m (Either ProcessError ())
darwinNotarization Platform
_rPlatform (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"Examining git ref " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
ref forall a. Semigroup a => a -> a -> a
<> Text
"\n " forall a. Semigroup a => a -> a -> a
<>
Text
"HLS version (from cabal file): " forall a. Semigroup a => a -> a -> a
<> Version -> Text
prettyVer Version
tver forall a. Semigroup a => a -> a -> a
<>
(if Bool -> Bool
not Bool
shallow_clone then Text
"\n " forall a. Semigroup a => a -> a -> a
<> Text
"'git describe' output: " forall a. Semigroup a => a -> a -> a
<> forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
git_describe else forall a. Monoid a => a
mempty) forall a. Semigroup a => a -> a -> a
<>
(if FilePath -> Bool
isCommitHash FilePath
ref then forall a. Monoid a => a
mempty else Text
"\n " forall a. Semigroup a => a -> a -> a
<> Text
"commit hash: " forall a. Semigroup a => a -> a -> a
<> Text
chash)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GHCupPath
tmpUnpack, GHCupPath
tmpUnpack, Version
tver, Maybe Text
git_describe)
Version
installVer <- case Either Bool Version
ov of
Left Bool
True -> case Maybe Text
git_describe of
Just Text
h -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => e -> FilePath
displayException) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either ParsingError Version
version forall a b. (a -> b) -> a -> b
$ Text
h
Maybe Text
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Version
tver
Left Bool
False -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Version
tver
Right Version
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Version
v
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) (e :: [*]) a.
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
MonadMask m, HasLog env, MonadUnliftIO m, MonadFail m,
MonadCatch m) =>
GHCupPath -> Excepts e m a -> Excepts e m a
runBuildAction
GHCupPath
tmpUnpack
(forall e (es :: [*]) (es' :: [*]) a (m :: * -> *).
(Monad m, e :< es') =>
(V es -> e) -> Excepts es m a -> Excepts es' m a
reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, ContentLengthError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (forall (es :: [*]).
(ToVariantMaybe BuildFailed es, PopVariant BuildFailed es,
Pretty (V es), Show (V es), HFErrorProject (V es)) =>
FilePath -> V es -> BuildFailed
BuildFailed forall a b. (a -> b) -> a -> b
$ GHCupPath -> FilePath
fromGHCupPath GHCupPath
workdir) forall a b. (a -> b) -> a -> b
$ do
let tmpInstallDir :: FilePath
tmpInstallDir = GHCupPath -> FilePath
fromGHCupPath GHCupPath
workdir FilePath -> FilePath -> FilePath
</> FilePath
"out"
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
createDirRecursive' FilePath
tmpInstallDir
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(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, ContentLengthError,
GPGError]
m
()
applyAnyPatch Maybe (Either FilePath [URI])
patches (GHCupPath -> FilePath
fromGHCupPath GHCupPath
workdir)
FilePath
cp <- case Maybe (Either FilePath URI)
cabalProject of
Just (Left FilePath
cp)
| FilePath -> Bool
isAbsolute FilePath
cp -> do
forall (xs :: [*]) (m :: * -> *).
(CopyError :< xs, MonadCatch m, MonadIO m) =>
FilePath -> FilePath -> Bool -> Excepts xs m ()
copyFileE FilePath
cp (GHCupPath -> FilePath
fromGHCupPath GHCupPath
workdir FilePath -> FilePath -> FilePath
</> FilePath
"cabal.project") Bool
False
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
"cabal.project"
| Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> FilePath
takeFileName FilePath
cp)
Just (Right URI
uri) -> do
GHCupPath
tmpUnpack' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, HasSettings env,
MonadUnliftIO m, MonadCatch m, MonadResource m, MonadThrow m,
MonadMask m, MonadIO m) =>
m GHCupPath
withGHCupTmpDir
FilePath
cp <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasDirs env, MonadMask m,
MonadThrow m, HasLog env, MonadIO m) =>
URI
-> Maybe URI
-> Maybe Text
-> Maybe Integer
-> FilePath
-> Maybe FilePath
-> Bool
-> Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
FilePath
download URI
uri forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack') (forall a. a -> Maybe a
Just FilePath
"cabal.project") Bool
False
forall (xs :: [*]) (m :: * -> *).
(CopyError :< xs, MonadCatch m, MonadIO m) =>
FilePath -> FilePath -> Bool -> Excepts xs m ()
copyFileE FilePath
cp (GHCupPath -> FilePath
fromGHCupPath GHCupPath
workdir FilePath -> FilePath -> FilePath
</> FilePath
"cabal.project") Bool
False
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
"cabal.project"
Maybe (Either FilePath URI)
Nothing
| HackageDist Version
_ <- HLSVer
targetHLS -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
B.writeFile (GHCupPath -> FilePath
fromGHCupPath GHCupPath
workdir FilePath -> FilePath -> FilePath
</> FilePath
"cabal.project") ByteString
"packages: ./"
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
"cabal.project"
| RemoteDist URI
_ <- HLSVer
targetHLS -> do
let cabalFile :: FilePath
cabalFile = GHCupPath -> FilePath
fromGHCupPath GHCupPath
workdir FilePath -> FilePath -> FilePath
</> FilePath
"cabal.project"
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Bool
doesFileExist FilePath
cabalFile) forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
B.writeFile FilePath
cabalFile ByteString
"packages: ./"
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
"cabal.project"
| Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
"cabal.project"
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe URI
cabalProjectLocal forall a b. (a -> b) -> a -> b
$ \URI
uri -> do
GHCupPath
tmpUnpack' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, HasSettings env,
MonadUnliftIO m, MonadCatch m, MonadResource m, MonadThrow m,
MonadMask m, MonadIO m) =>
m GHCupPath
withGHCupTmpDir
FilePath
cpl <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasDirs env, MonadMask m,
MonadThrow m, HasLog env, MonadIO m) =>
URI
-> Maybe URI
-> Maybe Text
-> Maybe Integer
-> FilePath
-> Maybe FilePath
-> Bool
-> Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
FilePath
download URI
uri forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack') (forall a. a -> Maybe a
Just (FilePath
cp FilePath -> FilePath -> FilePath
<.> FilePath
"local")) Bool
False
forall (xs :: [*]) (m :: * -> *).
(CopyError :< xs, MonadCatch m, MonadIO m) =>
FilePath -> FilePath -> Bool -> Excepts xs m ()
copyFileE FilePath
cpl (GHCupPath -> FilePath
fromGHCupPath GHCupPath
workdir FilePath -> FilePath -> FilePath
</> FilePath
cp FilePath -> FilePath -> FilePath
<.> FilePath
"local") Bool
False
[FilePath]
artifacts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a. Ord a => [a] -> [a]
sort [Version]
ghcs) forall a b. (a -> b) -> a -> b
$ \Version
ghc -> do
let ghcInstallDir :: FilePath
ghcInstallDir = FilePath
tmpInstallDir FilePath -> FilePath -> FilePath
</> Text -> FilePath
T.unpack (Version -> Text
prettyVer Version
ghc)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
createDirRecursive' FilePath
tmpInstallDir
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"Building HLS " forall a. Semigroup a => a -> a -> a
<> Version -> Text
prettyVer Version
installVer forall a. Semigroup a => a -> a -> a
<> Text
" for GHC version " forall a. Semigroup a => a -> a -> a
<> Version -> Text
prettyVer Version
ghc
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM @_ @'[ProcessError] forall a b. (a -> b) -> a -> b
$
forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasLog env, HasDirs env,
MonadIO m, MonadThrow m) =>
FilePath
-> [FilePath]
-> Maybe FilePath
-> FilePath
-> Maybe [(FilePath, FilePath)]
-> m (Either ProcessError ())
execLogged FilePath
"cabal" ( [ FilePath
"v2-install"
, FilePath
"-w"
, FilePath
"ghc-" forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack (Version -> Text
prettyVer Version
ghc)
, FilePath
"--install-method=copy"
] forall a. [a] -> [a] -> [a]
++
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Int
j -> [FilePath
"--jobs=" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Int
j]) Maybe Int
jobs forall a. [a] -> [a] -> [a]
++
[ FilePath
"--overwrite-policy=always"
, FilePath
"--disable-profiling"
, FilePath
"--disable-tests"
, FilePath
"--installdir=" forall a. Semigroup a => a -> a -> a
<> FilePath
ghcInstallDir
, FilePath
"--project-file=" forall a. Semigroup a => a -> a -> a
<> FilePath
cp
] forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> FilePath
T.unpack [Text]
cabalArgs forall a. [a] -> [a] -> [a]
++ [
FilePath
"exe:haskell-language-server"
, FilePath
"exe:haskell-language-server-wrapper"]
)
(forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ GHCupPath -> FilePath
fromGHCupPath GHCupPath
workdir)
FilePath
"cabal"
forall a. Maybe a
Nothing
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
ghcInstallDir
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
artifacts forall a b. (a -> b) -> a -> b
$ \FilePath
artifact -> do
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show FilePath
artifact)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
renameFile (FilePath
artifact FilePath -> FilePath -> FilePath
</> FilePath
"haskell-language-server" FilePath -> FilePath -> FilePath
<.> FilePath
exeExt)
(FilePath
tmpInstallDir FilePath -> FilePath -> FilePath
</> FilePath
"haskell-language-server-" forall a. Semigroup a => a -> a -> a
<> FilePath -> FilePath
takeFileName FilePath
artifact FilePath -> FilePath -> FilePath
<.> FilePath
exeExt)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
renameFile (FilePath
artifact FilePath -> FilePath -> FilePath
</> FilePath
"haskell-language-server-wrapper" FilePath -> FilePath -> FilePath
<.> FilePath
exeExt)
(FilePath
tmpInstallDir FilePath -> FilePath -> FilePath
</> FilePath
"haskell-language-server-wrapper" FilePath -> FilePath -> FilePath
<.> FilePath
exeExt)
case InstallDir
installDir of
IsolateDir FilePath
isoDir -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"isolated installing HLS to " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
isoDir
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, MonadFail m, HasLog env, MonadCatch m,
MonadIO m) =>
FilePath
-> InstallDirResolved
-> Version
-> Bool
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installHLSUnpackedLegacy FilePath
tmpInstallDir (FilePath -> InstallDirResolved
IsolateDirResolved FilePath
isoDir) Version
installVer Bool
True
InstallDir
GHCupInternal -> do
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, MonadFail m, HasLog env, MonadCatch m,
MonadIO m) =>
FilePath
-> InstallDirResolved
-> Version
-> Bool
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installHLSUnpackedLegacy FilePath
tmpInstallDir (FilePath -> InstallDirResolved
GHCupBinDir FilePath
binDir) Version
installVer Bool
True
)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Version
installVer
where
gitDescribeRequested :: Bool
gitDescribeRequested = case Either Bool Version
ov of
Left Bool
b -> Bool
b
Either Bool Version
_ -> Bool
False
setHLS :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadIO m
, MonadMask m
, MonadFail m
, MonadUnliftIO m
)
=> Version
-> SetHLS
-> Maybe FilePath
-> Excepts '[NotInstalled] m ()
setHLS :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadIO m,
MonadMask m, MonadFail m, MonadUnliftIO m) =>
Version -> SetHLS -> Maybe FilePath -> Excepts '[NotInstalled] m ()
setHLS Version
ver SetHLS
shls Maybe FilePath
mBinDir = do
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) =>
Version -> m Bool
hlsInstalled Version
ver) (forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (Tool -> GHCTargetVersion -> NotInstalled
NotInstalled Tool
HLS (Maybe Text -> Version -> GHCTargetVersion
GHCTargetVersion forall a. Maybe a
Nothing Version
ver)))
FilePath
binDir <- case Maybe FilePath
mBinDir of
Just FilePath
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
x
Maybe FilePath
Nothing -> do
Dirs {$sel:binDir:Dirs :: Dirs -> FilePath
binDir = FilePath
f} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
f
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe FilePath
mBinDir) forall a b. (a -> b) -> a -> b
$
case SetHLS
shls of
SetHLS
SetHLS_XYZ -> forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, HasLog env,
MonadThrow m, MonadFail m, MonadMask m) =>
Version -> Excepts '[NotInstalled] m ()
rmMinorHLSSymlinks Version
ver
SetHLS
SetHLSOnly -> forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadThrow m,
MonadFail m, MonadIO m, MonadMask m) =>
Excepts '[NotInstalled] m ()
rmPlainHLS
case SetHLS
shls of
SetHLS
SetHLS_XYZ -> do
[FilePath]
bins <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) =>
Version -> Maybe Version -> m [FilePath]
hlsInternalServerScripts Version
ver forall a. Maybe a
Nothing
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
bins forall a b. (a -> b) -> a -> b
$ \FilePath
f -> do
let fname :: FilePath
fname = FilePath -> FilePath
takeFileName FilePath
f
FilePath
destL <- forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
FilePath -> FilePath -> m FilePath
binarySymLinkDestination FilePath
binDir FilePath
f
let target :: FilePath
target = if FilePath
"haskell-language-server-wrapper" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
fname
then FilePath
fname forall a. Semigroup a => a -> a -> a
<> FilePath
"-" forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack (Version -> Text
prettyVer Version
ver) forall a. Semigroup a => a -> a -> a
<> FilePath
exeExt
else FilePath
fname forall a. Semigroup a => a -> a -> a
<> FilePath
"~" forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack (Version -> Text
prettyVer Version
ver) forall a. Semigroup a => a -> a -> a
<> FilePath
exeExt
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadMask m, MonadThrow m, HasLog env, MonadIO m,
MonadReader env m, HasDirs env, MonadUnliftIO m, MonadFail m) =>
FilePath -> FilePath -> m ()
createLink FilePath
destL (FilePath
binDir FilePath -> FilePath -> FilePath
</> FilePath
target)
SetHLS
SetHLSOnly -> do
[FilePath]
bins <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
Version -> Maybe Version -> m [FilePath]
hlsServerBinaries Version
ver forall a. Maybe a
Nothing
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
bins) forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE forall a b. (a -> b) -> a -> b
$ Tool -> GHCTargetVersion -> NotInstalled
NotInstalled Tool
HLS (Maybe Text -> Version -> GHCTargetVersion
GHCTargetVersion forall a. Maybe a
Nothing Version
ver)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
bins forall a b. (a -> b) -> a -> b
$ \FilePath
f -> do
let destL :: FilePath
destL = FilePath
f
let target :: FilePath
target = (forall a. Semigroup a => a -> a -> a
<> FilePath
exeExt) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [[a]]
splitOn FilePath
"~" forall a b. (a -> b) -> a -> b
$ FilePath
f
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadMask m, MonadThrow m, HasLog env, MonadIO m,
MonadReader env m, HasDirs env, MonadUnliftIO m, MonadFail m) =>
FilePath -> FilePath -> m ()
createLink FilePath
destL (FilePath
binDir FilePath -> FilePath -> FilePath
</> FilePath
target)
let destL :: FilePath
destL = FilePath
"haskell-language-server-wrapper-" forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack (Version -> Text
prettyVer Version
ver) forall a. Semigroup a => a -> a -> a
<> FilePath
exeExt
let wrapper :: FilePath
wrapper = FilePath
binDir FilePath -> FilePath -> FilePath
</> FilePath
"haskell-language-server-wrapper" forall a. Semigroup a => a -> a -> a
<> FilePath
exeExt
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadMask m, MonadThrow m, HasLog env, MonadIO m,
MonadReader env m, HasDirs env, MonadUnliftIO m, MonadFail m) =>
FilePath -> FilePath -> m ()
createLink FilePath
destL FilePath
wrapper
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe FilePath
mBinDir) forall a b. (a -> b) -> a -> b
$
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadThrow m,
MonadCatch m, MonadIO m) =>
m ()
warnAboutHlsCompatibility
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO (Maybe FilePath)
isShadowed FilePath
wrapper) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe FilePath
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just FilePath
pa -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall e. (Pretty e, HFErrorProject e) => e -> FilePath
prettyHFError (Tool -> FilePath -> FilePath -> Version -> ToolShadowed
ToolShadowed Tool
HLS FilePath
pa FilePath
wrapper Version
ver)
unsetHLS :: ( MonadMask m
, MonadReader env m
, HasDirs env
, MonadIO m)
=> m ()
unsetHLS :: forall (m :: * -> *) env.
(MonadMask m, MonadReader env m, HasDirs env, MonadIO m) =>
m ()
unsetHLS = do
Dirs {FilePath
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: FilePath
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..} <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
let wrapper :: FilePath
wrapper = FilePath
binDir FilePath -> FilePath -> FilePath
</> FilePath
"haskell-language-server-wrapper" forall a. Semigroup a => a -> a -> a
<> FilePath
exeExt
[FilePath]
bins <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []) forall a b. (a -> b) -> a -> b
$ forall a. FilePath -> Parsec Void Text a -> IO [FilePath]
findFiles'
FilePath
binDir
(forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"haskell-language-server-" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parsec Void Text PVP
pvp' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk (FilePath -> Text
T.pack FilePath
exeExt) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
MP.eof)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
bins (forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadMask m) =>
FilePath -> m ()
rmLink forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
binDir FilePath -> FilePath -> FilePath
</>))
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadMask m) =>
FilePath -> m ()
rmLink FilePath
wrapper
rmHLSVer :: ( MonadMask m
, MonadReader env m
, HasDirs env
, MonadThrow m
, HasLog env
, MonadIO m
, MonadFail m
, MonadCatch m
, MonadUnliftIO m
)
=> Version
-> Excepts '[NotInstalled, UninstallFailed] m ()
rmHLSVer :: forall (m :: * -> *) env.
(MonadMask m, MonadReader env m, HasDirs env, MonadThrow m,
HasLog env, MonadIO m, MonadFail m, MonadCatch m,
MonadUnliftIO m) =>
Version -> Excepts '[NotInstalled, UninstallFailed] m ()
rmHLSVer Version
ver = do
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) =>
Version -> m Bool
hlsInstalled Version
ver) forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (Tool -> GHCTargetVersion -> NotInstalled
NotInstalled Tool
HLS (Maybe Text -> Version -> GHCTargetVersion
GHCTargetVersion forall a. Maybe a
Nothing Version
ver))
Maybe Version
isHlsSet <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m,
MonadCatch m) =>
m (Maybe Version)
hlsSet
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, HasLog env,
MonadThrow m, MonadFail m, MonadMask m) =>
Version -> Excepts '[NotInstalled] m ()
rmMinorHLSSymlinks Version
ver
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. a -> Maybe a
Just Version
ver forall a. Eq a => a -> a -> Bool
== Maybe Version
isHlsSet) forall a b. (a -> b) -> a -> b
$ do
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadThrow m,
MonadFail m, MonadIO m, MonadMask m) =>
Excepts '[NotInstalled] m ()
rmPlainHLS
GHCupPath
hlsDir' <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
Version -> m GHCupPath
ghcupHLSDir Version
ver
let hlsDir :: FilePath
hlsDir = GHCupPath -> FilePath
fromGHCupPath GHCupPath
hlsDir'
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) env.
(MonadIO m, MonadCatch m, MonadReader env m, HasDirs env,
MonadFail m) =>
Tool -> GHCTargetVersion -> m (Maybe [FilePath])
getInstalledFiles Tool
HLS (Version -> GHCTargetVersion
mkTVer Version
ver)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just [FilePath]
files -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"Removing files safely from: " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
hlsDir
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
files (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
NoSuchThing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasDirs env) =>
FilePath -> m ()
recycleFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\FilePath
f -> FilePath
hlsDir FilePath -> FilePath -> FilePath
</> FilePath -> FilePath
dropDrive FilePath
f))
forall (m :: * -> *).
(MonadMask m, MonadIO m, MonadCatch m) =>
FilePath -> m ()
removeEmptyDirsRecursive FilePath
hlsDir
[FilePath]
survivors <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
[IOErrorType] -> a -> m a -> m a
hideErrorDef [IOErrorType
doesNotExistErrorType] [] forall a b. (a -> b) -> a -> b
$ FilePath -> IO [FilePath]
listDirectory FilePath
hlsDir
FilePath
f <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env) =>
Tool -> GHCTargetVersion -> m FilePath
recordedInstallationFile Tool
HLS (Version -> GHCTargetVersion
mkTVer Version
ver)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasDirs env) =>
FilePath -> m ()
recycleFile FilePath
f
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
survivors)) forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> UninstallFailed
UninstallFailed FilePath
hlsDir [FilePath]
survivors
Maybe [FilePath]
Nothing -> do
Bool
isDir <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesDirectoryExist FilePath
hlsDir
Bool
isSyml <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
pathIsSymbolicLink FilePath
hlsDir
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isDir Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isSyml) forall a b. (a -> b) -> a -> b
$ do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"Removing legacy directory recursively: " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
hlsDir
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadMask m) =>
GHCupPath -> m ()
recyclePathForcibly GHCupPath
hlsDir'
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. a -> Maybe a
Just Version
ver forall a. Eq a => a -> a -> Bool
== Maybe Version
isHlsSet) forall a b. (a -> b) -> a -> b
$ do
[Version]
hlsVers <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [Either a b] -> [b]
rights forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) =>
m [Either FilePath Version]
getInstalledHLSs
case forall a. [a] -> Maybe a
headMay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a. a -> Down a
Down) forall a b. (a -> b) -> a -> b
$ [Version]
hlsVers of
Just Version
latestver -> forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadIO m,
MonadMask m, MonadFail m, MonadUnliftIO m) =>
Version -> SetHLS -> Maybe FilePath -> Excepts '[NotInstalled] m ()
setHLS Version
latestver SetHLS
SetHLSOnly forall a. Maybe a
Nothing
Maybe Version
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
getCabalVersion :: (MonadIO m, MonadFail m) => FilePath -> m Version
getCabalVersion :: forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
FilePath -> m Version
getCabalVersion FilePath
fp = do
ByteString
contents <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
B.readFile FilePath
fp
GenericPackageDescription
gpd <- case ByteString -> Maybe GenericPackageDescription
parseGenericPackageDescriptionMaybe ByteString
contents of
Maybe GenericPackageDescription
Nothing -> forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall a b. (a -> b) -> a -> b
$ FilePath
"could not parse cabal file: " forall a. Semigroup a => a -> a -> a
<> FilePath
fp
Just GenericPackageDescription
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GenericPackageDescription
r
let tver :: Version
tver = (\NonEmpty VChunk
c -> Maybe Word -> NonEmpty VChunk -> [VChunk] -> Maybe Text -> Version
Version forall a. Maybe a
Nothing NonEmpty VChunk
c [] forall a. Maybe a
Nothing)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> NonEmpty a
NE.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. [a] -> NonEmpty a
NE.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> VUnit
digits forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> [Int]
versionNumbers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> Version
pkgVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageDescription -> PackageIdentifier
package
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription -> PackageDescription
packageDescription
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription
gpd
forall (f :: * -> *) a. Applicative f => a -> f a
pure Version
tver