{-# LANGUAGE CPP                   #-}
{-# LANGUAGE BangPatterns          #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE TemplateHaskell       #-}

{-|
Module      : GHCup.GHC
Description : GHCup installation functions for GHC
Copyright   : (c) Julian Ospald, 2020
License     : LGPL-3.0
Maintainer  : hasufell@hasufell.de
Stability   : experimental
Portability : portable
-}
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



    --------------------
    --[ Tool testing ]--
    --------------------



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
  -- download (or use cached version)
  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          -- ^ Path to the packed GHC bindist
              -> Maybe TarDir      -- ^ Subdir of the archive
              -> GHCTargetVersion  -- ^ The GHC version
              -> [T.Text]          -- ^ additional make args
              -> 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
  -- unpack
  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)

  -- the subdir of the archive where we do the work
  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         -- ^ Path to the unpacked GHC bindist (where the make file resides)
                -> GHCTargetVersion  -- ^ The GHC version
                -> [T.Text]          -- ^ additional configure args for bindist
                -> 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 ()


    ---------------------
    --[ Tool fetching ]--
    ---------------------



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



    -------------------------
    --[ Tool installation ]--
    -------------------------


-- | Like 'installGHCBin', except takes the 'DownloadInfo' as
-- argument instead of looking it up from 'GHCupDownloads'.
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    -- ^ where/how to download
                  -> GHCTargetVersion -- ^ the version to install
                  -> InstallDir
                  -> Bool            -- ^ Force install
                  -> [T.Text]        -- ^ additional configure args for bindist
                  -> 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 ()

  -- download (or use cached version)
  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                        -- isolated install
      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                            -- regular install
      -- prepare paths
      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

      -- make symlinks & stuff when regular install,
      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."


-- | Install a packed GHC distribution. This only deals with unpacking and the GHC
-- build system and nothing else.
installPackedGHC :: ( MonadMask m
                    , MonadCatch m
                    , MonadReader env m
                    , HasDirs env
                    , HasPlatformReq env
                    , HasSettings env
                    , MonadThrow m
                    , HasLog env
                    , MonadIO m
                    , MonadUnliftIO m
                    , MonadFail m
                    , MonadResource m
                    )
                 => FilePath          -- ^ Path to the packed GHC bindist
                 -> Maybe TarDir      -- ^ Subdir of the archive
                 -> InstallDirResolved
                 -> GHCTargetVersion  -- ^ The GHC version
                 -> Bool              -- ^ Force install
                 -> [T.Text]          -- ^ additional configure args for bindist
                 -> 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)

  -- unpack
  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)

  -- the subdir of the archive where we do the work
  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)


-- | Install an unpacked GHC distribution. This only deals with the GHC
-- build system and nothing else.
installUnpackedGHC :: ( MonadReader env m
                      , HasPlatformReq env
                      , HasDirs env
                      , HasSettings env
                      , MonadThrow m
                      , HasLog env
                      , MonadIO m
                      , MonadUnliftIO m
                      , MonadMask m
                      , MonadResource m
                      , MonadFail m
                      )
                   => GHCupPath           -- ^ Path to the unpacked GHC bindist (where the configure script resides)
                   -> InstallDirResolved  -- ^ Path to install to
                   -> GHCTargetVersion    -- ^ The GHC version
                   -> Bool                -- ^ Force install
                   -> [T.Text]          -- ^ additional configure args for bindist
                   -> 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)"
      -- Windows bindists are relocatable and don't need
      -- to run configure.
      -- We also must make sure to preserve mtime to not confuse ghc-pkg.
      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 ()


-- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
-- following symlinks in @~\/.ghcup\/bin@:
--
--   * @ghc-x.y.z -> ..\/ghc\/x.y.z\/bin/ghc@
--   * @ghc-x.y   -> ..\/ghc\/x.y.z\/bin/ghc@ (if x.y.z is the latest x.y version)
installGHCBin :: ( MonadFail m
                 , MonadMask m
                 , MonadCatch m
                 , MonadReader env m
                 , HasPlatformReq env
                 , HasGHCupInfo env
                 , HasDirs env
                 , HasSettings env
                 , HasLog env
                 , MonadResource m
                 , MonadIO m
                 , MonadUnliftIO m
                 )
              => GHCTargetVersion -- ^ the version to install
              -> InstallDir
              -> Bool            -- ^ force install
              -> [T.Text]        -- ^ additional configure args for bindist
              -> 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





    ---------------
    --[ Set GHC ]--
    ---------------



-- | Set GHC symlinks in @~\/.ghcup\/bin@ for the requested GHC version. The behavior depends
-- on `SetGHC`:
--
--   * SetGHCOnly: @~\/.ghcup\/bin\/ghc -> ~\/.ghcup\/ghc\/\<ver\>\/bin\/ghc@
--   * SetGHC_XY: @~\/.ghcup\/bin\/ghc-X.Y -> ~\/.ghcup\/ghc\/\<ver\>\/bin\/ghc@
--   * SetGHC_XYZ: @~\/.ghcup\/bin\/ghc-\<ver\> -> ~\/.ghcup\/ghc\/\<ver\>\/bin\/ghc@
--
-- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\<ver\>\/share symlink@
-- for 'SetGHCOnly' constructor.
setGHC :: ( MonadReader env m
          , HasDirs env
          , HasLog env
          , MonadThrow m
          , MonadFail m
          , MonadIO m
          , MonadCatch m
          , MonadMask m
          , MonadUnliftIO m
          )
       => GHCTargetVersion
       -> SetGHC
       -> Maybe FilePath  -- if set, signals that we're not operating in ~/.ghcup/bin
                          -- and don't want mess with other versions
       -> 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))

  -- symlink destination
  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

  -- first delete the old symlinks (this fixes compatibility issues
  -- with old ghcup)
  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

  -- for ghc tools (ghc, ghci, haddock, ...)
  [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)

    -- create symlink
    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
    -- create symlink for share dir
    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
                 -- On windows we need to be more permissive
                 -- in case symlinks can't be created, be just
                 -- give up here. This symlink isn't strictly necessary.
                 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





    --------------
    --[ GHC rm ]--
    --------------


-- | Delete a ghc version and all its symlinks.
--
-- This may leave GHCup without a "set" version.
-- Will try to fix the ghc-x.y symlink after removal (e.g. to an
-- older version).
rmGHCVer :: ( MonadReader env m
            , HasDirs env
            , 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))

  -- this isn't atomic, order matters
  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"
  -- first remove
  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
  -- then fix them (e.g. with an earlier version)

  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")




    ---------------
    --[ Compile ]--
    ---------------


-- | Compile a GHC from source. This behaves wrt symlinks and installation
-- the same as 'installGHCBin'.
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               -- ^ cross target
           -> Maybe Version            -- ^ overwrite version
           -> Either Version FilePath  -- ^ version to bootstrap with
           -> Maybe Int                -- ^ jobs
           -> Maybe FilePath           -- ^ build config
           -> Maybe (Either FilePath [URI])  -- ^ patches
           -> [Text]                   -- ^ additional args to ./configure
           -> Maybe String             -- ^ build flavour
           -> 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
      -- unpack from version tarball
      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

        -- download source tarball
        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

        -- unpack
        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)

        -- download source tarball
        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)

      -- clone from git
      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 ]

          -- figure out if we can do a shallow clone
          [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)

          -- fetch
          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

          -- initial checkout
          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 ]

          -- gather some info
          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)

          -- clone submodules
          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" ]

          -- apply patches
          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)

          -- bootstrap
          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 -- give the user a sec to intervene

          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)
    -- the version that's installed may differ from the
    -- compiled version, so the user can overwrite it
    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 -- give the user a sec to intervene

    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
             -- prefer 'tver', because the real version carries out compatibility checks
             -- we don't want the user to do funny things with it
             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 ->
        -- only remove old ghc in regular installs
        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       -- not a force install, since we already overwrite when compiling.
                               []

    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
      -- set and make symlinks for regular (non-isolated) installs
      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
        -- restore
        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)  -- ^ output path of bindist, None for cross
  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)  -- ^ output path of bindist, None for cross
  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           -- ^ tar file
              -> FilePath           -- ^ workdir
              -> 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

   -- for cross, we need Stage1Only
    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         -- ^ thing to execute
                 -> [String]         -- ^ args for the thing
                 -> Maybe FilePath   -- ^ optionally chdir into this
                 -> FilePath         -- ^ log filename (opened in append mode)
                 -> m (Either ProcessError ())
  execWithGhcEnv :: 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)




    -------------
    --[ Other ]--
    -------------



-- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for
-- both installing from source and bindist.
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

  -- Create ghc-x.y symlinks. This may not be the current
  -- version, create it regardless.
  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)