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