{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module GHCup.GHC 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 GHCup.Prelude.Version.QQ
import GHCup.Prelude.MegaParsec
import Codec.Archive ( ArchiveResult )
import Control.Applicative
import Control.Concurrent ( threadDelay )
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.Maybe
import Data.List.NonEmpty ( NonEmpty((:|)) )
import Data.String ( fromString )
import Data.Text ( Text )
import Data.Time.Clock
import Data.Time.Format.ISO8601
import Data.Versions hiding ( patch )
import GHC.IO.Exception
import Haskus.Utils.Variant.Excepts
import Language.Haskell.TH
import Language.Haskell.TH.Syntax ( Quasi(qAddDependentFile) )
import Optics
import Prelude hiding ( abs
, writeFile
)
import System.Environment
import System.FilePath
import System.IO.Error
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix
import URI.ByteString
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as E
import qualified Text.Megaparsec as MP
data GHCVer = SourceDist Version
| GitDist GitBranch
| RemoteDist URI
testGHCVer :: ( MonadFail m
, MonadMask m
, MonadCatch m
, MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, HasGHCupInfo env
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
)
=> GHCTargetVersion
-> [T.Text]
-> Excepts
'[ DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, NoDownload
, ArchiveResult
, TarDirDoesNotExist
, UnknownArchive
, TestFailed
]
m
()
testGHCVer :: forall (m :: * -> *) env.
(MonadFail m, MonadMask m, MonadCatch m, MonadReader env m,
HasDirs env, HasSettings env, HasPlatformReq env, HasGHCupInfo env,
HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m) =>
GHCTargetVersion
-> [Text]
-> Excepts
'[DigestError, ContentLengthError, GPGError, DownloadFailed,
NoDownload, ArchiveResult, TarDirDoesNotExist, UnknownArchive,
TestFailed]
m
()
testGHCVer GHCTargetVersion
ver [Text]
addMakeArgs = do
GHCupInfo { $sel:_ghcupDownloads:GHCupInfo :: GHCupInfo -> GHCupDownloads
_ghcupDownloads = GHCupDownloads
dls } <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "ghcupInfo" A_Lens env GHCupInfo) =>
m GHCupInfo
getGHCupInfo
DownloadInfo
dlInfo <-
forall k (is :: [*]) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
GHC forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix GHCTargetVersion
ver forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' VersionInfo (Maybe DownloadInfo)
viTestDL forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall a b. Prism (Maybe a) (Maybe b) a b
_Just) GHCupDownloads
dls
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
Maybe a -> e -> Excepts es m a
?? NoDownload
NoDownload
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadFail m, MonadMask m, MonadCatch m, MonadReader env m,
HasDirs env, HasSettings env, HasPlatformReq env, HasGHCupInfo env,
HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m) =>
DownloadInfo
-> GHCTargetVersion
-> [Text]
-> Excepts
'[DigestError, ContentLengthError, GPGError, DownloadFailed,
NoDownload, ArchiveResult, TarDirDoesNotExist, UnknownArchive,
TestFailed]
m
()
testGHCBindist DownloadInfo
dlInfo GHCTargetVersion
ver [Text]
addMakeArgs
testGHCBindist :: ( MonadFail m
, MonadMask m
, MonadCatch m
, MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, HasGHCupInfo env
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
)
=> DownloadInfo
-> GHCTargetVersion
-> [T.Text]
-> Excepts
'[ DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, NoDownload
, ArchiveResult
, TarDirDoesNotExist
, UnknownArchive
, TestFailed
]
m
()
testGHCBindist :: forall (m :: * -> *) env.
(MonadFail m, MonadMask m, MonadCatch m, MonadReader env m,
HasDirs env, HasSettings env, HasPlatformReq env, HasGHCupInfo env,
HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m) =>
DownloadInfo
-> GHCTargetVersion
-> [Text]
-> Excepts
'[DigestError, ContentLengthError, GPGError, DownloadFailed,
NoDownload, ArchiveResult, TarDirDoesNotExist, UnknownArchive,
TestFailed]
m
()
testGHCBindist DownloadInfo
dlinfo GHCTargetVersion
ver [Text]
addMakeArgs = do
FilePath
dl <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadMask m,
MonadResource m, MonadThrow m, HasLog env, MonadIO m,
MonadUnliftIO m) =>
DownloadInfo
-> Maybe FilePath
-> Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
FilePath
downloadCached DownloadInfo
dlinfo forall a. Maybe a
Nothing
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadMask m, MonadCatch m, MonadReader env m, HasDirs env,
HasPlatformReq env, HasSettings env, MonadThrow m, HasLog env,
MonadIO m, MonadUnliftIO m, MonadFail m, MonadResource m) =>
FilePath
-> Maybe TarDir
-> GHCTargetVersion
-> [Text]
-> Excepts
'[ArchiveResult, UnknownArchive, TarDirDoesNotExist, TestFailed]
m
()
testPackedGHC FilePath
dl (forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Lens' DownloadInfo (Maybe TarDir)
dlSubdir DownloadInfo
dlinfo) GHCTargetVersion
ver [Text]
addMakeArgs
testPackedGHC :: ( MonadMask m
, MonadCatch m
, MonadReader env m
, HasDirs env
, HasPlatformReq env
, HasSettings env
, MonadThrow m
, HasLog env
, MonadIO m
, MonadUnliftIO m
, MonadFail m
, MonadResource m
)
=> FilePath
-> Maybe TarDir
-> GHCTargetVersion
-> [T.Text]
-> Excepts
'[ ArchiveResult, UnknownArchive, TarDirDoesNotExist, TestFailed ] m ()
testPackedGHC :: forall (m :: * -> *) env.
(MonadMask m, MonadCatch m, MonadReader env m, HasDirs env,
HasPlatformReq env, HasSettings env, MonadThrow m, HasLog env,
MonadIO m, MonadUnliftIO m, MonadFail m, MonadResource m) =>
FilePath
-> Maybe TarDir
-> GHCTargetVersion
-> [Text]
-> Excepts
'[ArchiveResult, UnknownArchive, TarDirDoesNotExist, TestFailed]
m
()
testPackedGHC FilePath
dl Maybe TarDir
msubdir GHCTargetVersion
ver [Text]
addMakeArgs = do
GHCupPath
tmpUnpack <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadUnliftIO m, HasLog env,
MonadCatch m, MonadThrow m, MonadMask m, MonadIO m) =>
m GHCupPath
mkGhcupTmpDir
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (e :: [*]) (m :: * -> *) a env.
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
MonadMask m, HasLog env, MonadUnliftIO m, MonadFail m,
MonadCatch m) =>
GHCupPath -> Excepts e m a -> Excepts e m a
cleanUpOnError GHCupPath
tmpUnpack (forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m) =>
FilePath
-> FilePath -> Excepts '[UnknownArchive, ArchiveResult] m ()
unpackToDir (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack) FilePath
dl)
GHCupPath
workdir <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure GHCupPath
tmpUnpack)
(forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m,
MonadCatch m) =>
GHCupPath -> TarDir -> Excepts '[TarDirDoesNotExist] m GHCupPath
intoSubdir GHCupPath
tmpUnpack)
Maybe TarDir
msubdir
forall e (es :: [*]) (es' :: [*]) a (m :: * -> *).
(Monad m, e :< es') =>
(V es -> e) -> Excepts es m a -> Excepts es' m a
reThrowAll @_ @'[ArchiveResult, UnknownArchive, TarDirDoesNotExist, ProcessError]
(forall (es :: [*]).
(ToVariantMaybe TestFailed es, PopVariant TestFailed es,
Pretty (V es), Show (V es), HFErrorProject (V es)) =>
FilePath -> V es -> TestFailed
TestFailed (GHCupPath -> FilePath
fromGHCupPath GHCupPath
workdir)) forall a b. (a -> b) -> a -> b
$ forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) (e :: [*]) a.
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
MonadMask m, HasLog env, MonadUnliftIO m, MonadFail m,
MonadCatch m) =>
GHCupPath -> Excepts e m a -> Excepts e m a
runBuildAction GHCupPath
tmpUnpack
(forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadThrow m,
HasLog env, MonadIO m) =>
GHCupPath
-> GHCTargetVersion -> [Text] -> Excepts '[ProcessError] m ()
testUnpackedGHC GHCupPath
workdir GHCTargetVersion
ver [Text]
addMakeArgs)
testUnpackedGHC :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadThrow m
, HasLog env
, MonadIO m
)
=> GHCupPath
-> GHCTargetVersion
-> [T.Text]
-> Excepts '[ProcessError] m ()
testUnpackedGHC :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadThrow m,
HasLog env, MonadIO m) =>
GHCupPath
-> GHCTargetVersion -> [Text] -> Excepts '[ProcessError] m ()
testUnpackedGHC GHCupPath
path GHCTargetVersion
tver [Text]
addMakeArgs = do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"Testing GHC version " forall a. Semigroup a => a -> a -> a
<> GHCTargetVersion -> Text
tVerToText GHCTargetVersion
tver forall a. Semigroup a => a -> a -> a
<> Text
"!"
GHCupPath
ghcDir <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m GHCupPath
ghcupGHCDir GHCTargetVersion
tver
let ghcBinDir :: FilePath
ghcBinDir = GHCupPath -> FilePath
fromGHCupPath GHCupPath
ghcDir FilePath -> FilePath -> FilePath
</> FilePath
"bin"
[(FilePath, FilePath)]
env <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> Bool -> IO [(FilePath, FilePath)]
addToPath FilePath
ghcBinDir Bool
False
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadThrow m, MonadIO m, MonadReader env m, HasDirs env,
HasLog env, HasSettings env) =>
[FilePath]
-> Maybe FilePath
-> FilePath
-> Maybe [(FilePath, FilePath)]
-> m (Either ProcessError ())
make' (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> FilePath
T.unpack [Text]
addMakeArgs)
(forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ GHCupPath -> FilePath
fromGHCupPath GHCupPath
path)
FilePath
"ghc-test"
(forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (FilePath
"STAGE1_GHC", forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" (Text -> FilePath
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<> Text
"-")) (GHCTargetVersion -> Maybe Text
_tvTarget GHCTargetVersion
tver)
forall a. Semigroup a => a -> a -> a
<> FilePath
"ghc-"
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack (Version -> Text
prettyVer forall a b. (a -> b) -> a -> b
$ GHCTargetVersion -> Version
_tvVersion GHCTargetVersion
tver)) forall a. a -> [a] -> [a]
: [(FilePath, FilePath)]
env)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
fetchGHCSrc :: ( MonadFail m
, MonadMask m
, MonadCatch m
, MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, HasGHCupInfo env
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
)
=> GHCTargetVersion
-> Maybe FilePath
-> Excepts
'[ DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, NoDownload
]
m
FilePath
fetchGHCSrc :: forall (m :: * -> *) env.
(MonadFail m, MonadMask m, MonadCatch m, MonadReader env m,
HasDirs env, HasSettings env, HasPlatformReq env, HasGHCupInfo env,
HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m) =>
GHCTargetVersion
-> Maybe FilePath
-> Excepts
'[DigestError, ContentLengthError, GPGError, DownloadFailed,
NoDownload]
m
FilePath
fetchGHCSrc GHCTargetVersion
v Maybe FilePath
mfp = do
GHCupInfo { $sel:_ghcupDownloads:GHCupInfo :: GHCupInfo -> GHCupDownloads
_ghcupDownloads = GHCupDownloads
dls } <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "ghcupInfo" A_Lens env GHCupInfo) =>
m GHCupInfo
getGHCupInfo
DownloadInfo
dlInfo <-
forall k (is :: [*]) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
GHC forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix GHCTargetVersion
v forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' VersionInfo (Maybe DownloadInfo)
viSourceDL forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall a b. Prism (Maybe a) (Maybe b) a b
_Just) GHCupDownloads
dls
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
Maybe a -> e -> Excepts es m a
?? NoDownload
NoDownload
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadMask m,
MonadThrow m, HasLog env, MonadIO m, MonadUnliftIO m) =>
DownloadInfo
-> Maybe FilePath
-> Maybe FilePath
-> Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
FilePath
downloadCached' DownloadInfo
dlInfo forall a. Maybe a
Nothing Maybe FilePath
mfp
installGHCBindist :: ( MonadFail m
, MonadMask m
, MonadCatch m
, MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
)
=> DownloadInfo
-> GHCTargetVersion
-> InstallDir
-> Bool
-> [T.Text]
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
, DirNotEmpty
, ArchiveResult
, ProcessError
, UninstallFailed
, MergeFileTreeError
]
m
()
installGHCBindist :: forall (m :: * -> *) env.
(MonadFail m, MonadMask m, MonadCatch m, MonadReader env m,
HasDirs env, HasSettings env, HasPlatformReq env, HasLog env,
MonadResource m, MonadIO m, MonadUnliftIO m) =>
DownloadInfo
-> GHCTargetVersion
-> InstallDir
-> Bool
-> [Text]
-> Excepts
'[AlreadyInstalled, BuildFailed, DigestError, ContentLengthError,
GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive,
TarDirDoesNotExist, DirNotEmpty, ArchiveResult, ProcessError,
UninstallFailed, MergeFileTreeError]
m
()
installGHCBindist DownloadInfo
dlinfo GHCTargetVersion
tver InstallDir
installDir Bool
forceInstall [Text]
addConfArgs = do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"Requested to install GHC with " forall a. Semigroup a => a -> a -> a
<> GHCTargetVersion -> Text
tVerToText GHCTargetVersion
tver
Bool
regularGHCInstalled <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m Bool
ghcInstalled GHCTargetVersion
tver
if
| Bool -> Bool
not Bool
forceInstall
, Bool
regularGHCInstalled
, InstallDir
GHCupInternal <- InstallDir
installDir -> do
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE forall a b. (a -> b) -> a -> b
$ Tool -> Version -> AlreadyInstalled
AlreadyInstalled Tool
GHC (GHCTargetVersion -> Version
_tvVersion GHCTargetVersion
tver)
| Bool
forceInstall
, Bool
regularGHCInstalled
, InstallDir
GHCupInternal <- InstallDir
installDir -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo Text
"Removing the currently installed GHC version first!"
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, HasLog env,
MonadIO m, MonadFail m, MonadCatch m, MonadMask m,
MonadUnliftIO m) =>
GHCTargetVersion -> Excepts '[NotInstalled, UninstallFailed] m ()
rmGHCVer GHCTargetVersion
tver
| Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
FilePath
dl <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadMask m,
MonadResource m, MonadThrow m, HasLog env, MonadIO m,
MonadUnliftIO m) =>
DownloadInfo
-> Maybe FilePath
-> Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
FilePath
downloadCached DownloadInfo
dlinfo forall a. Maybe a
Nothing
Excepts
'[AlreadyInstalled, BuildFailed, DigestError, ContentLengthError,
GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive,
TarDirDoesNotExist, DirNotEmpty, ArchiveResult, ProcessError,
UninstallFailed, MergeFileTreeError]
m
()
toolchainSanityChecks
case InstallDir
installDir of
IsolateDir FilePath
isoDir -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"isolated installing GHC to " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
isoDir
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadMask m, MonadCatch m, MonadReader env m, HasDirs env,
HasPlatformReq env, HasSettings env, MonadThrow m, HasLog env,
MonadIO m, MonadUnliftIO m, MonadFail m, MonadResource m) =>
FilePath
-> Maybe TarDir
-> InstallDirResolved
-> GHCTargetVersion
-> Bool
-> [Text]
-> Excepts
'[BuildFailed, UnknownArchive, TarDirDoesNotExist, DirNotEmpty,
ArchiveResult, ProcessError, MergeFileTreeError]
m
()
installPackedGHC FilePath
dl (forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Lens' DownloadInfo (Maybe TarDir)
dlSubdir DownloadInfo
dlinfo) (FilePath -> InstallDirResolved
IsolateDirResolved FilePath
isoDir) GHCTargetVersion
tver Bool
forceInstall [Text]
addConfArgs
InstallDir
GHCupInternal -> do
GHCupPath
ghcdir <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m GHCupPath
ghcupGHCDir GHCTargetVersion
tver
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadMask m, MonadCatch m, MonadReader env m, HasDirs env,
HasPlatformReq env, HasSettings env, MonadThrow m, HasLog env,
MonadIO m, MonadUnliftIO m, MonadFail m, MonadResource m) =>
FilePath
-> Maybe TarDir
-> InstallDirResolved
-> GHCTargetVersion
-> Bool
-> [Text]
-> Excepts
'[BuildFailed, UnknownArchive, TarDirDoesNotExist, DirNotEmpty,
ArchiveResult, ProcessError, MergeFileTreeError]
m
()
installPackedGHC FilePath
dl (forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Lens' DownloadInfo (Maybe TarDir)
dlSubdir DownloadInfo
dlinfo) (GHCupPath -> InstallDirResolved
GHCupDir GHCupPath
ghcdir) GHCTargetVersion
tver Bool
forceInstall [Text]
addConfArgs
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadThrow m,
MonadFail m, MonadIO m, MonadCatch m, MonadMask m,
MonadUnliftIO m) =>
GHCTargetVersion -> Excepts '[NotInstalled] m ()
postGHCInstall GHCTargetVersion
tver
where
toolchainSanityChecks :: Excepts
'[AlreadyInstalled, BuildFailed, DigestError, ContentLengthError,
GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive,
TarDirDoesNotExist, DirNotEmpty, ArchiveResult, ProcessError,
UninstallFailed, MergeFileTreeError]
m
()
toolchainSanityChecks = do
[Maybe FilePath]
r <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath
"CC", FilePath
"LD"] (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO (Maybe FilePath)
lookupEnv)
case forall a. [Maybe a] -> [a]
catMaybes [Maybe FilePath]
r of
[] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
[FilePath]
_ -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Text
"CC/LD environment variable is set. This will change the compiler/linker"
forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<> Text
"GHC uses internally and can cause defunct GHC in some cases (e.g. in Anaconda"
forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<> Text
"environments). If you encounter problems, unset CC and LD and reinstall."
installPackedGHC :: ( MonadMask m
, MonadCatch m
, MonadReader env m
, HasDirs env
, HasPlatformReq env
, HasSettings env
, MonadThrow m
, HasLog env
, MonadIO m
, MonadUnliftIO m
, MonadFail m
, MonadResource m
)
=> FilePath
-> Maybe TarDir
-> InstallDirResolved
-> GHCTargetVersion
-> Bool
-> [T.Text]
-> Excepts
'[ BuildFailed
, UnknownArchive
, TarDirDoesNotExist
, DirNotEmpty
, ArchiveResult
, ProcessError
, MergeFileTreeError
] m ()
installPackedGHC :: forall (m :: * -> *) env.
(MonadMask m, MonadCatch m, MonadReader env m, HasDirs env,
HasPlatformReq env, HasSettings env, MonadThrow m, HasLog env,
MonadIO m, MonadUnliftIO m, MonadFail m, MonadResource m) =>
FilePath
-> Maybe TarDir
-> InstallDirResolved
-> GHCTargetVersion
-> Bool
-> [Text]
-> Excepts
'[BuildFailed, UnknownArchive, TarDirDoesNotExist, DirNotEmpty,
ArchiveResult, ProcessError, MergeFileTreeError]
m
()
installPackedGHC FilePath
dl Maybe TarDir
msubdir InstallDirResolved
inst GHCTargetVersion
ver Bool
forceInstall [Text]
addConfArgs = do
PlatformRequest {Maybe Versioning
Platform
Architecture
$sel:_rVersion:PlatformRequest :: PlatformRequest -> Maybe Versioning
$sel:_rPlatform:PlatformRequest :: PlatformRequest -> Platform
$sel:_rArch:PlatformRequest :: PlatformRequest -> Architecture
_rVersion :: Maybe Versioning
_rPlatform :: Platform
_rArch :: Architecture
..} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "pfreq" A_Lens env PlatformRequest) =>
m PlatformRequest
getPlatformReq
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
forceInstall
(forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m, MonadMask m) =>
InstallDirResolved -> Excepts '[DirNotEmpty] m ()
installDestSanityCheck InstallDirResolved
inst)
GHCupPath
tmpUnpack <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadUnliftIO m, HasLog env,
MonadCatch m, MonadThrow m, MonadMask m, MonadIO m) =>
m GHCupPath
mkGhcupTmpDir
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (e :: [*]) (m :: * -> *) a env.
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
MonadMask m, HasLog env, MonadUnliftIO m, MonadFail m,
MonadCatch m) =>
GHCupPath -> Excepts e m a -> Excepts e m a
cleanUpOnError GHCupPath
tmpUnpack (forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m) =>
FilePath
-> FilePath -> Excepts '[UnknownArchive, ArchiveResult] m ()
unpackToDir (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack) FilePath
dl)
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (es :: [*]) (m :: * -> *) env.
(Pretty (V es), HFErrorProject (V es), MonadReader env m,
HasLog env, MonadIO m, Monad m) =>
Excepts es m () -> Excepts '[] m ()
catchWarn forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM @_ @'[ProcessError] forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
Platform -> FilePath -> m (Either ProcessError ())
darwinNotarization Platform
_rPlatform (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack)
GHCupPath
workdir <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure GHCupPath
tmpUnpack)
(forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m,
MonadCatch m) =>
GHCupPath -> TarDir -> Excepts '[TarDirDoesNotExist] m GHCupPath
intoSubdir GHCupPath
tmpUnpack)
Maybe TarDir
msubdir
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) (e :: [*]) a.
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
MonadMask m, HasLog env, MonadUnliftIO m, MonadFail m,
MonadCatch m) =>
GHCupPath -> Excepts e m a -> Excepts e m a
runBuildAction GHCupPath
tmpUnpack
(forall env (m :: * -> *).
(MonadReader env m, HasPlatformReq env, HasDirs env,
HasSettings env, MonadThrow m, HasLog env, MonadIO m,
MonadUnliftIO m, MonadMask m, MonadResource m, MonadFail m) =>
GHCupPath
-> InstallDirResolved
-> GHCTargetVersion
-> Bool
-> [Text]
-> Excepts '[ProcessError, MergeFileTreeError] m ()
installUnpackedGHC GHCupPath
workdir InstallDirResolved
inst GHCTargetVersion
ver Bool
forceInstall [Text]
addConfArgs)
installUnpackedGHC :: ( MonadReader env m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, MonadThrow m
, HasLog env
, MonadIO m
, MonadUnliftIO m
, MonadMask m
, MonadResource m
, MonadFail m
)
=> GHCupPath
-> InstallDirResolved
-> GHCTargetVersion
-> Bool
-> [T.Text]
-> Excepts '[ProcessError, MergeFileTreeError] m ()
installUnpackedGHC :: forall env (m :: * -> *).
(MonadReader env m, HasPlatformReq env, HasDirs env,
HasSettings env, MonadThrow m, HasLog env, MonadIO m,
MonadUnliftIO m, MonadMask m, MonadResource m, MonadFail m) =>
GHCupPath
-> InstallDirResolved
-> GHCTargetVersion
-> Bool
-> [Text]
-> Excepts '[ProcessError, MergeFileTreeError] m ()
installUnpackedGHC GHCupPath
path InstallDirResolved
inst GHCTargetVersion
tver Bool
forceInstall [Text]
addConfArgs
| Bool
isWindows = do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo Text
"Installing GHC (this may take a while)"
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadMask m, MonadAsync m, MonadReader env m, HasDirs env,
HasLog env, MonadCatch m) =>
GHCupPath
-> InstallDirResolved
-> Tool
-> GHCTargetVersion
-> (FilePath -> FilePath -> m ())
-> Excepts '[MergeFileTreeError] m ()
mergeFileTree GHCupPath
path InstallDirResolved
inst Tool
GHC GHCTargetVersion
tver forall a b. (a -> b) -> a -> b
$ \FilePath
source FilePath
dest -> do
Maybe UTCTime
mtime <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (FilePath -> IO Bool
pathIsSymbolicLink FilePath
source) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO UTCTime
getModificationTime FilePath
source)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
forceInstall forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
InappropriateType forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasDirs env) =>
FilePath -> m ()
recycleFile FilePath
dest
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
moveFilePortable FilePath
source FilePath
dest
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe UTCTime
mtime forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> UTCTime -> IO ()
setModificationTime FilePath
dest
| Bool
otherwise = do
PlatformRequest {Maybe Versioning
Platform
Architecture
_rVersion :: Maybe Versioning
_rPlatform :: Platform
_rArch :: Architecture
$sel:_rVersion:PlatformRequest :: PlatformRequest -> Maybe Versioning
$sel:_rPlatform:PlatformRequest :: PlatformRequest -> Platform
$sel:_rArch:PlatformRequest :: PlatformRequest -> Architecture
..} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "pfreq" A_Lens env PlatformRequest) =>
m PlatformRequest
getPlatformReq
let ldOverride :: [FilePath]
ldOverride
| GHCTargetVersion -> Version
_tvVersion GHCTargetVersion
tver forall a. Ord a => a -> a -> Bool
>= [vver|8.2.2|]
, Platform
_rPlatform forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [LinuxDistro -> Platform
Linux LinuxDistro
Alpine, Platform
Darwin]
= [FilePath
"--disable-ld-override"]
| Bool
otherwise
= []
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo Text
"Installing GHC (this may take a while)"
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasLog env, HasDirs env,
MonadIO m, MonadThrow m) =>
FilePath
-> [FilePath]
-> Maybe FilePath
-> FilePath
-> Maybe [(FilePath, FilePath)]
-> m (Either ProcessError ())
execLogged FilePath
"sh"
(FilePath
"./configure" forall a. a -> [a] -> [a]
: (FilePath
"--prefix=" forall a. Semigroup a => a -> a -> a
<> InstallDirResolved -> FilePath
fromInstallDir InstallDirResolved
inst)
forall a. a -> [a] -> [a]
: (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (\Text
x -> [FilePath
"--target=" forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
x]) (GHCTargetVersion -> Maybe Text
_tvTarget GHCTargetVersion
tver) forall a. Semigroup a => a -> a -> a
<> [FilePath]
ldOverride forall a. Semigroup a => a -> a -> a
<> (Text -> FilePath
T.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
addConfArgs))
)
(forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ GHCupPath -> FilePath
fromGHCupPath GHCupPath
path)
FilePath
"ghc-configure"
forall a. Maybe a
Nothing
GHCupPath
tmpInstallDest <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, HasSettings env,
MonadUnliftIO m, MonadCatch m, MonadResource m, MonadThrow m,
MonadMask m, MonadIO m) =>
m GHCupPath
withGHCupTmpDir
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadThrow m, MonadIO m, MonadReader env m, HasDirs env,
HasLog env, HasSettings env) =>
[FilePath] -> Maybe FilePath -> m (Either ProcessError ())
make [FilePath
"DESTDIR=" forall a. Semigroup a => a -> a -> a
<> GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpInstallDest, FilePath
"install"] (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ GHCupPath -> FilePath
fromGHCupPath GHCupPath
path)
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (es :: [*]) (m :: * -> *) env.
(Pretty (V es), HFErrorProject (V es), MonadReader env m,
HasLog env, MonadIO m, Monad m) =>
Excepts es m () -> Excepts '[] m ()
catchWarn forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM @_ @'[ProcessError] forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
Platform -> FilePath -> m (Either ProcessError ())
darwinNotarization Platform
_rPlatform (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpInstallDest)
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadMask m, MonadAsync m, MonadReader env m, HasDirs env,
HasLog env, MonadCatch m) =>
GHCupPath
-> InstallDirResolved
-> Tool
-> GHCTargetVersion
-> (FilePath -> FilePath -> m ())
-> Excepts '[MergeFileTreeError] m ()
mergeFileTree (GHCupPath
tmpInstallDest GHCupPath -> FilePath -> GHCupPath
`appendGHCupPath` FilePath -> FilePath
dropDrive (InstallDirResolved -> FilePath
fromInstallDir InstallDirResolved
inst))
InstallDirResolved
inst
Tool
GHC
GHCTargetVersion
tver
(\FilePath
f FilePath
t -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Maybe UTCTime
mtime <- forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (FilePath -> IO Bool
pathIsSymbolicLink FilePath
f) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO UTCTime
getModificationTime FilePath
f)
FilePath -> FilePath -> Bool -> IO ()
install FilePath
f FilePath
t (Bool -> Bool
not Bool
forceInstall)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe UTCTime
mtime forall a b. (a -> b) -> a -> b
$ FilePath -> UTCTime -> IO ()
setModificationTime FilePath
t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
installGHCBin :: ( MonadFail m
, MonadMask m
, MonadCatch m
, MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
, HasDirs env
, HasSettings env
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
)
=> GHCTargetVersion
-> InstallDir
-> Bool
-> [T.Text]
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
, DirNotEmpty
, ArchiveResult
, ProcessError
, UninstallFailed
, MergeFileTreeError
]
m
()
installGHCBin :: forall (m :: * -> *) env.
(MonadFail m, MonadMask m, MonadCatch m, MonadReader env m,
HasPlatformReq env, HasGHCupInfo env, HasDirs env, HasSettings env,
HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m) =>
GHCTargetVersion
-> InstallDir
-> Bool
-> [Text]
-> Excepts
'[AlreadyInstalled, BuildFailed, DigestError, ContentLengthError,
GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive,
TarDirDoesNotExist, DirNotEmpty, ArchiveResult, ProcessError,
UninstallFailed, MergeFileTreeError]
m
()
installGHCBin GHCTargetVersion
tver InstallDir
installDir Bool
forceInstall [Text]
addConfArgs = do
DownloadInfo
dlinfo <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasPlatformReq env, HasGHCupInfo env) =>
Tool -> GHCTargetVersion -> Excepts '[NoDownload] m DownloadInfo
getDownloadInfo' Tool
GHC GHCTargetVersion
tver
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadFail m, MonadMask m, MonadCatch m, MonadReader env m,
HasDirs env, HasSettings env, HasPlatformReq env, HasLog env,
MonadResource m, MonadIO m, MonadUnliftIO m) =>
DownloadInfo
-> GHCTargetVersion
-> InstallDir
-> Bool
-> [Text]
-> Excepts
'[AlreadyInstalled, BuildFailed, DigestError, ContentLengthError,
GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive,
TarDirDoesNotExist, DirNotEmpty, ArchiveResult, ProcessError,
UninstallFailed, MergeFileTreeError]
m
()
installGHCBindist DownloadInfo
dlinfo GHCTargetVersion
tver InstallDir
installDir Bool
forceInstall [Text]
addConfArgs
setGHC :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadCatch m
, MonadMask m
, MonadUnliftIO m
)
=> GHCTargetVersion
-> SetGHC
-> Maybe FilePath
-> Excepts '[NotInstalled] m GHCTargetVersion
setGHC :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadThrow m,
MonadFail m, MonadIO m, MonadCatch m, MonadMask m,
MonadUnliftIO m) =>
GHCTargetVersion
-> SetGHC
-> Maybe FilePath
-> Excepts '[NotInstalled] m GHCTargetVersion
setGHC GHCTargetVersion
ver SetGHC
sghc Maybe FilePath
mBinDir = do
let verS :: FilePath
verS = Text -> FilePath
T.unpack forall a b. (a -> b) -> a -> b
$ Version -> Text
prettyVer (GHCTargetVersion -> Version
_tvVersion GHCTargetVersion
ver)
GHCupPath
ghcdir <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m GHCupPath
ghcupGHCDir GHCTargetVersion
ver
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m Bool
ghcInstalled GHCTargetVersion
ver) (forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (Tool -> GHCTargetVersion -> NotInstalled
NotInstalled Tool
GHC GHCTargetVersion
ver))
FilePath
binDir <- case Maybe FilePath
mBinDir of
Just FilePath
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
x
Maybe FilePath
Nothing -> do
Dirs {$sel:binDir:Dirs :: Dirs -> FilePath
binDir = FilePath
f} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
f
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe FilePath
mBinDir) forall a b. (a -> b) -> a -> b
$
case SetGHC
sghc of
SetGHC
SetGHCOnly -> forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadThrow m,
MonadFail m, MonadIO m, MonadMask m) =>
Maybe Text -> Excepts '[NotInstalled] m ()
rmPlainGHC (GHCTargetVersion -> Maybe Text
_tvTarget GHCTargetVersion
ver)
SetGHC
SetGHC_XY -> forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, HasLog env,
MonadThrow m, MonadFail m, MonadMask m) =>
GHCTargetVersion -> Excepts '[NotInstalled] m ()
rmMajorGHCSymlinks GHCTargetVersion
ver
SetGHC
SetGHC_XYZ -> forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, HasLog env,
MonadThrow m, MonadFail m, MonadMask m) =>
GHCTargetVersion -> Excepts '[NotInstalled] m ()
rmMinorGHCSymlinks GHCTargetVersion
ver
[FilePath]
verfiles <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadFail m,
MonadIO m) =>
GHCTargetVersion -> Excepts '[NotInstalled] m [FilePath]
ghcToolFiles GHCTargetVersion
ver
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
verfiles forall a b. (a -> b) -> a -> b
$ \FilePath
file -> do
Maybe FilePath
mTargetFile <- case SetGHC
sghc of
SetGHC
SetGHCOnly -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just FilePath
file
SetGHC
SetGHC_XY -> do
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle
(\(ParseError
e :: ParseError) -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn (FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> FilePath
displayException ParseError
e) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)
forall a b. (a -> b) -> a -> b
$ do
(Int
mj, Int
mi) <- forall (m :: * -> *). MonadThrow m => Version -> m (Int, Int)
getMajorMinorV (GHCTargetVersion -> Version
_tvVersion GHCTargetVersion
ver)
let major' :: Text
major' = forall a. Integral a => a -> Text
intToText Int
mj forall a. Semigroup a => a -> a -> a
<> Text
"." forall a. Semigroup a => a -> a -> a
<> forall a. Integral a => a -> Text
intToText Int
mi
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (FilePath
file forall a. Semigroup a => a -> a -> a
<> FilePath
"-" forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
major')
SetGHC
SetGHC_XYZ ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (FilePath
file forall a. Semigroup a => a -> a -> a
<> FilePath
"-" forall a. Semigroup a => a -> a -> a
<> FilePath
verS)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe FilePath
mTargetFile forall a b. (a -> b) -> a -> b
$ \FilePath
targetFile -> do
FilePath
bindir <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadFail m,
MonadIO m) =>
GHCTargetVersion -> m FilePath
ghcInternalBinDir GHCTargetVersion
ver
let fullF :: FilePath
fullF = FilePath
binDir FilePath -> FilePath -> FilePath
</> FilePath
targetFile forall a. Semigroup a => a -> a -> a
<> FilePath
exeExt
fileWithExt :: FilePath
fileWithExt = FilePath
bindir FilePath -> FilePath -> FilePath
</> FilePath
file forall a. Semigroup a => a -> a -> a
<> FilePath
exeExt
FilePath
destL <- forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
FilePath -> FilePath -> m FilePath
binarySymLinkDestination FilePath
binDir FilePath
fileWithExt
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadMask m, MonadThrow m, HasLog env, MonadIO m,
MonadReader env m, HasDirs env, MonadUnliftIO m, MonadFail m) =>
FilePath -> FilePath -> m ()
createLink FilePath
destL FilePath
fullF
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath
targetFile forall a. Eq a => a -> a -> Bool
== FilePath
"ghc") forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO (Maybe FilePath)
isShadowed FilePath
fullF) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe FilePath
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just FilePath
pa -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall e. (Pretty e, HFErrorProject e) => e -> FilePath
prettyHFError (Tool -> FilePath -> FilePath -> Version -> ToolShadowed
ToolShadowed Tool
GHC FilePath
pa FilePath
fullF (GHCTargetVersion -> Version
_tvVersion GHCTargetVersion
ver))
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe FilePath
mBinDir) forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. GHCTargetVersion -> Maybe Text
_tvTarget forall a b. (a -> b) -> a -> b
$ GHCTargetVersion
ver) forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, HasLog env,
MonadCatch m, MonadMask m) =>
FilePath -> FilePath -> m ()
symlinkShareDir (GHCupPath -> FilePath
fromGHCupPath GHCupPath
ghcdir) FilePath
verS
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SetGHC
sghc forall a. Eq a => a -> a -> Bool
== SetGHC
SetGHCOnly) forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadThrow m,
MonadCatch m, MonadIO m) =>
m ()
warnAboutHlsCompatibility
forall (f :: * -> *) a. Applicative f => a -> f a
pure GHCTargetVersion
ver
where
symlinkShareDir :: ( MonadReader env m
, HasDirs env
, MonadIO m
, HasLog env
, MonadCatch m
, MonadMask m
)
=> FilePath
-> String
-> m ()
symlinkShareDir :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, HasLog env,
MonadCatch m, MonadMask m) =>
FilePath -> FilePath -> m ()
symlinkShareDir FilePath
ghcdir FilePath
ver' = do
Dirs {FilePath
GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: FilePath
baseDir :: GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
..} <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
let destdir :: FilePath
destdir = GHCupPath -> FilePath
fromGHCupPath GHCupPath
baseDir
case SetGHC
sghc of
SetGHC
SetGHCOnly -> do
let sharedir :: FilePath
sharedir = FilePath
"share"
let fullsharedir :: FilePath
fullsharedir = FilePath
ghcdir FilePath -> FilePath -> FilePath
</> FilePath
sharedir
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"Checking for sharedir existence: " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
fullsharedir
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesDirectoryExist FilePath
fullsharedir) forall a b. (a -> b) -> a -> b
$ do
let fullF :: FilePath
fullF = FilePath
destdir FilePath -> FilePath -> FilePath
</> FilePath
sharedir
let targetF :: FilePath
targetF = FilePath
"." FilePath -> FilePath -> FilePath
</> FilePath
"ghc" FilePath -> FilePath -> FilePath
</> FilePath
ver' FilePath -> FilePath -> FilePath
</> FilePath
sharedir
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"rm -f " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
fullF
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasDirs env) =>
FilePath -> m ()
rmDirectoryLink FilePath
fullF
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"ln -s " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
targetF forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
fullF
if Bool
isWindows
then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
permissionErrorType
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
illegalOperationErrorType
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
createDirectoryLink FilePath
targetF FilePath
fullF
else forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
createDirectoryLink FilePath
targetF FilePath
fullF
SetGHC
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
unsetGHC :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadMask m
)
=> Maybe Text
-> Excepts '[NotInstalled] m ()
unsetGHC :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadThrow m,
MonadFail m, MonadIO m, MonadMask m) =>
Maybe Text -> Excepts '[NotInstalled] m ()
unsetGHC = forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadThrow m,
MonadFail m, MonadIO m, MonadMask m) =>
Maybe Text -> Excepts '[NotInstalled] m ()
rmPlainGHC
rmGHCVer :: ( MonadReader env m
, HasDirs env
, MonadThrow m
, HasLog env
, MonadIO m
, MonadFail m
, MonadCatch m
, MonadMask m
, MonadUnliftIO m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled, UninstallFailed] m ()
rmGHCVer :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, HasLog env,
MonadIO m, MonadFail m, MonadCatch m, MonadMask m,
MonadUnliftIO m) =>
GHCTargetVersion -> Excepts '[NotInstalled, UninstallFailed] m ()
rmGHCVer GHCTargetVersion
ver = do
Bool
isSetGHC <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just GHCTargetVersion
ver) forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) =>
Maybe Text -> m (Maybe GHCTargetVersion)
ghcSet (GHCTargetVersion -> Maybe Text
_tvTarget GHCTargetVersion
ver)
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m Bool
ghcInstalled GHCTargetVersion
ver) (forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (Tool -> GHCTargetVersion -> NotInstalled
NotInstalled Tool
GHC GHCTargetVersion
ver))
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isSetGHC forall a b. (a -> b) -> a -> b
$ do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo Text
"Removing ghc symlinks"
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadThrow m,
MonadFail m, MonadIO m, MonadMask m) =>
Maybe Text -> Excepts '[NotInstalled] m ()
rmPlainGHC (GHCTargetVersion -> Maybe Text
_tvTarget GHCTargetVersion
ver)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo Text
"Removing ghc-x.y.z symlinks"
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, HasLog env,
MonadThrow m, MonadFail m, MonadMask m) =>
GHCTargetVersion -> Excepts '[NotInstalled] m ()
rmMinorGHCSymlinks GHCTargetVersion
ver
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo Text
"Removing/rewiring ghc-x.y symlinks"
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (\(ParseError
_ :: ParseError) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) forall a b. (a -> b) -> a -> b
$ forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, HasLog env,
MonadThrow m, MonadFail m, MonadMask m) =>
GHCTargetVersion -> Excepts '[NotInstalled] m ()
rmMajorGHCSymlinks GHCTargetVersion
ver
GHCupPath
dir' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m GHCupPath
ghcupGHCDir GHCTargetVersion
ver
let dir :: FilePath
dir = GHCupPath -> FilePath
fromGHCupPath GHCupPath
dir'
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) env.
(MonadIO m, MonadCatch m, MonadReader env m, HasDirs env,
MonadFail m) =>
Tool -> GHCTargetVersion -> m (Maybe [FilePath])
getInstalledFiles Tool
GHC GHCTargetVersion
ver) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just [FilePath]
files -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"Removing files safely from: " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
dir
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
files (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
NoSuchThing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasDirs env) =>
FilePath -> m ()
recycleFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\FilePath
f -> FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath -> FilePath
dropDrive FilePath
f))
forall (m :: * -> *).
(MonadMask m, MonadIO m, MonadCatch m) =>
FilePath -> m ()
removeEmptyDirsRecursive FilePath
dir
[FilePath]
survivors <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
[IOErrorType] -> a -> m a -> m a
hideErrorDef [IOErrorType
doesNotExistErrorType] [] forall a b. (a -> b) -> a -> b
$ FilePath -> IO [FilePath]
listDirectory FilePath
dir
FilePath
f <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env) =>
Tool -> GHCTargetVersion -> m FilePath
recordedInstallationFile Tool
GHC GHCTargetVersion
ver
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasDirs env) =>
FilePath -> m ()
recycleFile FilePath
f
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
survivors)) forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> UninstallFailed
UninstallFailed FilePath
dir [FilePath]
survivors
Maybe [FilePath]
Nothing -> do
Bool
isDir <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesDirectoryExist FilePath
dir
Bool
isSyml <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
pathIsSymbolicLink FilePath
dir
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isDir Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isSyml) forall a b. (a -> b) -> a -> b
$ do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"Removing legacy directory recursively: " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
dir
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadMask m) =>
GHCupPath -> m ()
recyclePathForcibly GHCupPath
dir'
Maybe (Int, Int)
v' <-
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle
(\(ParseError
e :: ParseError) -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn (FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> FilePath
displayException ParseError
e) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)
forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => Version -> m (Int, Int)
getMajorMinorV (GHCTargetVersion -> Version
_tvVersion GHCTargetVersion
ver)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Int, Int)
v' forall a b. (a -> b) -> a -> b
$ \(Int
mj, Int
mi) -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) =>
PVP -> Maybe Text -> m (Maybe GHCTargetVersion)
getGHCForPVP (NonEmpty Word -> PVP
PVP (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
mj forall a. a -> [a] -> NonEmpty a
:| [forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
mi])) (GHCTargetVersion -> Maybe Text
_tvTarget GHCTargetVersion
ver))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\GHCTargetVersion
v -> forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadThrow m,
MonadFail m, MonadIO m, MonadCatch m, MonadMask m,
MonadUnliftIO m) =>
GHCTargetVersion
-> SetGHC
-> Maybe FilePath
-> Excepts '[NotInstalled] m GHCTargetVersion
setGHC GHCTargetVersion
v SetGHC
SetGHC_XY forall a. Maybe a
Nothing)
Dirs {FilePath
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: FilePath
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
..} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasDirs env) =>
FilePath -> m ()
rmDirectoryLink (GHCupPath -> FilePath
fromGHCupPath GHCupPath
baseDir FilePath -> FilePath -> FilePath
</> FilePath
"share")
compileGHC :: ( MonadMask m
, MonadReader env m
, HasDirs env
, HasPlatformReq env
, HasGHCupInfo env
, HasSettings env
, MonadThrow m
, MonadResource m
, HasLog env
, MonadIO m
, MonadUnliftIO m
, MonadFail m
)
=> GHCVer
-> Maybe Text
-> Maybe Version
-> Either Version FilePath
-> Maybe Int
-> Maybe FilePath
-> Maybe (Either FilePath [URI])
-> [Text]
-> Maybe String
-> Bool
-> InstallDir
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, GHCupSetError
, NoDownload
, NotFoundInPATH
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
, NotInstalled
, DirNotEmpty
, ArchiveResult
, FileDoesNotExistError
, HadrianNotFound
, InvalidBuildConfig
, ProcessError
, CopyError
, BuildFailed
, UninstallFailed
, MergeFileTreeError
]
m
GHCTargetVersion
compileGHC :: forall (m :: * -> *) env.
(MonadMask m, MonadReader env m, HasDirs env, HasPlatformReq env,
HasGHCupInfo env, HasSettings env, MonadThrow m, MonadResource m,
HasLog env, MonadIO m, MonadUnliftIO m, MonadFail m) =>
GHCVer
-> Maybe Text
-> Maybe Version
-> Either Version FilePath
-> Maybe Int
-> Maybe FilePath
-> Maybe (Either FilePath [URI])
-> [Text]
-> Maybe FilePath
-> Bool
-> InstallDir
-> Excepts
'[AlreadyInstalled, BuildFailed, DigestError, ContentLengthError,
GPGError, DownloadFailed, GHCupSetError, NoDownload,
NotFoundInPATH, PatchFailed, UnknownArchive, TarDirDoesNotExist,
NotInstalled, DirNotEmpty, ArchiveResult, FileDoesNotExistError,
HadrianNotFound, InvalidBuildConfig, ProcessError, CopyError,
BuildFailed, UninstallFailed, MergeFileTreeError]
m
GHCTargetVersion
compileGHC GHCVer
targetGhc Maybe Text
crossTarget Maybe Version
ov Either Version FilePath
bstrap Maybe Int
jobs Maybe FilePath
mbuildConfig Maybe (Either FilePath [URI])
patches [Text]
aargs Maybe FilePath
buildFlavour Bool
hadrian InstallDir
installDir
= do
PlatformRequest { Maybe Versioning
Platform
Architecture
_rVersion :: Maybe Versioning
_rPlatform :: Platform
_rArch :: Architecture
$sel:_rVersion:PlatformRequest :: PlatformRequest -> Maybe Versioning
$sel:_rPlatform:PlatformRequest :: PlatformRequest -> Platform
$sel:_rArch:PlatformRequest :: PlatformRequest -> Architecture
.. } <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "pfreq" A_Lens env PlatformRequest) =>
m PlatformRequest
getPlatformReq
GHCupInfo { $sel:_ghcupDownloads:GHCupInfo :: GHCupInfo -> GHCupDownloads
_ghcupDownloads = GHCupDownloads
dls } <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "ghcupInfo" A_Lens env GHCupInfo) =>
m GHCupInfo
getGHCupInfo
(GHCupPath
workdir, GHCupPath
tmpUnpack, Maybe GHCTargetVersion
tver) <- case GHCVer
targetGhc of
SourceDist Version
ver -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"Requested to compile: " forall a. Semigroup a => a -> a -> a
<> Version -> Text
prettyVer Version
ver forall a. Semigroup a => a -> a -> a
<> Text
" with " forall a. Semigroup a => a -> a -> a
<> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Version -> Text
prettyVer FilePath -> Text
T.pack Either Version FilePath
bstrap
DownloadInfo
dlInfo <-
forall k (is :: [*]) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
GHC forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix (Version -> GHCTargetVersion
mkTVer Version
ver) forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' VersionInfo (Maybe DownloadInfo)
viSourceDL forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall a b. Prism (Maybe a) (Maybe b) a b
_Just) GHCupDownloads
dls
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
Maybe a -> e -> Excepts es m a
?? NoDownload
NoDownload
FilePath
dl <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadMask m,
MonadResource m, MonadThrow m, HasLog env, MonadIO m,
MonadUnliftIO m) =>
DownloadInfo
-> Maybe FilePath
-> Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
FilePath
downloadCached DownloadInfo
dlInfo forall a. Maybe a
Nothing
GHCupPath
tmpUnpack <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadUnliftIO m, HasLog env,
MonadCatch m, MonadThrow m, MonadMask m, MonadIO m) =>
m GHCupPath
mkGhcupTmpDir
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (e :: [*]) (m :: * -> *) a env.
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
MonadMask m, HasLog env, MonadUnliftIO m, MonadFail m,
MonadCatch m) =>
GHCupPath -> Excepts e m a -> Excepts e m a
cleanUpOnError GHCupPath
tmpUnpack (forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m) =>
FilePath
-> FilePath -> Excepts '[UnknownArchive, ArchiveResult] m ()
unpackToDir (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack) FilePath
dl)
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (es :: [*]) (m :: * -> *) env.
(Pretty (V es), HFErrorProject (V es), MonadReader env m,
HasLog env, MonadIO m, Monad m) =>
Excepts es m () -> Excepts '[] m ()
catchWarn forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM @_ @'[ProcessError] forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
Platform -> FilePath -> m (Either ProcessError ())
darwinNotarization Platform
_rPlatform forall a b. (a -> b) -> a -> b
$ GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack
GHCupPath
workdir <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure GHCupPath
tmpUnpack)
(forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m,
MonadCatch m) =>
GHCupPath -> TarDir -> Excepts '[TarDirDoesNotExist] m GHCupPath
intoSubdir GHCupPath
tmpUnpack)
(forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Lens' DownloadInfo (Maybe TarDir)
dlSubdir DownloadInfo
dlInfo)
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, HasSettings env,
MonadUnliftIO m, MonadCatch m, MonadResource m, MonadThrow m,
MonadMask m, MonadIO m) =>
Maybe (Either FilePath [URI])
-> FilePath
-> Excepts
'[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
GPGError]
m
()
applyAnyPatch Maybe (Either FilePath [URI])
patches (GHCupPath -> FilePath
fromGHCupPath GHCupPath
workdir)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GHCupPath
workdir, GHCupPath
tmpUnpack, forall a. a -> Maybe a
Just (Maybe Text -> Version -> GHCTargetVersion
GHCTargetVersion Maybe Text
crossTarget Version
ver))
RemoteDist URI
uri -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"Requested to compile (from uri): " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show URI
uri)
GHCupPath
tmpDownload <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, HasSettings env,
MonadUnliftIO m, MonadCatch m, MonadResource m, MonadThrow m,
MonadMask m, MonadIO m) =>
m GHCupPath
withGHCupTmpDir
GHCupPath
tmpUnpack <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadUnliftIO m, HasLog env,
MonadCatch m, MonadThrow m, MonadMask m, MonadIO m) =>
m GHCupPath
mkGhcupTmpDir
FilePath
tar <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasDirs env, MonadMask m,
MonadThrow m, HasLog env, MonadIO m) =>
URI
-> Maybe URI
-> Maybe Text
-> Maybe Integer
-> FilePath
-> Maybe FilePath
-> Bool
-> Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
FilePath
download URI
uri forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpDownload) forall a. Maybe a
Nothing Bool
False
(FilePath
bf, Maybe Version
tver) <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (e :: [*]) (m :: * -> *) a env.
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
MonadMask m, HasLog env, MonadUnliftIO m, MonadFail m,
MonadCatch m) =>
GHCupPath -> Excepts e m a -> Excepts e m a
cleanUpOnError @'[UnknownArchive, ArchiveResult, ProcessError] GHCupPath
tmpUnpack forall a b. (a -> b) -> a -> b
$ do
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m) =>
FilePath
-> FilePath -> Excepts '[UnknownArchive, ArchiveResult] m ()
unpackToDir (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack) FilePath
tar
let regex :: ByteString
regex = [s|^(.*/)*boot$|] :: B.ByteString
[FilePath
bootFile] <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ GHCupPath -> Regex -> IO [FilePath]
findFilesDeep
GHCupPath
tmpUnpack
(forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended
ExecOption
execBlank
ByteString
regex
)
Maybe Version
tver <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (es :: [*]) (es' :: [*]) a.
Monad m =>
(V es -> Excepts es' m a) -> Excepts es m a -> Excepts es' m a
catchAllE @_ @'[ProcessError, ParseError] @'[] (\V '[ProcessError, ParseError]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasDirs env, HasLog env,
MonadIO m, MonadThrow m) =>
GHCupPath -> Excepts '[ProcessError, ParseError] m Version
getGHCVer
(GHCupPath -> FilePath -> GHCupPath
appendGHCupPath GHCupPath
tmpUnpack (FilePath -> FilePath
takeDirectory FilePath
bootFile))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
bootFile, Maybe Version
tver)
let workdir :: GHCupPath
workdir = GHCupPath -> FilePath -> GHCupPath
appendGHCupPath GHCupPath
tmpUnpack (FilePath -> FilePath
takeDirectory FilePath
bf)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GHCupPath
workdir, GHCupPath
tmpUnpack, Maybe Text -> Version -> GHCTargetVersion
GHCTargetVersion Maybe Text
crossTarget forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Version
tver)
GitDist GitBranch{FilePath
Maybe FilePath
$sel:repo:GitBranch :: GitBranch -> Maybe FilePath
$sel:ref:GitBranch :: GitBranch -> FilePath
repo :: Maybe FilePath
ref :: FilePath
..} -> do
GHCupPath
tmpUnpack <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadUnliftIO m, HasLog env,
MonadCatch m, MonadThrow m, MonadMask m, MonadIO m) =>
m GHCupPath
mkGhcupTmpDir
let git :: [FilePath] -> m (Either ProcessError ())
git [FilePath]
args = forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasLog env, HasDirs env,
MonadIO m, MonadThrow m) =>
FilePath
-> [FilePath]
-> Maybe FilePath
-> FilePath
-> Maybe [(FilePath, FilePath)]
-> m (Either ProcessError ())
execLogged FilePath
"git" (FilePath
"--no-pager"forall a. a -> [a] -> [a]
:[FilePath]
args) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack) FilePath
"git" forall a. Maybe a
Nothing
Maybe Version
tver <- forall e (es :: [*]) (es' :: [*]) a (m :: * -> *).
(Monad m, e :< es') =>
(V es -> e) -> Excepts es m a -> Excepts es' m a
reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, ContentLengthError, DownloadFailed, GPGError] forall (xs :: [*]).
(HFErrorProject (V xs), ToVariantMaybe DownloadFailed xs,
PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) =>
V xs -> DownloadFailed
DownloadFailed forall a b. (a -> b) -> a -> b
$ do
let rep :: FilePath
rep = forall a. a -> Maybe a -> a
fromMaybe FilePath
"https://gitlab.haskell.org/ghc/ghc.git" Maybe FilePath
repo
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"Fetching git repo " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
rep forall a. Semigroup a => a -> a -> a
<> Text
" at ref " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
ref forall a. Semigroup a => a -> a -> a
<> Text
" (this may take a while)"
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM forall a b. (a -> b) -> a -> b
$ [FilePath] -> m (Either ProcessError ())
git [ FilePath
"init" ]
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM forall a b. (a -> b) -> a -> b
$ [FilePath] -> m (Either ProcessError ())
git [ FilePath
"remote"
, FilePath
"add"
, FilePath
"origin"
, forall a. IsString a => FilePath -> a
fromString FilePath
rep ]
[FilePath]
remoteBranches <- forall e (es' :: [*]) (es'' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, e :< es, LiftVariant (Remove e es) es',
LiftVariant es'' es') =>
(e -> Excepts es'' m a) -> Excepts es m a -> Excepts es' m a
catchE @ProcessError @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, ContentLengthError, DownloadFailed, GPGError] @'[PatchFailed, NotFoundInPATH, DigestError, DownloadFailed, GPGError] (\(ProcessError
_ :: ProcessError) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> [FilePath]
processBranches forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m) =>
[FilePath] -> FilePath -> Excepts '[ProcessError] m Text
gitOut [FilePath
"ls-remote", FilePath
"--heads", FilePath
"origin"] (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack)
let shallow_clone :: Bool
shallow_clone
| FilePath -> Bool
isCommitHash FilePath
ref = Bool
True
| forall a. IsString a => FilePath -> a
fromString FilePath
ref forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
remoteBranches = Bool
True
| Bool
otherwise = Bool
False
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"Shallow clone: " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show Bool
shallow_clone)
let fetch_args :: [FilePath]
fetch_args
| Bool
shallow_clone = [FilePath
"fetch", FilePath
"--depth", FilePath
"1", FilePath
"--quiet", FilePath
"origin", forall a. IsString a => FilePath -> a
fromString FilePath
ref]
| Bool
otherwise = [FilePath
"fetch", FilePath
"--tags", FilePath
"--quiet", FilePath
"origin" ]
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM forall a b. (a -> b) -> a -> b
$ [FilePath] -> m (Either ProcessError ())
git [FilePath]
fetch_args
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM forall a b. (a -> b) -> a -> b
$ [FilePath] -> m (Either ProcessError ())
git [ FilePath
"checkout", forall a. IsString a => FilePath -> a
fromString FilePath
ref ]
Maybe Text
git_describe <- if Bool
shallow_clone
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m) =>
[FilePath] -> FilePath -> Excepts '[ProcessError] m Text
gitOut [FilePath
"describe", FilePath
"--tags"] (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack)
Text
chash <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m) =>
[FilePath] -> FilePath -> Excepts '[ProcessError] m Text
gitOut [FilePath
"rev-parse", FilePath
"HEAD" ] (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack)
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM forall a b. (a -> b) -> a -> b
$ [FilePath] -> m (Either ProcessError ())
git [ FilePath
"submodule", FilePath
"update", FilePath
"--init", FilePath
"--depth", FilePath
"1" ]
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, HasSettings env,
MonadUnliftIO m, MonadCatch m, MonadResource m, MonadThrow m,
MonadMask m, MonadIO m) =>
Maybe (Either FilePath [URI])
-> FilePath
-> Excepts
'[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
GPGError]
m
()
applyAnyPatch Maybe (Either FilePath [URI])
patches (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack)
Maybe Version
tver <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (es :: [*]) (es' :: [*]) a.
Monad m =>
(V es -> Excepts es' m a) -> Excepts es m a -> Excepts es' m a
catchAllE @_ @'[ProcessError, ParseError] @'[] (\V '[ProcessError, ParseError]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasDirs env, HasLog env,
MonadIO m, MonadThrow m) =>
GHCupPath -> Excepts '[ProcessError, ParseError] m Version
getGHCVer
GHCupPath
tmpUnpack
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (es :: [*]) (m :: * -> *) env.
(Pretty (V es), HFErrorProject (V es), MonadReader env m,
HasLog env, MonadIO m, Monad m) =>
Excepts es m () -> Excepts '[] m ()
catchWarn forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM @_ @'[ProcessError] forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
Platform -> FilePath -> m (Either ProcessError ())
darwinNotarization Platform
_rPlatform (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"Examining git ref " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
ref forall a. Semigroup a => a -> a -> a
<> Text
"\n " forall a. Semigroup a => a -> a -> a
<>
Text
"GHC version (from Makefile): " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show (Version -> Text
prettyVer forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Version
tver)) forall a. Semigroup a => a -> a -> a
<>
(if Bool -> Bool
not Bool
shallow_clone then Text
"\n " forall a. Semigroup a => a -> a -> a
<> Text
"'git describe' output: " forall a. Semigroup a => a -> a -> a
<> forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
git_describe else forall a. Monoid a => a
mempty) forall a. Semigroup a => a -> a -> a
<>
(if FilePath -> Bool
isCommitHash FilePath
ref then forall a. Monoid a => a
mempty else Text
"\n " forall a. Semigroup a => a -> a -> a
<> Text
"commit hash: " forall a. Semigroup a => a -> a -> a
<> Text
chash)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
5000000
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Version
tver
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GHCupPath
tmpUnpack, GHCupPath
tmpUnpack, Maybe Text -> Version -> GHCTargetVersion
GHCTargetVersion Maybe Text
crossTarget forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Version
tver)
GHCTargetVersion
installVer <- if | Just Version
ov' <- Maybe Version
ov -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> Version -> GHCTargetVersion
GHCTargetVersion Maybe Text
crossTarget Version
ov')
| Just GHCTargetVersion
tver' <- Maybe GHCTargetVersion
tver -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GHCTargetVersion
tver'
| Bool
otherwise -> forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"Newer GHCs don't support discovering the version in git. Complain to GHC devs: https://gitlab.haskell.org/ghc/ghc/-/issues/22322"
Bool
alreadyInstalled <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m Bool
ghcInstalled GHCTargetVersion
installVer
Bool
alreadySet <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just GHCTargetVersion
installVer) forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) =>
Maybe Text -> m (Maybe GHCTargetVersion)
ghcSet (GHCTargetVersion -> Maybe Text
_tvTarget GHCTargetVersion
installVer)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
alreadyInstalled forall a b. (a -> b) -> a -> b
$ do
case InstallDir
installDir of
IsolateDir FilePath
isoDir ->
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Text
"GHC " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. Pretty a => a -> FilePath
prettyShow GHCTargetVersion
installVer) forall a. Semigroup a => a -> a -> a
<> Text
" already installed. Isolate installing to " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
isoDir
InstallDir
GHCupInternal ->
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Text
"GHC " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. Pretty a => a -> FilePath
prettyShow GHCTargetVersion
installVer) forall a. Semigroup a => a -> a -> a
<> Text
" already installed. Will overwrite existing version."
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn
Text
"...waiting for 10 seconds before continuing, you can still abort..."
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
10000000
InstallDirResolved
ghcdir <- case InstallDir
installDir of
IsolateDir FilePath
isoDir -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FilePath -> InstallDirResolved
IsolateDirResolved FilePath
isoDir
InstallDir
GHCupInternal -> GHCupPath -> InstallDirResolved
GHCupDir forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m GHCupPath
ghcupGHCDir GHCTargetVersion
installVer)
(Maybe FilePath
mBindist, ByteString
bmk) <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) (e :: [*]) a.
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
MonadMask m, HasLog env, MonadUnliftIO m, MonadFail m,
MonadCatch m) =>
GHCupPath -> Excepts e m a -> Excepts e m a
runBuildAction
GHCupPath
tmpUnpack
(do
Maybe FilePath
b <- if Bool
hadrian
then forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env,
HasPlatformReq env, MonadThrow m, MonadCatch m, HasLog env,
MonadIO m, MonadFail m) =>
GHCTargetVersion
-> FilePath
-> InstallDirResolved
-> Excepts
'[FileDoesNotExistError, HadrianNotFound, InvalidBuildConfig,
PatchFailed, ProcessError, NotFoundInPATH, CopyError]
m
(Maybe FilePath)
compileHadrianBindist (forall a. a -> Maybe a -> a
fromMaybe GHCTargetVersion
installVer Maybe GHCTargetVersion
tver) (GHCupPath -> FilePath
fromGHCupPath GHCupPath
workdir) InstallDirResolved
ghcdir
else forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env,
HasPlatformReq env, MonadThrow m, MonadCatch m, HasLog env,
MonadIO m, MonadFail m) =>
GHCTargetVersion
-> FilePath
-> InstallDirResolved
-> Excepts
'[FileDoesNotExistError, HadrianNotFound, InvalidBuildConfig,
PatchFailed, ProcessError, NotFoundInPATH, CopyError]
m
(Maybe FilePath)
compileMakeBindist (forall a. a -> Maybe a -> a
fromMaybe GHCTargetVersion
installVer Maybe GHCTargetVersion
tver) (GHCupPath -> FilePath
fromGHCupPath GHCupPath
workdir) InstallDirResolved
ghcdir
ByteString
bmk <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
"") forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
B.readFile (FilePath -> FilePath
build_mk forall a b. (a -> b) -> a -> b
$ GHCupPath -> FilePath
fromGHCupPath GHCupPath
workdir)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FilePath
b, ByteString
bmk)
)
case InstallDir
installDir of
InstallDir
GHCupInternal ->
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
alreadyInstalled forall a b. (a -> b) -> a -> b
$ do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo Text
"Deleting existing installation"
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, HasLog env,
MonadIO m, MonadFail m, MonadCatch m, MonadMask m,
MonadUnliftIO m) =>
GHCTargetVersion -> Excepts '[NotInstalled, UninstallFailed] m ()
rmGHCVer GHCTargetVersion
installVer
InstallDir
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe FilePath
mBindist forall a b. (a -> b) -> a -> b
$ \FilePath
bindist -> do
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadMask m, MonadCatch m, MonadReader env m, HasDirs env,
HasPlatformReq env, HasSettings env, MonadThrow m, HasLog env,
MonadIO m, MonadUnliftIO m, MonadFail m, MonadResource m) =>
FilePath
-> Maybe TarDir
-> InstallDirResolved
-> GHCTargetVersion
-> Bool
-> [Text]
-> Excepts
'[BuildFailed, UnknownArchive, TarDirDoesNotExist, DirNotEmpty,
ArchiveResult, ProcessError, MergeFileTreeError]
m
()
installPackedGHC FilePath
bindist
(forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ FilePath -> TarDir
RegexDir FilePath
"ghc-.*")
InstallDirResolved
ghcdir
GHCTargetVersion
installVer
Bool
False
[]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
B.writeFile (InstallDirResolved -> FilePath
fromInstallDir InstallDirResolved
ghcdir FilePath -> FilePath -> FilePath
</> FilePath
ghcUpSrcBuiltFile) ByteString
bmk
case InstallDir
installDir of
InstallDir
GHCupInternal -> do
forall e (es :: [*]) (es' :: [*]) a (m :: * -> *).
(Monad m, e :< es') =>
(V es -> e) -> Excepts es m a -> Excepts es' m a
reThrowAll forall (es :: [*]).
(ToVariantMaybe GHCupSetError es, PopVariant GHCupSetError es,
Show (V es), Pretty (V es), HFErrorProject (V es)) =>
V es -> GHCupSetError
GHCupSetError forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadThrow m,
MonadFail m, MonadIO m, MonadCatch m, MonadMask m,
MonadUnliftIO m) =>
GHCTargetVersion -> Excepts '[NotInstalled] m ()
postGHCInstall GHCTargetVersion
installVer
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
alreadySet forall a b. (a -> b) -> a -> b
$ forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadThrow m,
MonadFail m, MonadIO m, MonadCatch m, MonadMask m,
MonadUnliftIO m) =>
GHCTargetVersion
-> SetGHC
-> Maybe FilePath
-> Excepts '[NotInstalled] m GHCTargetVersion
setGHC GHCTargetVersion
installVer SetGHC
SetGHCOnly forall a. Maybe a
Nothing
InstallDir
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure GHCTargetVersion
installVer
where
getGHCVer :: ( MonadReader env m
, HasSettings env
, HasDirs env
, HasLog env
, MonadIO m
, MonadThrow m
)
=> GHCupPath
-> Excepts '[ProcessError, ParseError] m Version
getGHCVer :: forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasDirs env, HasLog env,
MonadIO m, MonadThrow m) =>
GHCupPath -> Excepts '[ProcessError, ParseError] m Version
getGHCVer GHCupPath
tmpUnpack = do
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasDirs env, HasLog env,
MonadIO m, MonadThrow m) =>
FilePath
-> [FilePath]
-> Maybe FilePath
-> FilePath
-> m (Either ProcessError ())
execWithGhcEnv FilePath
"python3" [FilePath
"./boot"] (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack) FilePath
"ghc-bootstrap"
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasDirs env, HasLog env,
MonadIO m, MonadThrow m) =>
FilePath
-> [FilePath]
-> Maybe FilePath
-> FilePath
-> m (Either ProcessError ())
execWithGhcEnv FilePath
"sh" [FilePath
"./configure"] (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack) FilePath
"ghc-bootstrap"
CapturedProcess {ByteString
ExitCode
$sel:_stdErr:CapturedProcess :: CapturedProcess -> ByteString
$sel:_stdOut:CapturedProcess :: CapturedProcess -> ByteString
$sel:_exitCode:CapturedProcess :: CapturedProcess -> ExitCode
_stdErr :: ByteString
_stdOut :: ByteString
_exitCode :: ExitCode
..} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
[FilePath] -> Maybe FilePath -> m CapturedProcess
makeOut
[FilePath
"show!", FilePath
"--quiet", FilePath
"VALUE=ProjectVersion" ] (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpUnpack)
case ExitCode
_exitCode of
ExitCode
ExitSuccess -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ParseError
ParseError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> FilePath
show) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
MP.parse Parsec Void Text Version
ghcProjectVersion FilePath
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
stripNewlineEnd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decUTF8Safe' forall a b. (a -> b) -> a -> b
$ ByteString
_stdOut
ExitFailure Int
c -> forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE forall a b. (a -> b) -> a -> b
$ Int -> FilePath -> [FilePath] -> ProcessError
NonZeroExit Int
c FilePath
"make" [FilePath
"show!", FilePath
"--quiet", FilePath
"VALUE=ProjectVersion" ]
defaultConf :: Text
defaultConf =
let cross_mk :: Text
cross_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/cross" >> runIO (readFile "data/build_mk/cross")))
default_mk :: Text
default_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/default" >> runIO (readFile "data/build_mk/default")))
in case Maybe Text
crossTarget of
Just Text
_ -> Text
cross_mk
Maybe Text
_ -> Text
default_mk
compileHadrianBindist :: ( MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, MonadThrow m
, MonadCatch m
, HasLog env
, MonadIO m
, MonadFail m
)
=> GHCTargetVersion
-> FilePath
-> InstallDirResolved
-> Excepts
'[ FileDoesNotExistError
, HadrianNotFound
, InvalidBuildConfig
, PatchFailed
, ProcessError
, NotFoundInPATH
, CopyError]
m
(Maybe FilePath)
compileHadrianBindist :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env,
HasPlatformReq env, MonadThrow m, MonadCatch m, HasLog env,
MonadIO m, MonadFail m) =>
GHCTargetVersion
-> FilePath
-> InstallDirResolved
-> Excepts
'[FileDoesNotExistError, HadrianNotFound, InvalidBuildConfig,
PatchFailed, ProcessError, NotFoundInPATH, CopyError]
m
(Maybe FilePath)
compileHadrianBindist GHCTargetVersion
tver FilePath
workdir InstallDirResolved
ghcdir = do
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env,
HasPlatformReq env, MonadThrow m, MonadCatch m, HasLog env,
MonadIO m, MonadFail m) =>
GHCTargetVersion
-> FilePath
-> InstallDirResolved
-> Excepts
'[FileDoesNotExistError, InvalidBuildConfig, PatchFailed,
ProcessError, NotFoundInPATH, CopyError]
m
()
configureBindist GHCTargetVersion
tver FilePath
workdir InstallDirResolved
ghcdir
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo Text
"Building (this may take a while)..."
FilePath
hadrian_build <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
FilePath -> Excepts '[HadrianNotFound] m FilePath
findHadrianFile FilePath
workdir
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasDirs env, HasLog env,
MonadIO m, MonadThrow m) =>
FilePath
-> [FilePath]
-> Maybe FilePath
-> FilePath
-> m (Either ProcessError ())
execWithGhcEnv FilePath
hadrian_build
( forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Int
j -> [FilePath
"-j" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Int
j] ) Maybe Int
jobs
forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\FilePath
bf -> [FilePath
"--flavour=" forall a. Semigroup a => a -> a -> a
<> FilePath
bf]) Maybe FilePath
buildFlavour
forall a. [a] -> [a] -> [a]
++ [FilePath
"binary-dist"]
)
(forall a. a -> Maybe a
Just FilePath
workdir) FilePath
"ghc-make"
[FilePath
tar] <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> Regex -> IO [FilePath]
findFiles
(FilePath
workdir FilePath -> FilePath -> FilePath
</> FilePath
"_build" FilePath -> FilePath -> FilePath
</> FilePath
"bindist")
(forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended
ExecOption
execBlank
([s|^ghc-.*\.tar\..*$|] :: ByteString)
)
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env,
HasPlatformReq env, MonadIO m, MonadThrow m, MonadCatch m,
HasLog env) =>
GHCTargetVersion
-> FilePath -> FilePath -> Excepts '[CopyError] m FilePath
copyBindist GHCTargetVersion
tver FilePath
tar (FilePath
workdir FilePath -> FilePath -> FilePath
</> FilePath
"_build" FilePath -> FilePath -> FilePath
</> FilePath
"bindist")
findHadrianFile :: (MonadIO m)
=> FilePath
-> Excepts
'[HadrianNotFound]
m
FilePath
findHadrianFile :: forall (m :: * -> *).
MonadIO m =>
FilePath -> Excepts '[HadrianNotFound] m FilePath
findHadrianFile FilePath
workdir = do
let possible_files :: [FilePath]
possible_files = if Bool
isWindows
then ((FilePath
workdir FilePath -> FilePath -> FilePath
</> FilePath
"hadrian") FilePath -> FilePath -> FilePath
</>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath
"build.bat"]
else ((FilePath
workdir FilePath -> FilePath -> FilePath
</> FilePath
"hadrian") FilePath -> FilePath -> FilePath
</>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath
"build", FilePath
"build.sh"]
[(Bool, FilePath)]
exsists <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
possible_files (\FilePath
f -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesFileExist FilePath
f) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (,FilePath
f))
case forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a, b) -> a
fst [(Bool, FilePath)]
exsists of
[] -> forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE HadrianNotFound
HadrianNotFound
((Bool
_, FilePath
x):[(Bool, FilePath)]
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
x
compileMakeBindist :: ( MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, MonadThrow m
, MonadCatch m
, HasLog env
, MonadIO m
, MonadFail m
)
=> GHCTargetVersion
-> FilePath
-> InstallDirResolved
-> Excepts
'[ FileDoesNotExistError
, HadrianNotFound
, InvalidBuildConfig
, PatchFailed
, ProcessError
, NotFoundInPATH
, CopyError]
m
(Maybe FilePath)
compileMakeBindist :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env,
HasPlatformReq env, MonadThrow m, MonadCatch m, HasLog env,
MonadIO m, MonadFail m) =>
GHCTargetVersion
-> FilePath
-> InstallDirResolved
-> Excepts
'[FileDoesNotExistError, HadrianNotFound, InvalidBuildConfig,
PatchFailed, ProcessError, NotFoundInPATH, CopyError]
m
(Maybe FilePath)
compileMakeBindist GHCTargetVersion
tver FilePath
workdir InstallDirResolved
ghcdir = do
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env,
HasPlatformReq env, MonadThrow m, MonadCatch m, HasLog env,
MonadIO m, MonadFail m) =>
GHCTargetVersion
-> FilePath
-> InstallDirResolved
-> Excepts
'[FileDoesNotExistError, InvalidBuildConfig, PatchFailed,
ProcessError, NotFoundInPATH, CopyError]
m
()
configureBindist GHCTargetVersion
tver FilePath
workdir InstallDirResolved
ghcdir
case Maybe FilePath
mbuildConfig of
Just FilePath
bc -> forall (m :: * -> *) e (es' :: [*]) a.
(MonadCatch m, MonadIO m, Monad m, e :< es') =>
IOErrorType -> e -> m a -> Excepts es' m a
liftIOException
IOErrorType
doesNotExistErrorType
(FilePath -> FileDoesNotExistError
FileDoesNotExistError FilePath
bc)
(forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> Bool -> IO ()
copyFile FilePath
bc (FilePath -> FilePath
build_mk FilePath
workdir) Bool
False)
Maybe FilePath
Nothing ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> Text -> IO ()
T.writeFile (FilePath -> FilePath
build_mk FilePath
workdir) (Text -> Text
addBuildFlavourToConf Text
defaultConf)
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, MonadCatch m, MonadIO m, HasLog env) =>
FilePath
-> Excepts '[FileDoesNotExistError, InvalidBuildConfig] m ()
checkBuildConfig (FilePath -> FilePath
build_mk FilePath
workdir)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo Text
"Building (this may take a while)..."
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadThrow m, MonadIO m, MonadReader env m, HasDirs env,
HasLog env, HasSettings env) =>
[FilePath] -> Maybe FilePath -> m (Either ProcessError ())
make (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Int
j -> [FilePath
"-j" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => FilePath -> a
fS (forall a. Show a => a -> FilePath
show Int
j)]) Maybe Int
jobs) (forall a. a -> Maybe a
Just FilePath
workdir)
if | GHCTargetVersion -> Bool
isCross GHCTargetVersion
tver -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo Text
"Installing cross toolchain..."
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadThrow m, MonadIO m, MonadReader env m, HasDirs env,
HasLog env, HasSettings env) =>
[FilePath] -> Maybe FilePath -> m (Either ProcessError ())
make [FilePath
"install"] (forall a. a -> Maybe a
Just FilePath
workdir)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
| Bool
otherwise -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo Text
"Creating bindist..."
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadThrow m, MonadIO m, MonadReader env m, HasDirs env,
HasLog env, HasSettings env) =>
[FilePath] -> Maybe FilePath -> m (Either ProcessError ())
make [FilePath
"binary-dist"] (forall a. a -> Maybe a
Just FilePath
workdir)
[FilePath
tar] <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> Regex -> IO [FilePath]
findFiles
FilePath
workdir
(forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended
ExecOption
execBlank
([s|^ghc-.*\.tar\..*$|] :: ByteString)
)
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env,
HasPlatformReq env, MonadIO m, MonadThrow m, MonadCatch m,
HasLog env) =>
GHCTargetVersion
-> FilePath -> FilePath -> Excepts '[CopyError] m FilePath
copyBindist GHCTargetVersion
tver FilePath
tar FilePath
workdir
build_mk :: FilePath -> FilePath
build_mk FilePath
workdir = FilePath
workdir FilePath -> FilePath -> FilePath
</> FilePath
"mk" FilePath -> FilePath -> FilePath
</> FilePath
"build.mk"
copyBindist :: ( MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, MonadIO m
, MonadThrow m
, MonadCatch m
, HasLog env
)
=> GHCTargetVersion
-> FilePath
-> FilePath
-> Excepts
'[CopyError]
m
FilePath
copyBindist :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env,
HasPlatformReq env, MonadIO m, MonadThrow m, MonadCatch m,
HasLog env) =>
GHCTargetVersion
-> FilePath -> FilePath -> Excepts '[CopyError] m FilePath
copyBindist GHCTargetVersion
tver FilePath
tar FilePath
workdir = do
Dirs {FilePath
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: FilePath
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
..} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
PlatformRequest
pfreq <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "pfreq" A_Lens env PlatformRequest) =>
m PlatformRequest
getPlatformReq
ByteString
c <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
BL.readFile (FilePath
workdir FilePath -> FilePath -> FilePath
</> FilePath
tar)
Text
cDigest <-
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Text -> Text
T.take Int
8)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *) b.
(Exception a, MonadThrow m) =>
Either a b -> m b
throwEither
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
E.decodeUtf8'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B16.encode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
SHA256.hashlazy
forall a b. (a -> b) -> a -> b
$ ByteString
c
UTCTime
cTime <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
let tarName :: FilePath
tarName = FilePath -> FilePath
makeValid (FilePath
"ghc-"
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack (GHCTargetVersion -> Text
tVerToText GHCTargetVersion
tver)
forall a. Semigroup a => a -> a -> a
<> FilePath
"-"
forall a. Semigroup a => a -> a -> a
<> PlatformRequest -> FilePath
pfReqToString PlatformRequest
pfreq
forall a. Semigroup a => a -> a -> a
<> FilePath
"-"
forall a. Semigroup a => a -> a -> a
<> forall t. ISO8601 t => t -> FilePath
iso8601Show UTCTime
cTime
forall a. Semigroup a => a -> a -> a
<> FilePath
"-"
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
cDigest
forall a. Semigroup a => a -> a -> a
<> FilePath
".tar"
forall a. Semigroup a => a -> a -> a
<> FilePath -> FilePath
takeExtension FilePath
tar)
let tarPath :: FilePath
tarPath = GHCupPath -> FilePath
fromGHCupPath GHCupPath
cacheDir FilePath -> FilePath -> FilePath
</> FilePath
tarName
forall (xs :: [*]) (m :: * -> *).
(CopyError :< xs, MonadCatch m, MonadIO m) =>
FilePath -> FilePath -> Bool -> Excepts xs m ()
copyFileE (FilePath
workdir FilePath -> FilePath -> FilePath
</> FilePath
tar) FilePath
tarPath Bool
False
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"Copied bindist to " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
tarPath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
tarPath
checkBuildConfig :: (MonadReader env m, MonadCatch m, MonadIO m, HasLog env)
=> FilePath
-> Excepts
'[FileDoesNotExistError, InvalidBuildConfig]
m
()
checkBuildConfig :: forall env (m :: * -> *).
(MonadReader env m, MonadCatch m, MonadIO m, HasLog env) =>
FilePath
-> Excepts '[FileDoesNotExistError, InvalidBuildConfig] m ()
checkBuildConfig FilePath
bc = do
ByteString
c <- forall (m :: * -> *) e (es' :: [*]) a.
(MonadCatch m, MonadIO m, Monad m, e :< es') =>
IOErrorType -> e -> m a -> Excepts es' m a
liftIOException
IOErrorType
doesNotExistErrorType
(FilePath -> FileDoesNotExistError
FileDoesNotExistError FilePath
bc)
(forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
B.readFile FilePath
bc)
let lines' :: [Text]
lines' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
T.strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decUTF8Safe ByteString
c
case Maybe Text
crossTarget of
Just Text
_ -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
"Stage1Only = YES" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
lines') forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE
(Text -> InvalidBuildConfig
InvalidBuildConfig
[s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|]
)
Maybe Text
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe FilePath
buildFlavour forall a b. (a -> b) -> a -> b
$ \FilePath
bf ->
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath -> Text
T.pack (FilePath
"BuildFlavour = " forall a. Semigroup a => a -> a -> a
<> FilePath
bf) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
lines') forall a b. (a -> b) -> a -> b
$ do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Text
"Customly specified build config overwrites --flavour=" forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
bf forall a. Semigroup a => a -> a -> a
<> Text
" switch! Waiting 5 seconds..."
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
5000000
addBuildFlavourToConf :: Text -> Text
addBuildFlavourToConf Text
bc = case Maybe FilePath
buildFlavour of
Just FilePath
bf -> Text
"BuildFlavour = " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
bf forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<> Text
bc
Maybe FilePath
Nothing -> Text
bc
isCross :: GHCTargetVersion -> Bool
isCross :: GHCTargetVersion -> Bool
isCross = forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. GHCTargetVersion -> Maybe Text
_tvTarget
configureBindist :: ( MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, MonadThrow m
, MonadCatch m
, HasLog env
, MonadIO m
, MonadFail m
)
=> GHCTargetVersion
-> FilePath
-> InstallDirResolved
-> Excepts
'[ FileDoesNotExistError
, InvalidBuildConfig
, PatchFailed
, ProcessError
, NotFoundInPATH
, CopyError
]
m
()
configureBindist :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env,
HasPlatformReq env, MonadThrow m, MonadCatch m, HasLog env,
MonadIO m, MonadFail m) =>
GHCTargetVersion
-> FilePath
-> InstallDirResolved
-> Excepts
'[FileDoesNotExistError, InvalidBuildConfig, PatchFailed,
ProcessError, NotFoundInPATH, CopyError]
m
()
configureBindist GHCTargetVersion
tver FilePath
workdir (InstallDirResolved -> FilePath
fromInstallDir -> FilePath
ghcdir) = do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo [s|configuring build|]
if | GHCTargetVersion -> Version
_tvVersion GHCTargetVersion
tver forall a. Ord a => a -> a -> Bool
>= [vver|8.8.0|] -> do
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasDirs env, HasLog env,
MonadIO m, MonadThrow m) =>
FilePath
-> [FilePath]
-> Maybe FilePath
-> FilePath
-> m (Either ProcessError ())
execWithGhcEnv
FilePath
"sh"
(FilePath
"./configure" forall a. a -> [a] -> [a]
: forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty
(\Text
x -> [FilePath
"--target=" forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
x])
(GHCTargetVersion -> Maybe Text
_tvTarget GHCTargetVersion
tver)
forall a. [a] -> [a] -> [a]
++ [FilePath
"--prefix=" forall a. Semigroup a => a -> a -> a
<> FilePath
ghcdir]
forall a. [a] -> [a] -> [a]
++ (if Bool
isWindows then [FilePath
"--enable-tarballs-autodownload"] else [])
forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> FilePath
T.unpack [Text]
aargs
)
(forall a. a -> Maybe a
Just FilePath
workdir)
FilePath
"ghc-conf"
| Bool
otherwise -> do
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasLog env, HasDirs env,
MonadIO m, MonadThrow m) =>
FilePath
-> [FilePath]
-> Maybe FilePath
-> FilePath
-> Maybe [(FilePath, FilePath)]
-> m (Either ProcessError ())
execLogged
FilePath
"sh"
( [ FilePath
"./configure", FilePath
"--with-ghc=" forall a. Semigroup a => a -> a -> a
<> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id forall a. a -> a
id Either FilePath FilePath
bghc
]
forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty
(\Text
x -> [FilePath
"--target=" forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
x])
(GHCTargetVersion -> Maybe Text
_tvTarget GHCTargetVersion
tver)
forall a. [a] -> [a] -> [a]
++ [FilePath
"--prefix=" forall a. Semigroup a => a -> a -> a
<> FilePath
ghcdir]
forall a. [a] -> [a] -> [a]
++ (if Bool
isWindows then [FilePath
"--enable-tarballs-autodownload"] else [])
forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> FilePath
T.unpack [Text]
aargs
)
(forall a. a -> Maybe a
Just FilePath
workdir)
FilePath
"ghc-conf"
forall a. Maybe a
Nothing
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
execWithGhcEnv :: ( MonadReader env m
, HasSettings env
, HasDirs env
, HasLog env
, MonadIO m
, MonadThrow m)
=> FilePath
-> [String]
-> Maybe FilePath
-> FilePath
-> m (Either ProcessError ())
execWithGhcEnv :: forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasDirs env, HasLog env,
MonadIO m, MonadThrow m) =>
FilePath
-> [FilePath]
-> Maybe FilePath
-> FilePath
-> m (Either ProcessError ())
execWithGhcEnv FilePath
fp [FilePath]
args Maybe FilePath
dir FilePath
logf = do
[(FilePath, FilePath)]
env <- forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
m [(FilePath, FilePath)]
ghcEnv
forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasLog env, HasDirs env,
MonadIO m, MonadThrow m) =>
FilePath
-> [FilePath]
-> Maybe FilePath
-> FilePath
-> Maybe [(FilePath, FilePath)]
-> m (Either ProcessError ())
execLogged FilePath
fp [FilePath]
args Maybe FilePath
dir FilePath
logf (forall a. a -> Maybe a
Just [(FilePath, FilePath)]
env)
bghc :: Either FilePath FilePath
bghc = case Either Version FilePath
bstrap of
Right FilePath
g -> forall a b. b -> Either a b
Right FilePath
g
Left Version
bver -> forall a b. a -> Either a b
Left (FilePath
"ghc-" forall a. Semigroup a => a -> a -> a
<> (Text -> FilePath
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Text
prettyVer forall a b. (a -> b) -> a -> b
$ Version
bver) forall a. Semigroup a => a -> a -> a
<> FilePath
exeExt)
ghcEnv :: (MonadThrow m, MonadIO m) => m [(String, String)]
ghcEnv :: forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
m [(FilePath, FilePath)]
ghcEnv = do
[(FilePath, FilePath)]
cEnv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(FilePath, FilePath)]
getEnvironment
FilePath
bghcPath <- case Either FilePath FilePath
bghc of
Right FilePath
ghc' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
ghc'
Left FilePath
bver -> do
[FilePath]
spaths <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [FilePath]
getSearchPath
forall a (m :: * -> *) b.
(Exception a, MonadThrow m) =>
a -> m (Maybe b) -> m b
throwMaybeM (FilePath -> NotFoundInPATH
NotFoundInPATH FilePath
bver) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([FilePath] -> FilePath -> IO (Maybe FilePath)
searchPath [FilePath]
spaths FilePath
bver)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((FilePath
"GHC", FilePath
bghcPath) forall a. a -> [a] -> [a]
: [(FilePath, FilePath)]
cEnv)
postGHCInstall :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadCatch m
, MonadMask m
, MonadUnliftIO m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
postGHCInstall :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadThrow m,
MonadFail m, MonadIO m, MonadCatch m, MonadMask m,
MonadUnliftIO m) =>
GHCTargetVersion -> Excepts '[NotInstalled] m ()
postGHCInstall ver :: GHCTargetVersion
ver@GHCTargetVersion {Maybe Text
Version
_tvVersion :: Version
_tvTarget :: Maybe Text
$sel:_tvVersion:GHCTargetVersion :: GHCTargetVersion -> Version
$sel:_tvTarget:GHCTargetVersion :: GHCTargetVersion -> Maybe Text
..} = do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadThrow m,
MonadFail m, MonadIO m, MonadCatch m, MonadMask m,
MonadUnliftIO m) =>
GHCTargetVersion
-> SetGHC
-> Maybe FilePath
-> Excepts '[NotInstalled] m GHCTargetVersion
setGHC GHCTargetVersion
ver SetGHC
SetGHC_XYZ forall a. Maybe a
Nothing
Maybe (Int, Int)
v' <-
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (\(ParseError
e :: ParseError) -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn (FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> FilePath
displayException ParseError
e) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)
forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => Version -> m (Int, Int)
getMajorMinorV Version
_tvVersion
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Int, Int)
v' forall a b. (a -> b) -> a -> b
$ \(Int
mj, Int
mi) -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) =>
PVP -> Maybe Text -> m (Maybe GHCTargetVersion)
getGHCForPVP (NonEmpty Word -> PVP
PVP (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
mj forall a. a -> [a] -> NonEmpty a
:| [forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
mi])) Maybe Text
_tvTarget)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\GHCTargetVersion
v -> forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadThrow m,
MonadFail m, MonadIO m, MonadCatch m, MonadMask m,
MonadUnliftIO m) =>
GHCTargetVersion
-> SetGHC
-> Maybe FilePath
-> Excepts '[NotInstalled] m GHCTargetVersion
setGHC GHCTargetVersion
v SetGHC
SetGHC_XY forall a. Maybe a
Nothing)