{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveFunctor       #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE MultiWayIf          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE PackageImports      #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE ViewPatterns        #-}

module Stack.Setup
  ( setupEnv
  , ensureCompilerAndMsys
  , ensureDockerStackExe
  , SetupOpts (..)
  , defaultSetupInfoYaml
  , withNewLocalBuildTargets

  -- * Stack binary download

  , StackReleaseInfo
  , getDownloadVersion
  , stackVersion
  , preferredPlatforms
  , downloadStackReleaseInfo
  , downloadStackExe
  ) where

import qualified    Codec.Archive.Tar as Tar
import              Conduit
import              Control.Applicative (empty)
import "cryptonite" Crypto.Hash (SHA1(..), SHA256(..))
import              Pantry.Internal.AesonExtended
import qualified    Data.Aeson.KeyMap as KeyMap
import qualified    Data.ByteString as S
import qualified    Data.ByteString.Lazy as LBS
import qualified    Data.Conduit.Binary as CB
import              Data.Conduit.Lazy (lazyConsume)
import qualified    Data.Conduit.List as CL
import              Data.Conduit.Process.Typed (createSource)
import              Data.Conduit.Zlib          (ungzip)
import              Data.List hiding (concat, elem, maximumBy, any)
import qualified    Data.Map as Map
import qualified    Data.Set as Set
import qualified    Data.Text as T
import qualified    Data.Text.Lazy as TL
import qualified    Data.Text.Encoding as T
import qualified    Data.Text.Lazy.Encoding as TL
import qualified    Data.Text.Encoding.Error as T
import qualified    Data.Yaml as Yaml
import              Distribution.System (OS, Arch (..), Platform (..))
import qualified    Distribution.System as Cabal
import              Distribution.Text (simpleParse)
import              Distribution.Types.PackageName (mkPackageName)
import              Distribution.Version (mkVersion)
import              Network.HTTP.Client (redirectCount)
import              Network.HTTP.StackClient (CheckHexDigest (..), HashCheck (..),
                                              getResponseBody, getResponseStatusCode, httpLbs, httpJSON,
                                              mkDownloadRequest, parseRequest, parseUrlThrow, setGitHubHeaders,
                                              setHashChecks, setLengthCheck, verifiedDownloadWithProgress, withResponse,
                                              setRequestMethod)
import              Network.HTTP.Simple (getResponseHeader)
import              Path hiding (fileExtension)
import              Path.CheckInstall (warnInstallSearchPathIssues)
import              Path.Extended (fileExtension)
import              Path.Extra (toFilePathNoTrailingSep)
import              Path.IO hiding (findExecutable, withSystemTempDir)
import qualified    Pantry
import qualified    RIO
import              RIO.List
import              RIO.PrettyPrint
import              RIO.Process
import              Stack.Build.Haddock (shouldHaddockDeps)
import              Stack.Build.Source (loadSourceMap, hashSourceMapData)
import              Stack.Build.Target (NeedTargets(..), parseTargets)
import              Stack.Constants
import              Stack.Constants.Config (distRelativeDir)
import              Stack.GhcPkg (createDatabase, getGlobalDB, mkGhcPackagePath, ghcPkgPathEnvVar)
import              Stack.Prelude hiding (Display (..))
import              Stack.SourceMap
import              Stack.Setup.Installed (Tool (..), extraDirs, filterTools,
                                          installDir, getCompilerVersion,
                                          listInstalled, markInstalled, tempInstallDir,
                                          toolString, unmarkInstalled)
import              Stack.Storage.User (loadCompilerPaths, saveCompilerPaths)
import              Stack.Types.Build
import              Stack.Types.Compiler
import              Stack.Types.CompilerBuild
import              Stack.Types.Config
import              Stack.Types.Docker
import              Stack.Types.SourceMap
import              Stack.Types.Version
import qualified    System.Directory as D
import              System.Environment (getExecutablePath, lookupEnv)
import              System.IO.Error (isPermissionError)
import              System.FilePath (searchPathSeparator)
import qualified    System.FilePath as FP
import              System.Permissions (setFileExecutable)
import              System.Uname (getRelease)
import              Data.List.Split (splitOn)

-- | Default location of the stack-setup.yaml file

defaultSetupInfoYaml :: String
defaultSetupInfoYaml :: [Char]
defaultSetupInfoYaml =
    [Char]
"https://raw.githubusercontent.com/commercialhaskell/stackage-content/master/stack/stack-setup-2.yaml"

data SetupOpts = SetupOpts
    { SetupOpts -> Bool
soptsInstallIfMissing :: !Bool
    , SetupOpts -> Bool
soptsUseSystem :: !Bool
    -- ^ Should we use a system compiler installation, if available?

    , SetupOpts -> WantedCompiler
soptsWantedCompiler :: !WantedCompiler
    , SetupOpts -> VersionCheck
soptsCompilerCheck :: !VersionCheck
    , SetupOpts -> Maybe (Path Abs File)
soptsStackYaml :: !(Maybe (Path Abs File))
    -- ^ If we got the desired GHC version from that file

    , SetupOpts -> Bool
soptsForceReinstall :: !Bool
    , SetupOpts -> Bool
soptsSanityCheck :: !Bool
    -- ^ Run a sanity check on the selected GHC

    , SetupOpts -> Bool
soptsSkipGhcCheck :: !Bool
    -- ^ Don't check for a compatible GHC version/architecture

    , SetupOpts -> Bool
soptsSkipMsys :: !Bool
    -- ^ Do not use a custom msys installation on Windows

    , SetupOpts -> Maybe Text
soptsResolveMissingGHC :: !(Maybe Text)
    -- ^ Message shown to user for how to resolve the missing GHC

    , SetupOpts -> Maybe [Char]
soptsGHCBindistURL :: !(Maybe String)
    -- ^ Alternate GHC binary distribution (requires custom GHCVariant)

    }
    deriving Int -> SetupOpts -> ShowS
[SetupOpts] -> ShowS
SetupOpts -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SetupOpts] -> ShowS
$cshowList :: [SetupOpts] -> ShowS
show :: SetupOpts -> [Char]
$cshow :: SetupOpts -> [Char]
showsPrec :: Int -> SetupOpts -> ShowS
$cshowsPrec :: Int -> SetupOpts -> ShowS
Show
data SetupException = UnsupportedSetupCombo OS Arch
                    | MissingDependencies [String]
                    | UnknownCompilerVersion (Set.Set Text) WantedCompiler (Set.Set ActualCompiler)
                    | UnknownOSKey Text
                    | GHCSanityCheckCompileFailed SomeException (Path Abs File)
                    | WantedMustBeGHC
                    | RequireCustomGHCVariant
                    | ProblemWhileDecompressing (Path Abs File)
                    | SetupInfoMissingSevenz
                    | DockerStackExeNotFound Version Text
                    | UnsupportedSetupConfiguration
                    | InvalidGhcAt (Path Abs File) SomeException
    deriving Typeable
instance Exception SetupException
instance Show SetupException where
    show :: SetupException -> [Char]
show (UnsupportedSetupCombo OS
os Arch
arch) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"I don't know how to install GHC for "
        , forall a. Show a => a -> [Char]
show (OS
os, Arch
arch)
        , [Char]
", please install manually"
        ]
    show (MissingDependencies [[Char]]
tools) =
        [Char]
"The following executables are missing and must be installed: " forall a. [a] -> [a] -> [a]
++
        forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " [[Char]]
tools
    show (UnknownCompilerVersion Set Text
oskeys WantedCompiler
wanted Set ActualCompiler
known) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"No setup information found for "
        , Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Text
utf8BuilderToText forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Utf8Builder
RIO.display WantedCompiler
wanted
        , [Char]
" on your platform.\nThis probably means a GHC bindist has not yet been added for OS key '"
        , Text -> [Char]
T.unpack (Text -> [Text] -> Text
T.intercalate Text
"', '" (forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set Text
oskeys))
        , [Char]
"'.\nSupported versions: "
        , Text -> [Char]
T.unpack (Text -> [Text] -> Text
T.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map ActualCompiler -> Text
compilerVersionText (forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set ActualCompiler
known)))
        ]
    show (UnknownOSKey Text
oskey) =
        [Char]
"Unable to find installation URLs for OS key: " forall a. [a] -> [a] -> [a]
++
        Text -> [Char]
T.unpack Text
oskey
    show (GHCSanityCheckCompileFailed SomeException
e Path Abs File
ghc) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"The GHC located at "
        , forall b t. Path b t -> [Char]
toFilePath Path Abs File
ghc
        , [Char]
" failed to compile a sanity check. Please see:\n\n"
        , [Char]
"    http://docs.haskellstack.org/en/stable/install_and_upgrade/\n\n"
        , [Char]
"for more information. Exception was:\n"
        , forall a. Show a => a -> [Char]
show SomeException
e
        ]
    show SetupException
WantedMustBeGHC =
        [Char]
"The wanted compiler must be GHC"
    show SetupException
RequireCustomGHCVariant =
        [Char]
"A custom --ghc-variant must be specified to use --ghc-bindist"
    show (ProblemWhileDecompressing Path Abs File
archive) =
        [Char]
"Problem while decompressing " forall a. [a] -> [a] -> [a]
++ forall b t. Path b t -> [Char]
toFilePath Path Abs File
archive
    show SetupException
SetupInfoMissingSevenz =
        [Char]
"SetupInfo missing Sevenz EXE/DLL"
    show (DockerStackExeNotFound Version
stackVersion' Text
osKey) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
stackProgName
        , [Char]
"-"
        , Version -> [Char]
versionString Version
stackVersion'
        , [Char]
" executable not found for "
        , Text -> [Char]
T.unpack Text
osKey
        , [Char]
"\nUse the '"
        , Text -> [Char]
T.unpack Text
dockerStackExeArgName
        , [Char]
"' option to specify a location"]
    show SetupException
UnsupportedSetupConfiguration =
        [Char]
"I don't know how to install GHC on your system configuration, please install manually"
    show (InvalidGhcAt Path Abs File
compiler SomeException
e) =
        [Char]
"Found an invalid compiler at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall b t. Path b t -> [Char]
toFilePath Path Abs File
compiler) forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ forall e. Exception e => e -> [Char]
displayException SomeException
e

-- | Modify the environment variables (like PATH) appropriately, possibly doing installation too

setupEnv :: NeedTargets
         -> BuildOptsCLI
         -> Maybe Text -- ^ Message to give user when necessary GHC is not available

         -> RIO BuildConfig EnvConfig
setupEnv :: NeedTargets
-> BuildOptsCLI -> Maybe Text -> RIO BuildConfig EnvConfig
setupEnv NeedTargets
needTargets BuildOptsCLI
boptsCLI Maybe Text
mResolveMissingGHC = do
    Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
    BuildConfig
bc <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigL
    let stackYaml :: Path Abs File
stackYaml = BuildConfig -> Path Abs File
bcStackYaml BuildConfig
bc
    Platform
platform <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL
    WantedCompiler
wcVersion <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s r. HasBuildConfig s => Getting r s WantedCompiler
wantedCompilerVersionL
    WantedCompiler
wanted <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s r. HasBuildConfig s => Getting r s WantedCompiler
wantedCompilerVersionL
    ActualCompiler
actual <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ WantedCompiler -> Either CompilerException ActualCompiler
wantedToActual WantedCompiler
wanted
    let wc :: WhichCompiler
wc = ActualCompiler
actualforall s a. s -> Getting a s a -> a
^.forall r. Getting r ActualCompiler WhichCompiler
whichCompilerL
    let sopts :: SetupOpts
sopts = SetupOpts
            { soptsInstallIfMissing :: Bool
soptsInstallIfMissing = Config -> Bool
configInstallGHC Config
config
            , soptsUseSystem :: Bool
soptsUseSystem = Config -> Bool
configSystemGHC Config
config
            , soptsWantedCompiler :: WantedCompiler
soptsWantedCompiler = WantedCompiler
wcVersion
            , soptsCompilerCheck :: VersionCheck
soptsCompilerCheck = Config -> VersionCheck
configCompilerCheck Config
config
            , soptsStackYaml :: Maybe (Path Abs File)
soptsStackYaml = forall a. a -> Maybe a
Just Path Abs File
stackYaml
            , soptsForceReinstall :: Bool
soptsForceReinstall = Bool
False
            , soptsSanityCheck :: Bool
soptsSanityCheck = Bool
False
            , soptsSkipGhcCheck :: Bool
soptsSkipGhcCheck = Config -> Bool
configSkipGHCCheck Config
config
            , soptsSkipMsys :: Bool
soptsSkipMsys = Config -> Bool
configSkipMsys Config
config
            , soptsResolveMissingGHC :: Maybe Text
soptsResolveMissingGHC = Maybe Text
mResolveMissingGHC
            , soptsGHCBindistURL :: Maybe [Char]
soptsGHCBindistURL = forall a. Maybe a
Nothing
            }

    (CompilerPaths
compilerPaths, ExtraDirs
ghcBin) <- forall env.
(HasBuildConfig env, HasGHCVariant env) =>
SetupOpts -> RIO env (CompilerPaths, ExtraDirs)
ensureCompilerAndMsys SetupOpts
sopts
    let compilerVer :: ActualCompiler
compilerVer = CompilerPaths -> ActualCompiler
cpCompilerVersion CompilerPaths
compilerPaths

    -- Modify the initial environment to include the GHC path, if a local GHC

    -- is being used

    ProcessContext
menv0 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasProcessContext env => Lens' env ProcessContext
processContextL
    Map Text Text
env <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text Text -> Map Text Text
removeHaskellEnvVars)
               forall a b. (a -> b) -> a -> b
$ [[Char]]
-> Map Text Text -> Either ProcessException (Map Text Text)
augmentPathMap
                    (forall a b. (a -> b) -> [a] -> [b]
map forall b t. Path b t -> [Char]
toFilePath forall a b. (a -> b) -> a -> b
$ ExtraDirs -> [Path Abs Dir]
edBins ExtraDirs
ghcBin)
                    (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env.
HasProcessContext env =>
SimpleGetter env (Map Text Text)
envVarsL ProcessContext
menv0)
    ProcessContext
menv <- forall (m :: * -> *).
MonadIO m =>
Map Text Text -> m ProcessContext
mkProcessContext Map Text Text
env

    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Resolving package entries"

    (SourceMap
sourceMap, SourceMapHash
sourceMapHash) <- forall env a.
HasConfig env =>
ProcessContext -> CompilerPaths -> RIO (WithGHC env) a -> RIO env a
runWithGHC ProcessContext
menv CompilerPaths
compilerPaths forall a b. (a -> b) -> a -> b
$ do
      SMActual DumpedGlobalPackage
smActual <- forall env.
(HasConfig env, HasCompiler env) =>
SMWanted
-> ActualCompiler -> RIO env (SMActual DumpedGlobalPackage)
actualFromGhc (BuildConfig -> SMWanted
bcSMWanted BuildConfig
bc) ActualCompiler
compilerVer
      let actualPkgs :: Set PackageName
actualPkgs = forall k a. Map k a -> Set k
Map.keysSet (forall global. SMActual global -> Map PackageName DepPackage
smaDeps SMActual DumpedGlobalPackage
smActual) forall a. Semigroup a => a -> a -> a
<>
                       forall k a. Map k a -> Set k
Map.keysSet (forall global. SMActual global -> Map PackageName ProjectPackage
smaProject SMActual DumpedGlobalPackage
smActual)
          prunedActual :: SMActual GlobalPackage
prunedActual = SMActual DumpedGlobalPackage
smActual { smaGlobal :: Map PackageName GlobalPackage
smaGlobal = Map PackageName DumpedGlobalPackage
-> Set PackageName -> Map PackageName GlobalPackage
pruneGlobals (forall global. SMActual global -> Map PackageName global
smaGlobal SMActual DumpedGlobalPackage
smActual) Set PackageName
actualPkgs }
          haddockDeps :: Bool
haddockDeps = BuildOpts -> Bool
shouldHaddockDeps (Config -> BuildOpts
configBuild Config
config)
      SMTargets
targets <- forall env.
HasBuildConfig env =>
NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
parseTargets NeedTargets
needTargets Bool
haddockDeps BuildOptsCLI
boptsCLI SMActual GlobalPackage
prunedActual
      SourceMap
sourceMap <- forall env.
HasBuildConfig env =>
SMTargets
-> BuildOptsCLI
-> SMActual DumpedGlobalPackage
-> RIO env SourceMap
loadSourceMap SMTargets
targets BuildOptsCLI
boptsCLI SMActual DumpedGlobalPackage
smActual
      SourceMapHash
sourceMapHash <- forall env.
(HasBuildConfig env, HasCompiler env) =>
BuildOptsCLI -> SourceMap -> RIO env SourceMapHash
hashSourceMapData BuildOptsCLI
boptsCLI SourceMap
sourceMap
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (SourceMap
sourceMap, SourceMapHash
sourceMapHash)

    let envConfig0 :: EnvConfig
envConfig0 = EnvConfig
            { envConfigBuildConfig :: BuildConfig
envConfigBuildConfig = BuildConfig
bc
            , envConfigBuildOptsCLI :: BuildOptsCLI
envConfigBuildOptsCLI = BuildOptsCLI
boptsCLI
            , envConfigSourceMap :: SourceMap
envConfigSourceMap = SourceMap
sourceMap
            , envConfigSourceMapHash :: SourceMapHash
envConfigSourceMapHash = SourceMapHash
sourceMapHash
            , envConfigCompilerPaths :: CompilerPaths
envConfigCompilerPaths = CompilerPaths
compilerPaths
            }

    -- extra installation bin directories

    Bool -> [Path Abs Dir]
mkDirs <- forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO EnvConfig
envConfig0 forall env. HasEnvConfig env => RIO env (Bool -> [Path Abs Dir])
extraBinDirs
    let mpath :: Maybe Text
mpath = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"PATH" Map Text Text
env
    Text
depsPath <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [[Char]] -> Maybe Text -> Either ProcessException Text
augmentPath (forall b t. Path b t -> [Char]
toFilePath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> [Path Abs Dir]
mkDirs Bool
False) Maybe Text
mpath
    Text
localsPath <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [[Char]] -> Maybe Text -> Either ProcessException Text
augmentPath (forall b t. Path b t -> [Char]
toFilePath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> [Path Abs Dir]
mkDirs Bool
True) Maybe Text
mpath

    Path Abs Dir
deps <- forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO EnvConfig
envConfig0 forall env. HasEnvConfig env => RIO env (Path Abs Dir)
packageDatabaseDeps
    forall env a.
HasConfig env =>
ProcessContext -> CompilerPaths -> RIO (WithGHC env) a -> RIO env a
runWithGHC ProcessContext
menv CompilerPaths
compilerPaths forall a b. (a -> b) -> a -> b
$ forall env.
(HasProcessContext env, HasLogFunc env) =>
GhcPkgExe -> Path Abs Dir -> RIO env ()
createDatabase (CompilerPaths -> GhcPkgExe
cpPkg CompilerPaths
compilerPaths) Path Abs Dir
deps
    Path Abs Dir
localdb <- forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO EnvConfig
envConfig0 forall env. HasEnvConfig env => RIO env (Path Abs Dir)
packageDatabaseLocal
    forall env a.
HasConfig env =>
ProcessContext -> CompilerPaths -> RIO (WithGHC env) a -> RIO env a
runWithGHC ProcessContext
menv CompilerPaths
compilerPaths forall a b. (a -> b) -> a -> b
$ forall env.
(HasProcessContext env, HasLogFunc env) =>
GhcPkgExe -> Path Abs Dir -> RIO env ()
createDatabase (CompilerPaths -> GhcPkgExe
cpPkg CompilerPaths
compilerPaths) Path Abs Dir
localdb
    [Path Abs Dir]
extras <- forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall env (m :: * -> *).
(MonadReader env m, HasEnvConfig env) =>
m [Path Abs Dir]
packageDatabaseExtra EnvConfig
envConfig0
    let mkGPP :: Bool -> Text
mkGPP Bool
locals = Bool
-> Path Abs Dir
-> Path Abs Dir
-> [Path Abs Dir]
-> Path Abs Dir
-> Text
mkGhcPackagePath Bool
locals Path Abs Dir
localdb Path Abs Dir
deps [Path Abs Dir]
extras forall a b. (a -> b) -> a -> b
$ CompilerPaths -> Path Abs Dir
cpGlobalDB CompilerPaths
compilerPaths

    Path Abs Dir
distDir <- forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
m (Path Rel Dir)
distRelativeDir EnvConfig
envConfig0 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall path (m :: * -> *).
(AnyPath path, MonadIO m) =>
path -> m (AbsPath path)
canonicalizePath

    [Char]
executablePath <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [Char]
getExecutablePath

    Map Text Text
utf8EnvVars <- forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv forall a b. (a -> b) -> a -> b
$ forall env.
(HasProcessContext env, HasPlatform env, HasLogFunc env) =>
ActualCompiler -> RIO env (Map Text Text)
getUtf8EnvVars ActualCompiler
compilerVer

    Maybe [Char]
mGhcRtsEnvVar <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"GHCRTS"

    IORef (Map EnvSettings ProcessContext)
envRef <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef forall k a. Map k a
Map.empty
    let getProcessContext' :: EnvSettings -> IO ProcessContext
getProcessContext' EnvSettings
es = do
            Map EnvSettings ProcessContext
m <- forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Map EnvSettings ProcessContext)
envRef
            case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup EnvSettings
es Map EnvSettings ProcessContext
m of
                Just ProcessContext
eo -> forall (m :: * -> *) a. Monad m => a -> m a
return ProcessContext
eo
                Maybe ProcessContext
Nothing -> do
                    ProcessContext
eo <- forall (m :: * -> *).
MonadIO m =>
Map Text Text -> m ProcessContext
mkProcessContext
                        forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"PATH" (if EnvSettings -> Bool
esIncludeLocals EnvSettings
es then Text
localsPath else Text
depsPath)
                        forall a b. (a -> b) -> a -> b
$ (if EnvSettings -> Bool
esIncludeGhcPackagePath EnvSettings
es
                                then forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (WhichCompiler -> Text
ghcPkgPathEnvVar WhichCompiler
wc) (Bool -> Text
mkGPP (EnvSettings -> Bool
esIncludeLocals EnvSettings
es))
                                else forall a. a -> a
id)

                        forall a b. (a -> b) -> a -> b
$ (if EnvSettings -> Bool
esStackExe EnvSettings
es
                                then forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"STACK_EXE" ([Char] -> Text
T.pack [Char]
executablePath)
                                else forall a. a -> a
id)

                        forall a b. (a -> b) -> a -> b
$ (if EnvSettings -> Bool
esLocaleUtf8 EnvSettings
es
                                then forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Text Text
utf8EnvVars
                                else forall a. a -> a
id)

                        forall a b. (a -> b) -> a -> b
$ case (SetupOpts -> Bool
soptsSkipMsys SetupOpts
sopts, Platform
platform) of
                            (Bool
False, Platform Arch
Cabal.I386   OS
Cabal.Windows)
                                -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"MSYSTEM" Text
"MINGW32"
                            (Bool
False, Platform Arch
Cabal.X86_64 OS
Cabal.Windows)
                                -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"MSYSTEM" Text
"MINGW64"
                            (Bool, Platform)
_   -> forall a. a -> a
id

                        -- See https://github.com/commercialhaskell/stack/issues/3444

                        forall a b. (a -> b) -> a -> b
$ case (EnvSettings -> Bool
esKeepGhcRts EnvSettings
es, Maybe [Char]
mGhcRtsEnvVar) of
                            (Bool
True, Just [Char]
ghcRts) -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"GHCRTS" ([Char] -> Text
T.pack [Char]
ghcRts)
                            (Bool, Maybe [Char])
_ -> forall a. a -> a
id

                        -- For reasoning and duplication, see:

                        -- https://github.com/commercialhaskell/stack/issues/70

                        forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"HASKELL_PACKAGE_SANDBOX" ([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep Path Abs Dir
deps)
                        forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"HASKELL_PACKAGE_SANDBOXES"
                            ([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ if EnvSettings -> Bool
esIncludeLocals EnvSettings
es
                                then forall a. [a] -> [[a]] -> [a]
intercalate [Char
searchPathSeparator]
                                        [ forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep Path Abs Dir
localdb
                                        , forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep Path Abs Dir
deps
                                        , [Char]
""
                                        ]
                                else forall a. [a] -> [[a]] -> [a]
intercalate [Char
searchPathSeparator]
                                        [ forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep Path Abs Dir
deps
                                        , [Char]
""
                                        ])
                        forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"HASKELL_DIST_DIR" ([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep Path Abs Dir
distDir)

                          -- Make sure that any .ghc.environment files

                          -- are ignored, since we're setting up our

                          -- own package databases. See

                          -- https://github.com/commercialhaskell/stack/issues/4706

                        forall a b. (a -> b) -> a -> b
$ (case CompilerPaths -> ActualCompiler
cpCompilerVersion CompilerPaths
compilerPaths of
                             ACGhc Version
version | Version
version forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
8, Int
4, Int
4] ->
                               forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"GHC_ENVIRONMENT" Text
"-"
                             ActualCompiler
_ -> forall a. a -> a
id)

                          Map Text Text
env

                    () <- forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef IORef (Map EnvSettings ProcessContext)
envRef forall a b. (a -> b) -> a -> b
$ \Map EnvSettings ProcessContext
m' ->
                        (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert EnvSettings
es ProcessContext
eo Map EnvSettings ProcessContext
m', ())
                    forall (m :: * -> *) a. Monad m => a -> m a
return ProcessContext
eo

    ProcessContext
envOverride <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ EnvSettings -> IO ProcessContext
getProcessContext' EnvSettings
minimalEnvSettings
    forall (m :: * -> *) a. Monad m => a -> m a
return EnvConfig
        { envConfigBuildConfig :: BuildConfig
envConfigBuildConfig = BuildConfig
bc
            { bcConfig :: Config
bcConfig = ExtraDirs -> Config -> Config
addIncludeLib ExtraDirs
ghcBin
                       forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
set forall env. HasProcessContext env => Lens' env ProcessContext
processContextL ProcessContext
envOverride
                         (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL BuildConfig
bc)
                { configProcessContextSettings :: EnvSettings -> IO ProcessContext
configProcessContextSettings = EnvSettings -> IO ProcessContext
getProcessContext'
                }
            }
        , envConfigBuildOptsCLI :: BuildOptsCLI
envConfigBuildOptsCLI = BuildOptsCLI
boptsCLI
        , envConfigSourceMap :: SourceMap
envConfigSourceMap = SourceMap
sourceMap
        , envConfigSourceMapHash :: SourceMapHash
envConfigSourceMapHash = SourceMapHash
sourceMapHash
        , envConfigCompilerPaths :: CompilerPaths
envConfigCompilerPaths = CompilerPaths
compilerPaths
        }

-- | A modified env which we know has an installed compiler on the PATH.

data WithGHC env = WithGHC !CompilerPaths !env

insideL :: Lens' (WithGHC env) env
insideL :: forall env. Lens' (WithGHC env) env
insideL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(WithGHC CompilerPaths
_ env
x) -> env
x) (\(WithGHC CompilerPaths
cp env
_) -> forall env. CompilerPaths -> env -> WithGHC env
WithGHC CompilerPaths
cp)

instance HasLogFunc env => HasLogFunc (WithGHC env) where
  logFuncL :: Lens' (WithGHC env) LogFunc
logFuncL = forall env. Lens' (WithGHC env) env
insideLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasLogFunc env => Lens' env LogFunc
logFuncL
instance HasRunner env => HasRunner (WithGHC env) where
  runnerL :: Lens' (WithGHC env) Runner
runnerL = forall env. Lens' (WithGHC env) env
insideLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasRunner env => Lens' env Runner
runnerL
instance HasProcessContext env => HasProcessContext (WithGHC env) where
  processContextL :: Lens' (WithGHC env) ProcessContext
processContextL = forall env. Lens' (WithGHC env) env
insideLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasProcessContext env => Lens' env ProcessContext
processContextL
instance HasStylesUpdate env => HasStylesUpdate (WithGHC env) where
  stylesUpdateL :: Lens' (WithGHC env) StylesUpdate
stylesUpdateL = forall env. Lens' (WithGHC env) env
insideLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasStylesUpdate env => Lens' env StylesUpdate
stylesUpdateL
instance HasTerm env => HasTerm (WithGHC env) where
  useColorL :: Lens' (WithGHC env) Bool
useColorL = forall env. Lens' (WithGHC env) env
insideLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasTerm env => Lens' env Bool
useColorL
  termWidthL :: Lens' (WithGHC env) Int
termWidthL = forall env. Lens' (WithGHC env) env
insideLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasTerm env => Lens' env Int
termWidthL
instance HasPantryConfig env => HasPantryConfig (WithGHC env) where
  pantryConfigL :: Lens' (WithGHC env) PantryConfig
pantryConfigL = forall env. Lens' (WithGHC env) env
insideLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigL
instance HasConfig env => HasPlatform (WithGHC env)
instance HasConfig env => HasGHCVariant (WithGHC env)
instance HasConfig env => HasConfig (WithGHC env) where
  configL :: Lens' (WithGHC env) Config
configL = forall env. Lens' (WithGHC env) env
insideLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasConfig env => Lens' env Config
configL
instance HasBuildConfig env => HasBuildConfig (WithGHC env) where
  buildConfigL :: Lens' (WithGHC env) BuildConfig
buildConfigL = forall env. Lens' (WithGHC env) env
insideLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigL
instance HasCompiler (WithGHC env) where
  compilerPathsL :: SimpleGetter (WithGHC env) CompilerPaths
compilerPathsL = forall s a. (s -> a) -> SimpleGetter s a
to (\(WithGHC CompilerPaths
cp env
_) -> CompilerPaths
cp)

-- | Set up a modified environment which includes the modified PATH

-- that GHC can be found on. This is needed for looking up global

-- package information and ghc fingerprint (result from 'ghc --info').

runWithGHC :: HasConfig env => ProcessContext -> CompilerPaths -> RIO (WithGHC env) a -> RIO env a
runWithGHC :: forall env a.
HasConfig env =>
ProcessContext -> CompilerPaths -> RIO (WithGHC env) a -> RIO env a
runWithGHC ProcessContext
pc CompilerPaths
cp RIO (WithGHC env) a
inner = do
  env
env <- forall r (m :: * -> *). MonadReader r m => m r
ask
  let envg :: WithGHC env
envg
        = forall env. CompilerPaths -> env -> WithGHC env
WithGHC CompilerPaths
cp forall a b. (a -> b) -> a -> b
$
          forall s t a b. ASetter s t a b -> b -> s -> t
set forall env.
HasConfig env =>
Lens' env (EnvSettings -> IO ProcessContext)
envOverrideSettingsL (\EnvSettings
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ProcessContext
pc) forall a b. (a -> b) -> a -> b
$
          forall s t a b. ASetter s t a b -> b -> s -> t
set forall env. HasProcessContext env => Lens' env ProcessContext
processContextL ProcessContext
pc env
env
  forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO WithGHC env
envg RIO (WithGHC env) a
inner

-- | special helper for GHCJS which needs an updated source map

-- only project dependencies should get included otherwise source map hash will

-- get changed and EnvConfig will become inconsistent

rebuildEnv :: EnvConfig
    -> NeedTargets
    -> Bool
    -> BuildOptsCLI
    -> RIO env EnvConfig
rebuildEnv :: forall env.
EnvConfig
-> NeedTargets -> Bool -> BuildOptsCLI -> RIO env EnvConfig
rebuildEnv EnvConfig
envConfig NeedTargets
needTargets Bool
haddockDeps BuildOptsCLI
boptsCLI = do
    let bc :: BuildConfig
bc = EnvConfig -> BuildConfig
envConfigBuildConfig EnvConfig
envConfig
        cp :: CompilerPaths
cp = EnvConfig -> CompilerPaths
envConfigCompilerPaths EnvConfig
envConfig
        compilerVer :: ActualCompiler
compilerVer = SourceMap -> ActualCompiler
smCompiler forall a b. (a -> b) -> a -> b
$ EnvConfig -> SourceMap
envConfigSourceMap EnvConfig
envConfig
    forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO (forall env. CompilerPaths -> env -> WithGHC env
WithGHC CompilerPaths
cp BuildConfig
bc) forall a b. (a -> b) -> a -> b
$ do
        SMActual DumpedGlobalPackage
smActual <- forall env.
(HasConfig env, HasCompiler env) =>
SMWanted
-> ActualCompiler -> RIO env (SMActual DumpedGlobalPackage)
actualFromGhc (BuildConfig -> SMWanted
bcSMWanted BuildConfig
bc) ActualCompiler
compilerVer
        let actualPkgs :: Set PackageName
actualPkgs = forall k a. Map k a -> Set k
Map.keysSet (forall global. SMActual global -> Map PackageName DepPackage
smaDeps SMActual DumpedGlobalPackage
smActual) forall a. Semigroup a => a -> a -> a
<> forall k a. Map k a -> Set k
Map.keysSet (forall global. SMActual global -> Map PackageName ProjectPackage
smaProject SMActual DumpedGlobalPackage
smActual)
            prunedActual :: SMActual GlobalPackage
prunedActual = SMActual DumpedGlobalPackage
smActual {
              smaGlobal :: Map PackageName GlobalPackage
smaGlobal = Map PackageName DumpedGlobalPackage
-> Set PackageName -> Map PackageName GlobalPackage
pruneGlobals (forall global. SMActual global -> Map PackageName global
smaGlobal SMActual DumpedGlobalPackage
smActual) Set PackageName
actualPkgs
              }
        SMTargets
targets <- forall env.
HasBuildConfig env =>
NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
parseTargets NeedTargets
needTargets Bool
haddockDeps BuildOptsCLI
boptsCLI SMActual GlobalPackage
prunedActual
        SourceMap
sourceMap <- forall env.
HasBuildConfig env =>
SMTargets
-> BuildOptsCLI
-> SMActual DumpedGlobalPackage
-> RIO env SourceMap
loadSourceMap SMTargets
targets BuildOptsCLI
boptsCLI SMActual DumpedGlobalPackage
smActual
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
            EnvConfig
envConfig
            {envConfigSourceMap :: SourceMap
envConfigSourceMap = SourceMap
sourceMap, envConfigBuildOptsCLI :: BuildOptsCLI
envConfigBuildOptsCLI = BuildOptsCLI
boptsCLI}

-- | Some commands (script, ghci and exec) set targets dynamically

-- see also the note about only local targets for rebuildEnv

withNewLocalBuildTargets :: HasEnvConfig  env => [Text] -> RIO env a -> RIO env a
withNewLocalBuildTargets :: forall env a. HasEnvConfig env => [Text] -> RIO env a -> RIO env a
withNewLocalBuildTargets [Text]
targets RIO env a
f = do
    EnvConfig
envConfig <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL
    Bool
haddockDeps <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> BuildOpts
configBuildforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to BuildOpts -> Bool
shouldHaddockDeps
    let boptsCLI :: BuildOptsCLI
boptsCLI = EnvConfig -> BuildOptsCLI
envConfigBuildOptsCLI EnvConfig
envConfig
    EnvConfig
envConfig' <- forall env.
EnvConfig
-> NeedTargets -> Bool -> BuildOptsCLI -> RIO env EnvConfig
rebuildEnv EnvConfig
envConfig NeedTargets
NeedTargets Bool
haddockDeps forall a b. (a -> b) -> a -> b
$
                  BuildOptsCLI
boptsCLI {boptsCLITargets :: [Text]
boptsCLITargets = [Text]
targets}
    forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (forall s t a b. ASetter s t a b -> b -> s -> t
set forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL EnvConfig
envConfig') RIO env a
f

-- | Add the include and lib paths to the given Config

addIncludeLib :: ExtraDirs -> Config -> Config
addIncludeLib :: ExtraDirs -> Config -> Config
addIncludeLib (ExtraDirs [Path Abs Dir]
_bins [Path Abs Dir]
includes [Path Abs Dir]
libs) Config
config = Config
config
    { configExtraIncludeDirs :: [[Char]]
configExtraIncludeDirs =
        Config -> [[Char]]
configExtraIncludeDirs Config
config forall a. [a] -> [a] -> [a]
++
        forall a b. (a -> b) -> [a] -> [b]
map forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep [Path Abs Dir]
includes
    , configExtraLibDirs :: [[Char]]
configExtraLibDirs =
        Config -> [[Char]]
configExtraLibDirs Config
config forall a. [a] -> [a] -> [a]
++
        forall a b. (a -> b) -> [a] -> [b]
map forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep [Path Abs Dir]
libs
    }

-- | Ensure both the compiler and the msys toolchain are installed and

-- provide the PATHs to add if necessary

ensureCompilerAndMsys
  :: (HasBuildConfig env, HasGHCVariant env)
  => SetupOpts
  -> RIO env (CompilerPaths, ExtraDirs)
ensureCompilerAndMsys :: forall env.
(HasBuildConfig env, HasGHCVariant env) =>
SetupOpts -> RIO env (CompilerPaths, ExtraDirs)
ensureCompilerAndMsys SetupOpts
sopts = do
  Memoized SetupInfo
getSetupInfo' <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Memoized a)
memoizeRef forall env. HasConfig env => RIO env SetupInfo
getSetupInfo
  Maybe Tool
mmsys2Tool <- forall env.
HasBuildConfig env =>
SetupOpts -> Memoized SetupInfo -> RIO env (Maybe Tool)
ensureMsys SetupOpts
sopts Memoized SetupInfo
getSetupInfo'
  Maybe ExtraDirs
msysPaths <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env. HasConfig env => Tool -> RIO env ExtraDirs
extraDirs) Maybe Tool
mmsys2Tool

  ActualCompiler
actual <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ WantedCompiler -> Either CompilerException ActualCompiler
wantedToActual forall a b. (a -> b) -> a -> b
$ SetupOpts -> WantedCompiler
soptsWantedCompiler SetupOpts
sopts
  Bool
didWarn <- forall env. HasLogFunc env => Version -> RIO env Bool
warnUnsupportedCompiler forall a b. (a -> b) -> a -> b
$ ActualCompiler -> Version
getGhcVersion ActualCompiler
actual

  (CompilerPaths
cp, ExtraDirs
ghcPaths) <- forall env.
(HasConfig env, HasBuildConfig env, HasGHCVariant env) =>
SetupOpts
-> Memoized SetupInfo -> RIO env (CompilerPaths, ExtraDirs)
ensureCompiler SetupOpts
sopts Memoized SetupInfo
getSetupInfo'

  forall env. HasLogFunc env => CompilerPaths -> Bool -> RIO env ()
warnUnsupportedCompilerCabal CompilerPaths
cp Bool
didWarn

  let paths :: ExtraDirs
paths = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ExtraDirs
ghcPaths (ExtraDirs
ghcPaths forall a. Semigroup a => a -> a -> a
<>) Maybe ExtraDirs
msysPaths
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompilerPaths
cp, ExtraDirs
paths)

-- | See <https://github.com/commercialhaskell/stack/issues/4246>

warnUnsupportedCompiler :: HasLogFunc env => Version -> RIO env Bool
warnUnsupportedCompiler :: forall env. HasLogFunc env => Version -> RIO env Bool
warnUnsupportedCompiler Version
ghcVersion = do
  if
    | Version
ghcVersion forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
7, Int
8] -> do
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
          Utf8Builder
"Stack will almost certainly fail with GHC below version 7.8, requested " forall a. Semigroup a => a -> a -> a
<>
          forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
versionString Version
ghcVersion)
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Valiantly attempting to run anyway, but I know this is doomed"
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"For more information, see: https://github.com/commercialhaskell/stack/issues/648"
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
""
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    | Version
ghcVersion forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
9, Int
5] -> do
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
          Utf8Builder
"Stack has not been tested with GHC versions above 9.4, and using " forall a. Semigroup a => a -> a -> a
<>
          forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
versionString Version
ghcVersion) forall a. Semigroup a => a -> a -> a
<>
          Utf8Builder
", this may fail"
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    | Bool
otherwise -> do
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Asking for a supported GHC version"
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

-- | See <https://github.com/commercialhaskell/stack/issues/4246>

warnUnsupportedCompilerCabal
  :: HasLogFunc env
  => CompilerPaths
  -> Bool -- ^ already warned about GHC?

  -> RIO env ()
warnUnsupportedCompilerCabal :: forall env. HasLogFunc env => CompilerPaths -> Bool -> RIO env ()
warnUnsupportedCompilerCabal CompilerPaths
cp Bool
didWarn = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
didWarn 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. HasLogFunc env => Version -> RIO env Bool
warnUnsupportedCompiler forall a b. (a -> b) -> a -> b
$ ActualCompiler -> Version
getGhcVersion forall a b. (a -> b) -> a -> b
$ CompilerPaths -> ActualCompiler
cpCompilerVersion CompilerPaths
cp
  let cabalVersion :: Version
cabalVersion = CompilerPaths -> Version
cpCabalVersion CompilerPaths
cp

  if
    | Version
cabalVersion forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
1, Int
19, Int
2] -> do
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Stack no longer supports Cabal versions below 1.19.2,"
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"but version " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
versionString Version
cabalVersion) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" was found."
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"This invocation will most likely fail."
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"To fix this, either use an older version of Stack or a newer resolver"
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Acceptable resolvers: lts-3.0/nightly-2015-05-05 or later"
    | Version
cabalVersion forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
3, Int
9] ->
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
          Utf8Builder
"Stack has not been tested with Cabal versions above 3.8, but version " forall a. Semigroup a => a -> a -> a
<>
          forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
versionString Version
cabalVersion) forall a. Semigroup a => a -> a -> a
<>
          Utf8Builder
" was found, this may fail"
    | Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Ensure that the msys toolchain is installed if necessary and

-- provide the PATHs to add if necessary

ensureMsys
  :: HasBuildConfig env
  => SetupOpts
  -> Memoized SetupInfo
  -> RIO env (Maybe Tool)
ensureMsys :: forall env.
HasBuildConfig env =>
SetupOpts -> Memoized SetupInfo -> RIO env (Maybe Tool)
ensureMsys SetupOpts
sopts Memoized SetupInfo
getSetupInfo' = do
  Platform
platform <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL
  Path Abs Dir
localPrograms <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> Path Abs Dir
configLocalPrograms
  [Tool]
installed <- forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs Dir -> m [Tool]
listInstalled Path Abs Dir
localPrograms

  case Platform
platform of
      Platform Arch
_ OS
Cabal.Windows | Bool -> Bool
not (SetupOpts -> Bool
soptsSkipMsys SetupOpts
sopts) ->
          case [Tool] -> PackageName -> (Version -> Bool) -> Maybe Tool
getInstalledTool [Tool]
installed ([Char] -> PackageName
mkPackageName [Char]
"msys2") (forall a b. a -> b -> a
const Bool
True) of
              Just Tool
tool -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Tool
tool)
              Maybe Tool
Nothing
                  | SetupOpts -> Bool
soptsInstallIfMissing SetupOpts
sopts -> do
                      SetupInfo
si <- forall (m :: * -> *) a. MonadIO m => Memoized a -> m a
runMemoized Memoized SetupInfo
getSetupInfo'
                      Text
osKey <- forall (m :: * -> *). MonadThrow m => Platform -> m Text
getOSKey Platform
platform
                      Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
                      VersionedDownloadInfo Version
version DownloadInfo
info <-
                          case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
osKey forall a b. (a -> b) -> a -> b
$ SetupInfo -> Map Text VersionedDownloadInfo
siMsys2 SetupInfo
si of
                              Just VersionedDownloadInfo
x -> forall (m :: * -> *) a. Monad m => a -> m a
return VersionedDownloadInfo
x
                              Maybe VersionedDownloadInfo
Nothing -> forall (m :: * -> *) a. (MonadIO m, HasCallStack) => [Char] -> m a
throwString forall a b. (a -> b) -> a -> b
$ [Char]
"MSYS2 not found for " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
osKey
                      let tool :: Tool
tool = PackageIdentifier -> Tool
Tool (PackageName -> Version -> PackageIdentifier
PackageIdentifier ([Char] -> PackageName
mkPackageName [Char]
"msys2") Version
version)
                      forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env.
(HasTerm env, HasBuildConfig env) =>
Path Abs Dir
-> DownloadInfo
-> Tool
-> (Path Abs File
    -> ArchiveType -> Path Abs Dir -> Path Abs Dir -> RIO env ())
-> RIO env Tool
downloadAndInstallTool (Config -> Path Abs Dir
configLocalPrograms Config
config) DownloadInfo
info Tool
tool (forall env.
HasBuildConfig env =>
SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
installMsys2Windows SetupInfo
si)
                  | Bool
otherwise -> do
                      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Continuing despite missing tool: msys2"
                      forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      Platform
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

installGhcBindist
  :: HasBuildConfig env
  => SetupOpts
  -> Memoized SetupInfo
  -> [Tool]
  -> RIO env (Tool, CompilerBuild)
installGhcBindist :: forall env.
HasBuildConfig env =>
SetupOpts
-> Memoized SetupInfo -> [Tool] -> RIO env (Tool, CompilerBuild)
installGhcBindist SetupOpts
sopts Memoized SetupInfo
getSetupInfo' [Tool]
installed = do
    Platform Arch
expectedArch OS
_ <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL
    let wanted :: WantedCompiler
wanted = SetupOpts -> WantedCompiler
soptsWantedCompiler SetupOpts
sopts
        isWanted :: ActualCompiler -> Bool
isWanted = VersionCheck -> WantedCompiler -> ActualCompiler -> Bool
isWantedCompiler (SetupOpts -> VersionCheck
soptsCompilerCheck SetupOpts
sopts) (SetupOpts -> WantedCompiler
soptsWantedCompiler SetupOpts
sopts)
    Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
    GHCVariant
ghcVariant <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasGHCVariant env => SimpleGetter env GHCVariant
ghcVariantL
    WhichCompiler
wc <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActualCompiler -> WhichCompiler
whichCompiler) forall a b. (a -> b) -> a -> b
$ WantedCompiler -> Either CompilerException ActualCompiler
wantedToActual WantedCompiler
wanted
    [(Maybe Tool, CompilerBuild)]
possibleCompilers <-
            case WhichCompiler
wc of
                WhichCompiler
Ghc -> do
                    [CompilerBuild]
ghcBuilds <- forall env. HasConfig env => RIO env [CompilerBuild]
getGhcBuilds
                    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CompilerBuild]
ghcBuilds forall a b. (a -> b) -> a -> b
$ \CompilerBuild
ghcBuild -> do
                        PackageName
ghcPkgName <- forall (m :: * -> *). MonadThrow m => [Char] -> m PackageName
parsePackageNameThrowing ([Char]
"ghc" forall a. [a] -> [a] -> [a]
++ GHCVariant -> [Char]
ghcVariantSuffix GHCVariant
ghcVariant forall a. [a] -> [a] -> [a]
++ CompilerBuild -> [Char]
compilerBuildSuffix CompilerBuild
ghcBuild)
                        forall (m :: * -> *) a. Monad m => a -> m a
return ([Tool] -> PackageName -> (Version -> Bool) -> Maybe Tool
getInstalledTool [Tool]
installed PackageName
ghcPkgName (ActualCompiler -> Bool
isWanted forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> ActualCompiler
ACGhc), CompilerBuild
ghcBuild)
    let existingCompilers :: [(Tool, CompilerBuild)]
existingCompilers = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
            (\(Maybe Tool
installedCompiler, CompilerBuild
compilerBuild) ->
                case (Maybe Tool
installedCompiler, SetupOpts -> Bool
soptsForceReinstall SetupOpts
sopts) of
                    (Just Tool
tool, Bool
False) -> [(Tool
tool, CompilerBuild
compilerBuild)]
                    (Maybe Tool, Bool)
_ -> [])
            [(Maybe Tool, CompilerBuild)]
possibleCompilers
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$
      Utf8Builder
"Found already installed GHC builds: " forall a. Semigroup a => a -> a -> a
<>
      forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
intersperse Utf8Builder
", " (forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerBuild -> [Char]
compilerBuildName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Tool, CompilerBuild)]
existingCompilers))
    case [(Tool, CompilerBuild)]
existingCompilers of
        (Tool
tool, CompilerBuild
build_):[(Tool, CompilerBuild)]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (Tool
tool, CompilerBuild
build_)
        []
            | SetupOpts -> Bool
soptsInstallIfMissing SetupOpts
sopts -> do
                SetupInfo
si <- forall (m :: * -> *) a. MonadIO m => Memoized a -> m a
runMemoized Memoized SetupInfo
getSetupInfo'
                forall env.
(HasGHCVariant env, HasBuildConfig env) =>
[CompilerBuild]
-> SetupInfo
-> WantedCompiler
-> VersionCheck
-> Maybe [Char]
-> RIO env (Tool, CompilerBuild)
downloadAndInstallPossibleCompilers
                    (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Maybe Tool, CompilerBuild)]
possibleCompilers)
                    SetupInfo
si
                    (SetupOpts -> WantedCompiler
soptsWantedCompiler SetupOpts
sopts)
                    (SetupOpts -> VersionCheck
soptsCompilerCheck SetupOpts
sopts)
                    (SetupOpts -> Maybe [Char]
soptsGHCBindistURL SetupOpts
sopts)
            | Bool
otherwise -> do
                let suggestion :: Text
suggestion = forall a. a -> Maybe a -> a
fromMaybe
                        (forall a. Monoid a => [a] -> a
mconcat
                             [ Text
"To install the correct GHC into "
                             , [Char] -> Text
T.pack (forall b t. Path b t -> [Char]
toFilePath (Config -> Path Abs Dir
configLocalPrograms Config
config))
                             , Text
", try running \"stack setup\" or use the \"--install-ghc\" flag."
                             , Text
" To use your system GHC installation, run \"stack config set system-ghc --global true\", or use the \"--system-ghc\" flag."
                             ])
                        (SetupOpts -> Maybe Text
soptsResolveMissingGHC SetupOpts
sopts)
                forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Maybe (ActualCompiler, Arch)
-> (WantedCompiler, Arch)
-> GHCVariant
-> CompilerBuild
-> VersionCheck
-> Maybe (Path Abs File)
-> Text
-> StackBuildException
CompilerVersionMismatch
                    forall a. Maybe a
Nothing -- FIXME ((\(x, y, _) -> (x, y)) <$> msystem)

                    (SetupOpts -> WantedCompiler
soptsWantedCompiler SetupOpts
sopts, Arch
expectedArch)
                    GHCVariant
ghcVariant
                    (case [(Maybe Tool, CompilerBuild)]
possibleCompilers of
                        [] -> CompilerBuild
CompilerBuildStandard
                        (Maybe Tool
_, CompilerBuild
compilerBuild):[(Maybe Tool, CompilerBuild)]
_ -> CompilerBuild
compilerBuild)
                    (SetupOpts -> VersionCheck
soptsCompilerCheck SetupOpts
sopts)
                    (SetupOpts -> Maybe (Path Abs File)
soptsStackYaml SetupOpts
sopts)
                    Text
suggestion

-- | Ensure compiler is installed, without worrying about msys

ensureCompiler
  :: forall env. (HasConfig env, HasBuildConfig env, HasGHCVariant env)
  => SetupOpts
  -> Memoized SetupInfo
  -> RIO env (CompilerPaths, ExtraDirs)
ensureCompiler :: forall env.
(HasConfig env, HasBuildConfig env, HasGHCVariant env) =>
SetupOpts
-> Memoized SetupInfo -> RIO env (CompilerPaths, ExtraDirs)
ensureCompiler SetupOpts
sopts Memoized SetupInfo
getSetupInfo' = do
    let wanted :: WantedCompiler
wanted = SetupOpts -> WantedCompiler
soptsWantedCompiler SetupOpts
sopts
    WhichCompiler
wc <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActualCompiler -> WhichCompiler
whichCompiler) forall a b. (a -> b) -> a -> b
$ WantedCompiler -> Either CompilerException ActualCompiler
wantedToActual WantedCompiler
wanted

    Path Abs File
hook <- forall env. HasConfig env => RIO env (Path Abs File)
ghcInstallHook
    Bool
hookIsExecutable <- forall (m :: * -> *) a.
MonadUnliftIO 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
$ if Bool
osIsWindows
      then forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
hook  -- can't really detect executable on windows, only file extension

      else Permissions -> Bool
executable forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) b t. MonadIO m => Path b t -> m Permissions
getPermissions Path Abs File
hook

    Platform Arch
expectedArch OS
_ <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL

    let canUseCompiler :: CompilerPaths -> RIO env CompilerPaths
canUseCompiler CompilerPaths
cp
            | SetupOpts -> Bool
soptsSkipGhcCheck SetupOpts
sopts = forall (f :: * -> *) a. Applicative f => a -> f a
pure CompilerPaths
cp
            | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ ActualCompiler -> Bool
isWanted forall a b. (a -> b) -> a -> b
$ CompilerPaths -> ActualCompiler
cpCompilerVersion CompilerPaths
cp = forall (m :: * -> *) a. (MonadIO m, HasCallStack) => [Char] -> m a
throwString [Char]
"Not the compiler version we want"
            | CompilerPaths -> Arch
cpArch CompilerPaths
cp forall a. Eq a => a -> a -> Bool
/= Arch
expectedArch = forall (m :: * -> *) a. (MonadIO m, HasCallStack) => [Char] -> m a
throwString [Char]
"Not the architecture we want"
            | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure CompilerPaths
cp
        isWanted :: ActualCompiler -> Bool
isWanted = VersionCheck -> WantedCompiler -> ActualCompiler -> Bool
isWantedCompiler (SetupOpts -> VersionCheck
soptsCompilerCheck SetupOpts
sopts) (SetupOpts -> WantedCompiler
soptsWantedCompiler SetupOpts
sopts)

    let checkCompiler :: Path Abs File -> RIO env (Maybe CompilerPaths)
        checkCompiler :: Path Abs File -> RIO env (Maybe CompilerPaths)
checkCompiler Path Abs File
compiler = do
          Either SomeException CompilerPaths
eres <- forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny forall a b. (a -> b) -> a -> b
$ forall env.
HasConfig env =>
WhichCompiler
-> CompilerBuild -> Bool -> Path Abs File -> RIO env CompilerPaths
pathsFromCompiler WhichCompiler
wc CompilerBuild
CompilerBuildStandard Bool
False Path Abs File
compiler forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CompilerPaths -> RIO env CompilerPaths
canUseCompiler
          case Either SomeException CompilerPaths
eres of
            Left SomeException
e -> do
              forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Not using compiler at " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow (forall b t. Path b t -> [Char]
toFilePath Path Abs File
compiler) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow SomeException
e
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Right CompilerPaths
cp -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just CompilerPaths
cp

    Maybe CompilerPaths
mcp <-
      if | SetupOpts -> Bool
soptsUseSystem SetupOpts
sopts -> do
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Getting system compiler version"
            forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$
              forall env i.
(HasProcessContext env, HasLogFunc env) =>
WantedCompiler -> ConduitT i (Path Abs File) (RIO env) ()
sourceSystemCompilers WantedCompiler
wanted forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
              forall (m :: * -> *) mono a.
(Monad m, MonoFoldable mono) =>
(a -> m mono) -> ConduitT a (Element mono) m ()
concatMapMC Path Abs File -> RIO env (Maybe CompilerPaths)
checkCompiler forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
              forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await
         | Bool
hookIsExecutable -> do
          -- if the hook fails, we fall through to stacks sandboxed installation

            Maybe (Path Abs File)
hookGHC <- forall env.
HasBuildConfig env =>
SetupOpts -> Path Abs File -> RIO env (Maybe (Path Abs File))
runGHCInstallHook SetupOpts
sopts Path Abs File
hook
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) Path Abs File -> RIO env (Maybe CompilerPaths)
checkCompiler Maybe (Path Abs File)
hookGHC
         | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    case Maybe CompilerPaths
mcp of
      Maybe CompilerPaths
Nothing -> forall env.
HasBuildConfig env =>
SetupOpts
-> Memoized SetupInfo -> RIO env (CompilerPaths, ExtraDirs)
ensureSandboxedCompiler SetupOpts
sopts Memoized SetupInfo
getSetupInfo'
      Just CompilerPaths
cp -> do
        let paths :: ExtraDirs
paths = ExtraDirs { edBins :: [Path Abs Dir]
edBins = [forall b t. Path b t -> Path b Dir
parent forall a b. (a -> b) -> a -> b
$ CompilerPaths -> Path Abs File
cpCompiler CompilerPaths
cp], edInclude :: [Path Abs Dir]
edInclude = [], edLib :: [Path Abs Dir]
edLib = [] }
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompilerPaths
cp, ExtraDirs
paths)


-- | Runs @STACK_ROOT\/hooks\/ghc-install.sh@.

--

-- Reads and possibly validates the output of the process as the GHC

-- binary and returns it.

runGHCInstallHook
  :: HasBuildConfig env
  => SetupOpts
  -> Path Abs File
  -> RIO env (Maybe (Path Abs File))
runGHCInstallHook :: forall env.
HasBuildConfig env =>
SetupOpts -> Path Abs File -> RIO env (Maybe (Path Abs File))
runGHCInstallHook SetupOpts
sopts Path Abs File
hook = do
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Getting hook installed compiler version"
    let wanted :: WantedCompiler
wanted = SetupOpts -> WantedCompiler
soptsWantedCompiler SetupOpts
sopts
    ProcessContext
menv0 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasProcessContext env => Lens' env ProcessContext
processContextL
    ProcessContext
menv <- forall (m :: * -> *).
MonadIO m =>
Map Text Text -> m ProcessContext
mkProcessContext (forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (WantedCompiler -> Map Text Text
wantedCompilerToEnv WantedCompiler
wanted) forall a b. (a -> b) -> a -> b
$
      Map Text Text -> Map Text Text
removeHaskellEnvVars (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env.
HasProcessContext env =>
SimpleGetter env (Map Text Text)
envVarsL ProcessContext
menv0))
    (ExitCode
exit, ByteString
out) <- forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc [Char]
"sh" [forall b t. Path b t -> [Char]
toFilePath Path Abs File
hook] forall (m :: * -> *) stdin stdoutIgnored stderr.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderr
-> m (ExitCode, ByteString)
readProcessStdout
    case ExitCode
exit of
      ExitCode
ExitSuccess -> do
        let ghcPath :: [Char]
ghcPath = ShowS
stripNewline forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
TL.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
TL.decodeUtf8With OnDecodeError
T.lenientDecode forall a b. (a -> b) -> a -> b
$ ByteString
out
        case forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs File)
parseAbsFile [Char]
ghcPath of
          Just Path Abs File
compiler -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SetupOpts -> Bool
soptsSanityCheck SetupOpts
sopts) forall a b. (a -> b) -> a -> b
$ forall env.
(HasProcessContext env, HasLogFunc env) =>
Path Abs File -> RIO env ()
sanityCheck Path Abs File
compiler
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Using GHC compiler at: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs File
compiler))
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Path Abs File
compiler)
          Maybe (Path Abs File)
Nothing -> do
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder
"Path to GHC binary is not a valid path: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
ghcPath)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      ExitFailure Int
i -> do
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder
"GHC install hook exited with code: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show Int
i))
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
 where
    wantedCompilerToEnv :: WantedCompiler -> EnvVars
    wantedCompilerToEnv :: WantedCompiler -> Map Text Text
wantedCompilerToEnv (WCGhc Version
ver) =
      forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text
"HOOK_GHC_TYPE", Text
"bindist")
                   ,(Text
"HOOK_GHC_VERSION", [Char] -> Text
T.pack (Version -> [Char]
versionString Version
ver))
                   ]
    wantedCompilerToEnv (WCGhcGit Text
commit Text
flavor) =
      forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text
"HOOK_GHC_TYPE", Text
"git")
                   ,(Text
"HOOK_GHC_COMMIT", Text
commit)
                   ,(Text
"HOOK_GHC_FLAVOR", Text
flavor)
                   ,(Text
"HOOK_GHC_FLAVOUR", Text
flavor)
                   ]
    wantedCompilerToEnv (WCGhcjs Version
ghcjs_ver Version
ghc_ver) =
      forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text
"HOOK_GHC_TYPE", Text
"ghcjs")
                   ,(Text
"HOOK_GHC_VERSION", [Char] -> Text
T.pack (Version -> [Char]
versionString Version
ghc_ver))
                   ,(Text
"HOOK_GHCJS_VERSION", [Char] -> Text
T.pack (Version -> [Char]
versionString Version
ghcjs_ver))
                   ]
    newlines :: [Char]
    newlines :: [Char]
newlines = [Char
'\n', Char
'\r']

    stripNewline :: String -> String
    stripNewline :: ShowS
stripNewline [Char]
str = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem [Char]
newlines) [Char]
str


ensureSandboxedCompiler
  :: HasBuildConfig env
  => SetupOpts
  -> Memoized SetupInfo
  -> RIO env (CompilerPaths, ExtraDirs)
ensureSandboxedCompiler :: forall env.
HasBuildConfig env =>
SetupOpts
-> Memoized SetupInfo -> RIO env (CompilerPaths, ExtraDirs)
ensureSandboxedCompiler SetupOpts
sopts Memoized SetupInfo
getSetupInfo' = do
    let wanted :: WantedCompiler
wanted = SetupOpts -> WantedCompiler
soptsWantedCompiler SetupOpts
sopts
    -- List installed tools

    Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
    let localPrograms :: Path Abs Dir
localPrograms = Config -> Path Abs Dir
configLocalPrograms Config
config
    [Tool]
installed <- forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs Dir -> m [Tool]
listInstalled Path Abs Dir
localPrograms
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Installed tools: \n - " forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
intersperse Utf8Builder
"\n - " (forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tool -> [Char]
toolString) [Tool]
installed))
    (Tool
compilerTool, CompilerBuild
compilerBuild) <-
      case SetupOpts -> WantedCompiler
soptsWantedCompiler SetupOpts
sopts of
       -- shall we build GHC from source?

       WCGhcGit Text
commitId Text
flavour -> forall env.
(HasTerm env, HasProcessContext env, HasBuildConfig env) =>
Memoized SetupInfo
-> [Tool]
-> CompilerRepository
-> Text
-> Text
-> RIO env (Tool, CompilerBuild)
buildGhcFromSource Memoized SetupInfo
getSetupInfo' [Tool]
installed  (Config -> CompilerRepository
configCompilerRepository Config
config) Text
commitId Text
flavour
       WantedCompiler
_ -> forall env.
HasBuildConfig env =>
SetupOpts
-> Memoized SetupInfo -> [Tool] -> RIO env (Tool, CompilerBuild)
installGhcBindist SetupOpts
sopts Memoized SetupInfo
getSetupInfo' [Tool]
installed
    ExtraDirs
paths <- forall env. HasConfig env => Tool -> RIO env ExtraDirs
extraDirs Tool
compilerTool

    WhichCompiler
wc <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActualCompiler -> WhichCompiler
whichCompiler) forall a b. (a -> b) -> a -> b
$ WantedCompiler -> Either CompilerException ActualCompiler
wantedToActual WantedCompiler
wanted
    ProcessContext
menv0 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasProcessContext env => Lens' env ProcessContext
processContextL
    Map Text Text
m <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall (m :: * -> *) a. Monad m => a -> m a
return
       forall a b. (a -> b) -> a -> b
$ [[Char]]
-> Map Text Text -> Either ProcessException (Map Text Text)
augmentPathMap (forall b t. Path b t -> [Char]
toFilePath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExtraDirs -> [Path Abs Dir]
edBins ExtraDirs
paths) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env.
HasProcessContext env =>
SimpleGetter env (Map Text Text)
envVarsL ProcessContext
menv0)
    ProcessContext
menv <- forall (m :: * -> *).
MonadIO m =>
Map Text Text -> m ProcessContext
mkProcessContext (Map Text Text -> Map Text Text
removeHaskellEnvVars Map Text Text
m)

    [[Char]]
names <-
      case WantedCompiler
wanted of
        WCGhc Version
version -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Char]
"ghc-" forall a. [a] -> [a] -> [a]
++ Version -> [Char]
versionString Version
version, [Char]
"ghc"]
        WCGhcGit{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Char]
"ghc"]
        WCGhcjs{} -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO CompilerException
GhcjsNotSupported

    -- Previously, we used findExecutable to locate these executables. This was

    -- actually somewhat sloppy, as it could discover executables outside of the

    -- sandbox. This led to a specific issue on Windows with GHC 9.0.1. See

    -- https://gitlab.haskell.org/ghc/ghc/-/issues/20074. Instead, now, we look

    -- on the paths specified only.

    let loop :: [[Char]] -> RIO env (Path Abs File)
loop [] = do
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Looked for sandboxed compiler named one of: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow [[Char]]
names
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Could not find it on the paths " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow (ExtraDirs -> [Path Abs Dir]
edBins ExtraDirs
paths)
          forall (m :: * -> *) a. (MonadIO m, HasCallStack) => [Char] -> m a
throwString [Char]
"Could not find sandboxed compiler"
        loop ([Char]
x:[[Char]]
xs) = do
          [[Char]]
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char] -> IO [[Char]]
D.findExecutablesInDirectories (forall a b. (a -> b) -> [a] -> [b]
map forall b t. Path b t -> [Char]
toFilePath (ExtraDirs -> [Path Abs Dir]
edBins ExtraDirs
paths)) [Char]
x
          case [[Char]]
res of
            [] -> [[Char]] -> RIO env (Path Abs File)
loop [[Char]]
xs
            [Char]
compiler:[[Char]]
rest -> do
              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
rest) forall a b. (a -> b) -> a -> b
$ do
                forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Found multiple candidate compilers:"
                forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [[Char]]
res forall a b. (a -> b) -> a -> b
$ \[Char]
y -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"- " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
y
                forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"This usually indicates a failed installation. Trying anyway with " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
compiler
              forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs File)
parseAbsFile [Char]
compiler
    Path Abs File
compiler <- forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv forall a b. (a -> b) -> a -> b
$ do
      Path Abs File
compiler <- [[Char]] -> RIO env (Path Abs File)
loop [[Char]]
names

      -- Run this here to ensure that the sanity check uses the modified

      -- environment, otherwise we may infect GHC_PACKAGE_PATH and break sanity

      -- checks.

      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SetupOpts -> Bool
soptsSanityCheck SetupOpts
sopts) forall a b. (a -> b) -> a -> b
$ forall env.
(HasProcessContext env, HasLogFunc env) =>
Path Abs File -> RIO env ()
sanityCheck Path Abs File
compiler

      forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
compiler

    CompilerPaths
cp <- forall env.
HasConfig env =>
WhichCompiler
-> CompilerBuild -> Bool -> Path Abs File -> RIO env CompilerPaths
pathsFromCompiler WhichCompiler
wc CompilerBuild
compilerBuild Bool
True Path Abs File
compiler
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompilerPaths
cp, ExtraDirs
paths)

pathsFromCompiler
  :: forall env. HasConfig env
  => WhichCompiler
  -> CompilerBuild
  -> Bool
  -> Path Abs File -- ^ executable filepath

  -> RIO env CompilerPaths
pathsFromCompiler :: forall env.
HasConfig env =>
WhichCompiler
-> CompilerBuild -> Bool -> Path Abs File -> RIO env CompilerPaths
pathsFromCompiler WhichCompiler
wc CompilerBuild
compilerBuild Bool
isSandboxed Path Abs File
compiler = RIO env CompilerPaths -> RIO env CompilerPaths
withCache forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny SomeException -> RIO env CompilerPaths
onErr forall a b. (a -> b) -> a -> b
$ do
    let dir :: [Char]
dir = forall b t. Path b t -> [Char]
toFilePath forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> Path b Dir
parent Path Abs File
compiler
        suffixNoVersion :: [Char]
suffixNoVersion
          | Bool
osIsWindows = [Char]
".exe"
          | Bool
otherwise = [Char]
""
        msuffixWithVersion :: Maybe [Char]
msuffixWithVersion = do
          let prefix :: [Char]
prefix =
                case WhichCompiler
wc of
                  WhichCompiler
Ghc -> [Char]
"ghc-"
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char]
"-" forall a. [a] -> [a] -> [a]
++) forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
prefix forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> [Char]
toFilePath forall a b. (a -> b) -> a -> b
$ forall b. Path b File -> Path Rel File
filename Path Abs File
compiler
        suffixes :: [[Char]]
suffixes = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (:) Maybe [Char]
msuffixWithVersion [[Char]
suffixNoVersion]
        findHelper :: (WhichCompiler -> [String]) -> RIO env (Path Abs File)
        findHelper :: (WhichCompiler -> [[Char]]) -> RIO env (Path Abs File)
findHelper WhichCompiler -> [[Char]]
getNames = do
          let toTry :: [[Char]]
toTry = [[Char]
dir forall a. [a] -> [a] -> [a]
++ [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
suffix | [Char]
suffix <- [[Char]]
suffixes, [Char]
name <- WhichCompiler -> [[Char]]
getNames WhichCompiler
wc]
              loop :: [[Char]] -> RIO env (Path Abs File)
loop [] = forall (m :: * -> *) a. (MonadIO m, HasCallStack) => [Char] -> m a
throwString forall a b. (a -> b) -> a -> b
$ [Char]
"Could not find any of: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [[Char]]
toTry
              loop ([Char]
guessedPath':[[Char]]
rest) = do
                Path Abs File
guessedPath <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs File)
parseAbsFile [Char]
guessedPath'
                Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
guessedPath
                if Bool
exists
                  then forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
guessedPath
                  else [[Char]] -> RIO env (Path Abs File)
loop [[Char]]
rest
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Looking for executable(s): " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow [[Char]]
toTry
          [[Char]] -> RIO env (Path Abs File)
loop [[Char]]
toTry
    GhcPkgExe
pkg <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Path Abs File -> GhcPkgExe
GhcPkgExe forall a b. (a -> b) -> a -> b
$ (WhichCompiler -> [[Char]]) -> RIO env (Path Abs File)
findHelper forall a b. (a -> b) -> a -> b
$ \case
                               WhichCompiler
Ghc -> [[Char]
"ghc-pkg"]

    ProcessContext
menv0 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasProcessContext env => Lens' env ProcessContext
processContextL
    ProcessContext
menv <- forall (m :: * -> *).
MonadIO m =>
Map Text Text -> m ProcessContext
mkProcessContext (Map Text Text -> Map Text Text
removeHaskellEnvVars (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env.
HasProcessContext env =>
SimpleGetter env (Map Text Text)
envVarsL ProcessContext
menv0))

    Path Abs File
interpreter <- (WhichCompiler -> [[Char]]) -> RIO env (Path Abs File)
findHelper forall a b. (a -> b) -> a -> b
$
                   \case
                      WhichCompiler
Ghc -> [[Char]
"runghc"]
    Path Abs File
haddock <- (WhichCompiler -> [[Char]]) -> RIO env (Path Abs File)
findHelper forall a b. (a -> b) -> a -> b
$
               \case
                  WhichCompiler
Ghc -> [[Char]
"haddock", [Char]
"haddock-ghc"]
    ByteString
infobs <- forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc (forall b t. Path b t -> [Char]
toFilePath Path Abs File
compiler) [[Char]
"--info"]
            forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> ByteString
toStrictBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_
    Text
infotext <-
      case ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
infobs of
        Left UnicodeException
e -> forall (m :: * -> *) a. (MonadIO m, HasCallStack) => [Char] -> m a
throwString forall a b. (a -> b) -> a -> b
$ [Char]
"GHC info is not valid UTF-8: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show UnicodeException
e
        Right Text
info -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
info
    [([Char], [Char])]
infoPairs :: [(String, String)] <-
      case forall a. Read a => [Char] -> Maybe a
readMaybe forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
infotext of
        Maybe [([Char], [Char])]
Nothing -> forall (m :: * -> *) a. (MonadIO m, HasCallStack) => [Char] -> m a
throwString [Char]
"GHC info does not parse as a list of pairs"
        Just [([Char], [Char])]
infoPairs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [([Char], [Char])]
infoPairs
    let infoMap :: Map [Char] [Char]
infoMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [([Char], [Char])]
infoPairs

    Either SomeException (Path Abs Dir)
eglobaldb <- forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny forall a b. (a -> b) -> a -> b
$
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
"Global Package DB" Map [Char] [Char]
infoMap of
        Maybe [Char]
Nothing -> forall (m :: * -> *) a. (MonadIO m, HasCallStack) => [Char] -> m a
throwString [Char]
"Key 'Global Package DB' not found in GHC info"
        Just [Char]
db -> forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs Dir)
parseAbsDir [Char]
db

    Arch
arch <-
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
"Target platform" Map [Char] [Char]
infoMap of
        Maybe [Char]
Nothing -> forall (m :: * -> *) a. (MonadIO m, HasCallStack) => [Char] -> m a
throwString [Char]
"Key 'Target platform' not found in GHC info"
        Just [Char]
targetPlatform ->
          case forall a. Parsec a => [Char] -> Maybe a
simpleParse forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'-') [Char]
targetPlatform of
            Maybe Arch
Nothing -> forall (m :: * -> *) a. (MonadIO m, HasCallStack) => [Char] -> m a
throwString forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid target platform in GHC info: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
targetPlatform
            Just Arch
arch -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Arch
arch
    ActualCompiler
compilerVer <-
      case WhichCompiler
wc of
        WhichCompiler
Ghc ->
          case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
"Project version" Map [Char] [Char]
infoMap of
            Maybe [Char]
Nothing -> do
              forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Key 'Project version' not found in GHC info"
              forall env.
(HasProcessContext env, HasLogFunc env) =>
WhichCompiler -> Path Abs File -> RIO env ActualCompiler
getCompilerVersion WhichCompiler
wc Path Abs File
compiler
            Just [Char]
versionString' -> Version -> ActualCompiler
ACGhc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => [Char] -> m Version
parseVersionThrowing [Char]
versionString'
    Path Abs Dir
globaldb <-
      case Either SomeException (Path Abs Dir)
eglobaldb of
        Left SomeException
e -> do
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Parsing global DB from GHC info failed"
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Utf8Builder
displayShow SomeException
e
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Asking ghc-pkg directly"
          forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv forall a b. (a -> b) -> a -> b
$ forall env.
(HasProcessContext env, HasLogFunc env) =>
GhcPkgExe -> RIO env (Path Abs Dir)
getGlobalDB GhcPkgExe
pkg
        Right Path Abs Dir
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
x

    Map PackageName DumpedGlobalPackage
globalDump <- forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv forall a b. (a -> b) -> a -> b
$ forall env.
(HasLogFunc env, HasProcessContext env) =>
GhcPkgExe -> RIO env (Map PackageName DumpedGlobalPackage)
globalsFromDump GhcPkgExe
pkg
    Version
cabalPkgVer <-
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
cabalPackageName Map PackageName DumpedGlobalPackage
globalDump of
        Maybe DumpedGlobalPackage
Nothing -> forall (m :: * -> *) a. (MonadIO m, HasCallStack) => [Char] -> m a
throwString forall a b. (a -> b) -> a -> b
$ [Char]
"Cabal library not found in global package database for " forall a. [a] -> [a] -> [a]
++ forall b t. Path b t -> [Char]
toFilePath Path Abs File
compiler
        Just DumpedGlobalPackage
dp -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> Version
pkgVersion forall a b. (a -> b) -> a -> b
$ DumpedGlobalPackage -> PackageIdentifier
dpPackageIdent DumpedGlobalPackage
dp

    forall (m :: * -> *) a. Monad m => a -> m a
return CompilerPaths
      { cpBuild :: CompilerBuild
cpBuild = CompilerBuild
compilerBuild
      , cpArch :: Arch
cpArch = Arch
arch
      , cpSandboxed :: Bool
cpSandboxed = Bool
isSandboxed
      , cpCompilerVersion :: ActualCompiler
cpCompilerVersion = ActualCompiler
compilerVer
      , cpCompiler :: Path Abs File
cpCompiler = Path Abs File
compiler
      , cpPkg :: GhcPkgExe
cpPkg = GhcPkgExe
pkg
      , cpInterpreter :: Path Abs File
cpInterpreter = Path Abs File
interpreter
      , cpHaddock :: Path Abs File
cpHaddock = Path Abs File
haddock
      , cpCabalVersion :: Version
cpCabalVersion = Version
cabalPkgVer
      , cpGlobalDB :: Path Abs Dir
cpGlobalDB = Path Abs Dir
globaldb
      , cpGhcInfo :: ByteString
cpGhcInfo = ByteString
infobs
      , cpGlobalDump :: Map PackageName DumpedGlobalPackage
cpGlobalDump = Map PackageName DumpedGlobalPackage
globalDump
      }
  where
    onErr :: SomeException -> RIO env CompilerPaths
onErr = forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> SomeException -> SetupException
InvalidGhcAt Path Abs File
compiler

    withCache :: RIO env CompilerPaths -> RIO env CompilerPaths
withCache RIO env CompilerPaths
inner = do
      Either SomeException (Maybe CompilerPaths)
eres <- forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny forall a b. (a -> b) -> a -> b
$ forall env.
HasConfig env =>
Path Abs File
-> CompilerBuild -> Bool -> RIO env (Maybe CompilerPaths)
loadCompilerPaths Path Abs File
compiler CompilerBuild
compilerBuild Bool
isSandboxed
      Maybe CompilerPaths
mres <-
        case Either SomeException (Maybe CompilerPaths)
eres of
          Left SomeException
e -> do
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Trouble loading CompilerPaths cache: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow SomeException
e
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
          Right Maybe CompilerPaths
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CompilerPaths
x
      case Maybe CompilerPaths
mres of
        Just CompilerPaths
cp -> CompilerPaths
cp forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Loaded compiler information from cache"
        Maybe CompilerPaths
Nothing -> do
          CompilerPaths
cp <- RIO env CompilerPaths
inner
          forall env. HasConfig env => CompilerPaths -> RIO env ()
saveCompilerPaths CompilerPaths
cp forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
e ->
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder
"Unable to save CompilerPaths cache: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow SomeException
e)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure CompilerPaths
cp

buildGhcFromSource :: forall env.
   ( HasTerm env
   , HasProcessContext env
   , HasBuildConfig env
   ) => Memoized SetupInfo -> [Tool] -> CompilerRepository -> Text -> Text
   -> RIO env (Tool, CompilerBuild)
buildGhcFromSource :: forall env.
(HasTerm env, HasProcessContext env, HasBuildConfig env) =>
Memoized SetupInfo
-> [Tool]
-> CompilerRepository
-> Text
-> Text
-> RIO env (Tool, CompilerBuild)
buildGhcFromSource Memoized SetupInfo
getSetupInfo' [Tool]
installed (CompilerRepository Text
url) Text
commitId Text
flavour = do
   Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
   let compilerTool :: Tool
compilerTool = Text -> Text -> Tool
ToolGhcGit Text
commitId Text
flavour

   -- detect when the correct GHC is already installed

   if Tool
compilerTool forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Tool]
installed
     then forall (m :: * -> *) a. Monad m => a -> m a
return (Tool
compilerTool,CompilerBuild
CompilerBuildStandard)
     else do
       -- clone the repository and execute the given commands

       forall env a.
(HasLogFunc env, HasProcessContext env) =>
SimpleRepo -> RIO env a -> RIO env a
Pantry.withRepo (Text -> Text -> RepoType -> SimpleRepo
Pantry.SimpleRepo Text
url Text
commitId RepoType
RepoGit) forall a b. (a -> b) -> a -> b
$ do
         -- withRepo is guaranteed to set workingDirL, so let's get it

         Maybe (Path Abs Dir)
mcwd <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs Dir)
parseAbsDir forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasProcessContext env => Lens' env (Maybe [Char])
workingDirL
         let cwd :: Path Abs Dir
cwd = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
"Invalid working directory") Maybe (Path Abs Dir)
mcwd

         Int
threads <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> Int
configJobs
         let
           hadrianArgs :: [[Char]]
hadrianArgs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> [Char]
T.unpack
               [ Text
"-c"                    -- run ./boot and ./configure

               , Text
"-j" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Int
threads   -- parallel build

               , Text
"--flavour=" forall a. Semigroup a => a -> a -> a
<> Text
flavour -- selected flavour

               , Text
"binary-dist"
               ]
           hadrianScripts :: [Path Rel File]
hadrianScripts
             | Bool
osIsWindows = [Path Rel File]
hadrianScriptsWindows
             | Bool
otherwise   = [Path Rel File]
hadrianScriptsPosix

         [Path Abs File]
foundHadrianPaths <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist forall a b. (a -> b) -> a -> b
$ (Path Abs Dir
cwd forall b t. Path b Dir -> Path Rel t -> Path b t
</>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Path Rel File]
hadrianScripts
         Path Abs File
hadrianPath <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. (MonadIO m, HasCallStack) => [Char] -> m a
throwString [Char]
"No Hadrian build script found") forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
listToMaybe [Path Abs File]
foundHadrianPaths

         forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logSticky forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Building GHC from source with `"
            forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
RIO.display Text
flavour
            forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"` flavour. It can take a long time (more than one hour)..."

         -- We need to provide an absolute path to the script since

         -- the process package only sets working directory _after_

         -- discovering the executable

         forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc (forall b t. Path b t -> [Char]
toFilePath Path Abs File
hadrianPath) [[Char]]
hadrianArgs forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_

         -- find the bindist and install it

         Path Rel Dir
bindistPath <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel Dir)
parseRelDir [Char]
"_build/bindist"
         ([Path Abs Dir]
_,[Path Abs File]
files) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir (Path Abs Dir
cwd forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
bindistPath)
         let
           isBindist :: Path b File -> m Bool
isBindist Path b File
p = do
             [Char]
extension <- forall (m :: * -> *) b. MonadThrow m => Path b File -> m [Char]
fileExtension (forall b. Path b File -> Path Rel File
filename Path b File
p)

             forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char]
"ghc-" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` (forall b t. Path b t -> [Char]
toFilePath (forall b. Path b File -> Path Rel File
filename Path b File
p))
                         Bool -> Bool -> Bool
&& [Char]
extension forall a. Eq a => a -> a -> Bool
== [Char]
".xz"

         [Path Abs File]
mbindist <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM forall {m :: * -> *} {b}. MonadThrow m => Path b File -> m Bool
isBindist [Path Abs File]
files
         case [Path Abs File]
mbindist of
           [Path Abs File
bindist] -> do
               let bindist' :: Text
bindist' = [Char] -> Text
T.pack (forall b t. Path b t -> [Char]
toFilePath Path Abs File
bindist)
                   dlinfo :: DownloadInfo
dlinfo = DownloadInfo
                             { downloadInfoUrl :: Text
downloadInfoUrl           = Text
bindist'
                               -- we can specify a filepath instead of a URL

                             , downloadInfoContentLength :: Maybe Int
downloadInfoContentLength = forall a. Maybe a
Nothing
                             , downloadInfoSha1 :: Maybe ByteString
downloadInfoSha1          = forall a. Maybe a
Nothing
                             , downloadInfoSha256 :: Maybe ByteString
downloadInfoSha256        = forall a. Maybe a
Nothing
                             }
                   ghcdlinfo :: GHCDownloadInfo
ghcdlinfo = [Text] -> Map Text Text -> DownloadInfo -> GHCDownloadInfo
GHCDownloadInfo forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty DownloadInfo
dlinfo
                   installer :: SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
installer
                      | Bool
osIsWindows = forall env.
HasBuildConfig env =>
SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
installGHCWindows
                      | Bool
otherwise   = forall env.
HasConfig env =>
GHCDownloadInfo
-> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
installGHCPosix GHCDownloadInfo
ghcdlinfo
               SetupInfo
si <- forall (m :: * -> *) a. MonadIO m => Memoized a -> m a
runMemoized Memoized SetupInfo
getSetupInfo'
               Tool
_ <- forall env.
(HasTerm env, HasBuildConfig env) =>
Path Abs Dir
-> DownloadInfo
-> Tool
-> (Path Abs File
    -> ArchiveType -> Path Abs Dir -> Path Abs Dir -> RIO env ())
-> RIO env Tool
downloadAndInstallTool
                 (Config -> Path Abs Dir
configLocalPrograms Config
config)
                 DownloadInfo
dlinfo
                 Tool
compilerTool
                 (SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
installer SetupInfo
si)
               forall (m :: * -> *) a. Monad m => a -> m a
return (Tool
compilerTool, CompilerBuild
CompilerBuildStandard)
           [Path Abs File]
_ -> do
              forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path Abs File]
files (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
" - " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> [Char]
toFilePath)
              forall a. HasCallStack => [Char] -> a
error [Char]
"Can't find hadrian generated bindist"


-- | Determine which GHC builds to use depending on which shared libraries are available

-- on the system.

getGhcBuilds :: HasConfig env => RIO env [CompilerBuild]
getGhcBuilds :: forall env. HasConfig env => RIO env [CompilerBuild]
getGhcBuilds = do

    Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
    case Config -> Maybe CompilerBuild
configGHCBuild Config
config of
        Just CompilerBuild
ghcBuild -> forall (m :: * -> *) a. Monad m => a -> m a
return [CompilerBuild
ghcBuild]
        Maybe CompilerBuild
Nothing -> RIO env [CompilerBuild]
determineGhcBuild
  where
    determineGhcBuild :: RIO env [CompilerBuild]
determineGhcBuild = do
        -- TODO: a more reliable, flexible, and data driven approach would be to actually download small

        -- "test" executables (from setup-info) that link to the same gmp/tinfo versions

        -- that GHC does (i.e. built in same environment as the GHC bindist). The algorithm would go

        -- something like this:

        --

        -- check for previous 'uname -a'/`ldconfig -p` plus compiler version/variant in cache

        -- if cached, then use that as suffix

        -- otherwise:

        --     download setup-info

        --     go through all with right prefix for os/version/variant

        --     first try "standard" (no extra suffix), then the rest

        --         download "compatibility check" exe if not already downloaded

        --         try running it

        --         if successful, then choose that

        --             cache compiler suffix with the uname -a and ldconfig -p output hash plus compiler version

        --

        -- Of course, could also try to make a static GHC bindist instead of all this rigamarole.


        Platform
platform <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL
        case Platform
platform of
            Platform Arch
_ OS
Cabal.Linux -> do
                -- Some systems don't have ldconfig in the PATH, so make sure to look in /sbin and /usr/sbin as well

                let sbinEnv :: Map k a -> Map k a
sbinEnv Map k a
m = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
                      k
"PATH"
                      (a
"/sbin:/usr/sbin" forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe a
"" (a
":" forall a. Semigroup a => a -> a -> a
<>) (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
"PATH" Map k a
m))
                      Map k a
m
                Either SomeException ByteString
eldconfigOut
                  <- forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
(Map Text Text -> Map Text Text) -> m a -> m a
withModifyEnvVars forall {k} {a}.
(Ord k, Semigroup a, IsString k, IsString a) =>
Map k a -> Map k a
sbinEnv
                   forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc [Char]
"ldconfig" [[Char]
"-p"]
                   forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_
                let firstWords :: [Text]
firstWords = case Either SomeException ByteString
eldconfigOut of
                        Right ByteString
ldconfigOut -> forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words) forall a b. (a -> b) -> a -> b
$
                            Text -> [Text]
T.lines forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
T.decodeUtf8With OnDecodeError
T.lenientDecode
                                    forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
ldconfigOut
                        Left SomeException
_ -> []
                    checkLib :: Path Rel File -> RIO env Bool
checkLib Path Rel File
lib
                        | Text
libT forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
firstWords = do
                            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Found shared library " forall a. Semigroup a => a -> a -> a
<> Utf8Builder
libD forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" in 'ldconfig -p' output")
                            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                        | Bool
osIsWindows =
                            -- Cannot parse /usr/lib on Windows

                            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                        | Bool
otherwise = do
                        -- This is a workaround for the fact that libtinfo.so.x doesn't appear in

                        -- the 'ldconfig -p' output on Arch or Slackware even when it exists.

                        -- There doesn't seem to be an easy way to get the true list of directories

                        -- to scan for shared libs, but this works for our particular cases.

                            [Path Abs Dir]
matches <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist forall b c a. (b -> c) -> (a -> b) -> a -> c
.(forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
lib)) [Path Abs Dir]
usrLibDirs
                            case [Path Abs Dir]
matches of
                                [] -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Did not find shared library " forall a. Semigroup a => a -> a -> a
<> Utf8Builder
libD)
                                    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                                (Path Abs Dir
path:[Path Abs Dir]
_) -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Found shared library " forall a. Semigroup a => a -> a -> a
<> Utf8Builder
libD
                                        forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" in " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
Path.toFilePath Path Abs Dir
path))
                                    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                      where
                        libT :: Text
libT = [Char] -> Text
T.pack (forall b t. Path b t -> [Char]
toFilePath Path Rel File
lib)
                        libD :: Utf8Builder
libD = forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Rel File
lib)
                Bool
hastinfo5 <- Path Rel File -> RIO env Bool
checkLib Path Rel File
relFileLibtinfoSo5
                Bool
hastinfo6 <- Path Rel File -> RIO env Bool
checkLib Path Rel File
relFileLibtinfoSo6
                Bool
hasncurses6 <- Path Rel File -> RIO env Bool
checkLib Path Rel File
relFileLibncurseswSo6
                Bool
hasgmp5 <- Path Rel File -> RIO env Bool
checkLib Path Rel File
relFileLibgmpSo10
                Bool
hasgmp4 <- Path Rel File -> RIO env Bool
checkLib Path Rel File
relFileLibgmpSo3
                let libComponents :: [[[Char]]]
libComponents = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                        [ [[[Char]
"tinfo6"] | Bool
hastinfo6 Bool -> Bool -> Bool
&& Bool
hasgmp5]
                        , [[] | Bool
hastinfo5 Bool -> Bool -> Bool
&& Bool
hasgmp5]
                        , [[[Char]
"ncurses6"] | Bool
hasncurses6 Bool -> Bool -> Bool
&& Bool
hasgmp5 ]
                        , [[[Char]
"gmp4"] | Bool
hasgmp4 ]
                        ]
                forall {m :: * -> *} {env}.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
[CompilerBuild] -> m [CompilerBuild]
useBuilds forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map
                    (\[[Char]]
c -> case [[Char]]
c of
                        [] -> CompilerBuild
CompilerBuildStandard
                        [[Char]]
_ -> [Char] -> CompilerBuild
CompilerBuildSpecialized (forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"-" [[Char]]
c))
                    [[[Char]]]
libComponents
            Platform Arch
_ OS
Cabal.FreeBSD -> do
                let getMajorVer :: [Char] -> Maybe Int
getMajorVer = forall a. Read a => [Char] -> Maybe a
readMaybe forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. [a] -> Maybe a
headMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Eq a => [a] -> [a] -> [[a]]
splitOn [Char]
".")
                Maybe Int
majorVer <- [Char] -> Maybe Int
getMajorVer forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env. HasLogFunc env => RIO env [Char]
sysRelease
                if Maybe Int
majorVer forall a. Ord a => a -> a -> Bool
>= forall a. a -> Maybe a
Just (Int
12 :: Int) then
                  forall {m :: * -> *} {env}.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
[CompilerBuild] -> m [CompilerBuild]
useBuilds [[Char] -> CompilerBuild
CompilerBuildSpecialized [Char]
"ino64"]
                else
                  forall {m :: * -> *} {env}.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
[CompilerBuild] -> m [CompilerBuild]
useBuilds [CompilerBuild
CompilerBuildStandard]
            Platform Arch
_ OS
Cabal.OpenBSD -> do
                [Char]
releaseStr <- ShowS
mungeRelease forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env. HasLogFunc env => RIO env [Char]
sysRelease
                forall {m :: * -> *} {env}.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
[CompilerBuild] -> m [CompilerBuild]
useBuilds [[Char] -> CompilerBuild
CompilerBuildSpecialized [Char]
releaseStr]
            Platform
_ -> forall {m :: * -> *} {env}.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
[CompilerBuild] -> m [CompilerBuild]
useBuilds [CompilerBuild
CompilerBuildStandard]
    useBuilds :: [CompilerBuild] -> m [CompilerBuild]
useBuilds [CompilerBuild]
builds = do
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$
          Utf8Builder
"Potential GHC builds: " forall a. Semigroup a => a -> a -> a
<>
          forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
intersperse Utf8Builder
", " (forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerBuild -> [Char]
compilerBuildName) [CompilerBuild]
builds))
        forall (m :: * -> *) a. Monad m => a -> m a
return [CompilerBuild]
builds

-- | Encode an OpenBSD version (like "6.1") into a valid argument for

-- CompilerBuildSpecialized, so "maj6-min1". Later version numbers are prefixed

-- with "r".

-- The result r must be such that "ghc-" ++ r is a valid package name,

-- as recognized by parsePackageNameFromString.

mungeRelease :: String -> String
mungeRelease :: ShowS
mungeRelease = forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"-" forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [[Char]]
prefixMaj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [[a]]
splitOn [Char]
"."
  where
    prefixFst :: [a] -> ([[a]] -> [[a]]) -> [[a]] -> [[a]]
prefixFst [a]
pfx [[a]] -> [[a]]
k ([a]
rev : [[a]]
revs) = ([a]
pfx forall a. [a] -> [a] -> [a]
++ [a]
rev) forall a. a -> [a] -> [a]
: [[a]] -> [[a]]
k [[a]]
revs
    prefixFst [a]
_ [[a]] -> [[a]]
_ [] = []
    prefixMaj :: [[Char]] -> [[Char]]
prefixMaj = forall {a}. [a] -> ([[a]] -> [[a]]) -> [[a]] -> [[a]]
prefixFst [Char]
"maj" [[Char]] -> [[Char]]
prefixMin
    prefixMin :: [[Char]] -> [[Char]]
prefixMin = forall {a}. [a] -> ([[a]] -> [[a]]) -> [[a]] -> [[a]]
prefixFst [Char]
"min" (forall a b. (a -> b) -> [a] -> [b]
map (Char
'r'forall a. a -> [a] -> [a]
:))

sysRelease :: HasLogFunc env => RIO env String
sysRelease :: forall env. HasLogFunc env => RIO env [Char]
sysRelease =
  forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
e -> do
               forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Could not query OS version: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow IOException
e
               forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"")
  (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [Char]
getRelease)

-- | Ensure Docker container-compatible 'stack' executable is downloaded

ensureDockerStackExe :: HasConfig env => Platform -> RIO env (Path Abs File)
ensureDockerStackExe :: forall env. HasConfig env => Platform -> RIO env (Path Abs File)
ensureDockerStackExe Platform
containerPlatform = do
    Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
    Path Rel Dir
containerPlatformDir <- forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall env (m :: * -> *).
(MonadReader env m, HasPlatform env, MonadThrow m) =>
m (Path Rel Dir)
platformOnlyRelDir (Platform
containerPlatform,PlatformVariant
PlatformVariantNone)
    let programsPath :: Path Abs Dir
programsPath = Config -> Path Abs Dir
configLocalProgramsBase Config
config forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
containerPlatformDir
        tool :: Tool
tool = PackageIdentifier -> Tool
Tool (PackageName -> Version -> PackageIdentifier
PackageIdentifier ([Char] -> PackageName
mkPackageName [Char]
"stack") Version
stackVersion)
    Path Abs Dir
stackExeDir <- forall env (m :: * -> *).
(MonadReader env m, MonadThrow m) =>
Path Abs Dir -> Tool -> m (Path Abs Dir)
installDir Path Abs Dir
programsPath Tool
tool
    let stackExePath :: Path Abs File
stackExePath = Path Abs Dir
stackExeDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileStack
    Bool
stackExeExists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
stackExePath
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
stackExeExists forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$
          Utf8Builder
"Downloading Docker-compatible " forall a. Semigroup a => a -> a -> a
<>
          forall a. IsString a => [Char] -> a
fromString [Char]
stackProgName forall a. Semigroup a => a -> a -> a
<>
          Utf8Builder
" executable"
        StackReleaseInfo
sri <- forall env.
(HasPlatform env, HasLogFunc env) =>
Maybe [Char]
-> Maybe [Char] -> Maybe [Char] -> RIO env StackReleaseInfo
downloadStackReleaseInfo forall a. Maybe a
Nothing forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just (Version -> [Char]
versionString Version
stackMinorVersion))
        [(Bool, [Char])]
platforms <- forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall env (m :: * -> *).
(MonadReader env m, HasPlatform env, MonadThrow m) =>
m [(Bool, [Char])]
preferredPlatforms (Platform
containerPlatform, PlatformVariant
PlatformVariantNone)
        forall env.
HasConfig env =>
[(Bool, [Char])]
-> StackReleaseInfo
-> Path Abs Dir
-> Bool
-> (Path Abs File -> IO ())
-> RIO env ()
downloadStackExe [(Bool, [Char])]
platforms StackReleaseInfo
sri Path Abs Dir
stackExeDir Bool
False (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ())
    forall (m :: * -> *) a. Monad m => a -> m a
return Path Abs File
stackExePath

-- | Get all executables on the path that might match the wanted compiler

sourceSystemCompilers
  :: (HasProcessContext env, HasLogFunc env)
  => WantedCompiler
  -> ConduitT i (Path Abs File) (RIO env) ()
sourceSystemCompilers :: forall env i.
(HasProcessContext env, HasLogFunc env) =>
WantedCompiler -> ConduitT i (Path Abs File) (RIO env) ()
sourceSystemCompilers WantedCompiler
wanted = do
  [[Char]]
searchPath <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasProcessContext env => SimpleGetter env [[Char]]
exeSearchPathL
  [[Char]]
names <-
    case WantedCompiler
wanted of
      WCGhc Version
version -> forall (f :: * -> *) a. Applicative f => a -> f a
pure
        [ [Char]
"ghc-" forall a. [a] -> [a] -> [a]
++ Version -> [Char]
versionString Version
version
        , [Char]
"ghc"
        ]
      WCGhcjs{} -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO CompilerException
GhcjsNotSupported
      WCGhcGit{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [] -- only use sandboxed versions

  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [[Char]]
names forall a b. (a -> b) -> a -> b
$ \[Char]
name -> forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [[Char]]
searchPath forall a b. (a -> b) -> a -> b
$ \[Char]
dir -> do
    Path Abs File
fp <- forall (m :: * -> *). MonadIO m => [Char] -> m (Path Abs File)
resolveFile' forall a b. (a -> b) -> a -> b
$ ShowS
addExe forall a b. (a -> b) -> a -> b
$ [Char]
dir [Char] -> ShowS
FP.</> [Char]
name
    Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
fp
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Path Abs File
fp
  where
    addExe :: ShowS
addExe
      | Bool
osIsWindows = (forall a. [a] -> [a] -> [a]
++ [Char]
".exe")
      | Bool
otherwise = forall a. a -> a
id

-- | Download the most recent SetupInfo

getSetupInfo :: HasConfig env => RIO env SetupInfo
getSetupInfo :: forall env. HasConfig env => RIO env SetupInfo
getSetupInfo = do
    Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
    let inlineSetupInfo :: SetupInfo
inlineSetupInfo = Config -> SetupInfo
configSetupInfoInline Config
config
        locations' :: [[Char]]
locations' = Config -> [[Char]]
configSetupInfoLocations Config
config
        locations :: [[Char]]
locations = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
locations' then [[Char]
defaultSetupInfoYaml] else [[Char]]
locations'

    [SetupInfo]
resolvedSetupInfos <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *} {b} {env}.
(MonadIO m, MonadThrow m, FromJSON (WithJSONWarnings b),
 MonadReader env m, HasLogFunc env) =>
[Char] -> m b
loadSetupInfo [[Char]]
locations
    forall (m :: * -> *) a. Monad m => a -> m a
return (SetupInfo
inlineSetupInfo forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat [SetupInfo]
resolvedSetupInfos)
  where
    loadSetupInfo :: [Char] -> m b
loadSetupInfo [Char]
urlOrFile = do
      ByteString
bs <-
          case forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseUrlThrow [Char]
urlOrFile of
              Just Request
req -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (ByteString -> ByteString
LBS.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Response a -> a
getResponseBody) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpLbs Request
req
              Maybe Request
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
S.readFile [Char]
urlOrFile
      WithJSONWarnings b
si [JSONWarning]
warnings <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither' ByteString
bs)
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Char]
urlOrFile forall a. Eq a => a -> a -> Bool
/= [Char]
defaultSetupInfoYaml) forall a b. (a -> b) -> a -> b
$
          forall env (m :: * -> *).
(MonadReader env m, HasLogFunc env, HasCallStack, MonadIO m) =>
[Char] -> [JSONWarning] -> m ()
logJSONWarnings [Char]
urlOrFile [JSONWarning]
warnings
      forall (m :: * -> *) a. Monad m => a -> m a
return b
si

getInstalledTool :: [Tool]            -- ^ already installed

                 -> PackageName       -- ^ package to find

                 -> (Version -> Bool) -- ^ which versions are acceptable

                 -> Maybe Tool
getInstalledTool :: [Tool] -> PackageName -> (Version -> Bool) -> Maybe Tool
getInstalledTool [Tool]
installed PackageName
name Version -> Bool
goodVersion = PackageIdentifier -> Tool
Tool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> Maybe a
maximumByMaybe (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing PackageIdentifier -> Version
pkgVersion) (PackageName -> (Version -> Bool) -> [Tool] -> [PackageIdentifier]
filterTools PackageName
name Version -> Bool
goodVersion [Tool]
installed)

downloadAndInstallTool :: (HasTerm env, HasBuildConfig env)
                       => Path Abs Dir
                       -> DownloadInfo
                       -> Tool
                       -> (Path Abs File -> ArchiveType -> Path Abs Dir -> Path Abs Dir -> RIO env ())
                       -> RIO env Tool
downloadAndInstallTool :: forall env.
(HasTerm env, HasBuildConfig env) =>
Path Abs Dir
-> DownloadInfo
-> Tool
-> (Path Abs File
    -> ArchiveType -> Path Abs Dir -> Path Abs Dir -> RIO env ())
-> RIO env Tool
downloadAndInstallTool Path Abs Dir
programsDir DownloadInfo
downloadInfo Tool
tool Path Abs File
-> ArchiveType -> Path Abs Dir -> Path Abs Dir -> RIO env ()
installer = do
    forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
programsDir
    (Path Abs File
file, ArchiveType
at) <- forall env.
(HasTerm env, HasBuildConfig env) =>
Path Abs Dir
-> DownloadInfo -> Tool -> RIO env (Path Abs File, ArchiveType)
downloadFromInfo Path Abs Dir
programsDir DownloadInfo
downloadInfo Tool
tool
    Path Abs Dir
dir <- forall env (m :: * -> *).
(MonadReader env m, MonadThrow m) =>
Path Abs Dir -> Tool -> m (Path Abs Dir)
installDir Path Abs Dir
programsDir Tool
tool
    Path Abs Dir
tempDir <- forall env (m :: * -> *).
(MonadReader env m, MonadThrow m) =>
Path Abs Dir -> Tool -> m (Path Abs Dir)
tempInstallDir Path Abs Dir
programsDir Tool
tool
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path Abs Dir
tempDir)
    forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
tempDir
    forall (m :: * -> *). MonadIO m => Path Abs Dir -> Tool -> m ()
unmarkInstalled Path Abs Dir
programsDir Tool
tool
    Path Abs File
-> ArchiveType -> Path Abs Dir -> Path Abs Dir -> RIO env ()
installer Path Abs File
file ArchiveType
at Path Abs Dir
tempDir Path Abs Dir
dir
    forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs Dir -> Tool -> m ()
markInstalled Path Abs Dir
programsDir Tool
tool
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path Abs Dir
tempDir)
    forall (m :: * -> *) a. Monad m => a -> m a
return Tool
tool

downloadAndInstallCompiler :: (HasBuildConfig env, HasGHCVariant env)
                           => CompilerBuild
                           -> SetupInfo
                           -> WantedCompiler
                           -> VersionCheck
                           -> Maybe String
                           -> RIO env Tool
downloadAndInstallCompiler :: forall env.
(HasBuildConfig env, HasGHCVariant env) =>
CompilerBuild
-> SetupInfo
-> WantedCompiler
-> VersionCheck
-> Maybe [Char]
-> RIO env Tool
downloadAndInstallCompiler CompilerBuild
ghcBuild SetupInfo
si wanted :: WantedCompiler
wanted@(WCGhc Version
version) VersionCheck
versionCheck Maybe [Char]
mbindistURL = do
    GHCVariant
ghcVariant <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasGHCVariant env => SimpleGetter env GHCVariant
ghcVariantL
    (Version
selectedVersion, GHCDownloadInfo
downloadInfo) <- case Maybe [Char]
mbindistURL of
        Just [Char]
bindistURL -> do
            case GHCVariant
ghcVariant of
                GHCCustom [Char]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                GHCVariant
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SetupException
RequireCustomGHCVariant
            forall (m :: * -> *) a. Monad m => a -> m a
return (Version
version, [Text] -> Map Text Text -> DownloadInfo -> GHCDownloadInfo
GHCDownloadInfo forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty DownloadInfo
                     { downloadInfoUrl :: Text
downloadInfoUrl = [Char] -> Text
T.pack [Char]
bindistURL
                     , downloadInfoContentLength :: Maybe Int
downloadInfoContentLength = forall a. Maybe a
Nothing
                     , downloadInfoSha1 :: Maybe ByteString
downloadInfoSha1 = forall a. Maybe a
Nothing
                     , downloadInfoSha256 :: Maybe ByteString
downloadInfoSha256 = forall a. Maybe a
Nothing
                     })
        Maybe [Char]
_ -> do
            Text
ghcKey <- forall env (m :: * -> *).
(MonadReader env m, HasPlatform env, HasGHCVariant env,
 MonadThrow m) =>
CompilerBuild -> m Text
getGhcKey CompilerBuild
ghcBuild
            case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
ghcKey forall a b. (a -> b) -> a -> b
$ SetupInfo -> Map Text (Map Version GHCDownloadInfo)
siGHCs SetupInfo
si of
                Maybe (Map Version GHCDownloadInfo)
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Text -> SetupException
UnknownOSKey Text
ghcKey
                Just Map Version GHCDownloadInfo
pairs_ -> forall k (m :: * -> *) a.
(Ord k, MonadThrow m) =>
Text
-> VersionCheck
-> WantedCompiler
-> (k -> ActualCompiler)
-> Map k a
-> m (k, a)
getWantedCompilerInfo Text
ghcKey VersionCheck
versionCheck WantedCompiler
wanted Version -> ActualCompiler
ACGhc Map Version GHCDownloadInfo
pairs_
    Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
    let installer :: SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
installer =
            case Config -> Platform
configPlatform Config
config of
                Platform Arch
_ OS
Cabal.Windows -> forall env.
HasBuildConfig env =>
SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
installGHCWindows
                Platform
_ -> forall env.
HasConfig env =>
GHCDownloadInfo
-> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
installGHCPosix GHCDownloadInfo
downloadInfo
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$
        Utf8Builder
"Preparing to install GHC" forall a. Semigroup a => a -> a -> a
<>
        (case GHCVariant
ghcVariant of
            GHCVariant
GHCStandard -> Utf8Builder
""
            GHCVariant
v -> Utf8Builder
" (" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (GHCVariant -> [Char]
ghcVariantName GHCVariant
v) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")") forall a. Semigroup a => a -> a -> a
<>
        (case CompilerBuild
ghcBuild of
            CompilerBuild
CompilerBuildStandard -> Utf8Builder
""
            CompilerBuild
b -> Utf8Builder
" (" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (CompilerBuild -> [Char]
compilerBuildName CompilerBuild
b) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")") forall a. Semigroup a => a -> a -> a
<>
        Utf8Builder
" to an isolated location."
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"This will not interfere with any system-level installation."
    PackageName
ghcPkgName <- forall (m :: * -> *). MonadThrow m => [Char] -> m PackageName
parsePackageNameThrowing ([Char]
"ghc" forall a. [a] -> [a] -> [a]
++ GHCVariant -> [Char]
ghcVariantSuffix GHCVariant
ghcVariant forall a. [a] -> [a] -> [a]
++ CompilerBuild -> [Char]
compilerBuildSuffix CompilerBuild
ghcBuild)
    let tool :: Tool
tool = PackageIdentifier -> Tool
Tool forall a b. (a -> b) -> a -> b
$ PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
ghcPkgName Version
selectedVersion
    forall env.
(HasTerm env, HasBuildConfig env) =>
Path Abs Dir
-> DownloadInfo
-> Tool
-> (Path Abs File
    -> ArchiveType -> Path Abs Dir -> Path Abs Dir -> RIO env ())
-> RIO env Tool
downloadAndInstallTool (Config -> Path Abs Dir
configLocalPrograms Config
config) (GHCDownloadInfo -> DownloadInfo
gdiDownloadInfo GHCDownloadInfo
downloadInfo) Tool
tool (SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
installer SetupInfo
si)

downloadAndInstallCompiler CompilerBuild
_ SetupInfo
_ WCGhcjs{} VersionCheck
_ Maybe [Char]
_ = forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO CompilerException
GhcjsNotSupported

downloadAndInstallCompiler CompilerBuild
_ SetupInfo
_ WCGhcGit{} VersionCheck
_ Maybe [Char]
_ =
    forall a. HasCallStack => [Char] -> a
error [Char]
"downloadAndInstallCompiler: shouldn't be reached with ghc-git"

getWantedCompilerInfo :: (Ord k, MonadThrow m)
                      => Text
                      -> VersionCheck
                      -> WantedCompiler
                      -> (k -> ActualCompiler)
                      -> Map k a
                      -> m (k, a)
getWantedCompilerInfo :: forall k (m :: * -> *) a.
(Ord k, MonadThrow m) =>
Text
-> VersionCheck
-> WantedCompiler
-> (k -> ActualCompiler)
-> Map k a
-> m (k, a)
getWantedCompilerInfo Text
key VersionCheck
versionCheck WantedCompiler
wanted k -> ActualCompiler
toCV Map k a
pairs_ =
    case Maybe (k, a)
mpair of
        Just (k, a)
pair -> forall (m :: * -> *) a. Monad m => a -> m a
return (k, a)
pair
        Maybe (k, a)
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Set Text -> WantedCompiler -> Set ActualCompiler -> SetupException
UnknownCompilerVersion (forall a. a -> Set a
Set.singleton Text
key) WantedCompiler
wanted (forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map k -> ActualCompiler
toCV (forall k a. Map k a -> [k]
Map.keys Map k a
pairs_))
  where
    mpair :: Maybe (k, a)
mpair =
        forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$
        forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> a
fst)) forall a b. (a -> b) -> a -> b
$
        forall a. (a -> Bool) -> [a] -> [a]
filter (VersionCheck -> WantedCompiler -> ActualCompiler -> Bool
isWantedCompiler VersionCheck
versionCheck WantedCompiler
wanted forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> ActualCompiler
toCV forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (forall k a. Map k a -> [(k, a)]
Map.toList Map k a
pairs_)

-- | Download and install the first available compiler build.

downloadAndInstallPossibleCompilers
    :: (HasGHCVariant env, HasBuildConfig env)
    => [CompilerBuild]
    -> SetupInfo
    -> WantedCompiler
    -> VersionCheck
    -> Maybe String
    -> RIO env (Tool, CompilerBuild)
downloadAndInstallPossibleCompilers :: forall env.
(HasGHCVariant env, HasBuildConfig env) =>
[CompilerBuild]
-> SetupInfo
-> WantedCompiler
-> VersionCheck
-> Maybe [Char]
-> RIO env (Tool, CompilerBuild)
downloadAndInstallPossibleCompilers [CompilerBuild]
possibleCompilers SetupInfo
si WantedCompiler
wanted VersionCheck
versionCheck Maybe [Char]
mbindistURL =
    [CompilerBuild]
-> Maybe SetupException -> RIO env (Tool, CompilerBuild)
go [CompilerBuild]
possibleCompilers forall a. Maybe a
Nothing
  where
    -- This will stop as soon as one of the builds doesn't throw an @UnknownOSKey@ or

    -- @UnknownCompilerVersion@ exception (so it will only try subsequent builds if one is nonexistent,

    -- not if the download or install fails for some other reason).

    -- The @Unknown*@ exceptions thrown by each attempt are combined into a single exception

    -- (if only @UnknownOSKey@ is thrown, then the first of those is rethrown, but if any

    -- @UnknownCompilerVersion@s are thrown then the attempted OS keys and available versions

    -- are unioned).

    go :: [CompilerBuild]
-> Maybe SetupException -> RIO env (Tool, CompilerBuild)
go [] Maybe SetupException
Nothing = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SetupException
UnsupportedSetupConfiguration
    go [] (Just SetupException
e) = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SetupException
e
    go (CompilerBuild
b:[CompilerBuild]
bs) Maybe SetupException
e = do
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Trying to setup GHC build: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (CompilerBuild -> [Char]
compilerBuildName CompilerBuild
b)
        Either SetupException Tool
er <- forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ forall env.
(HasBuildConfig env, HasGHCVariant env) =>
CompilerBuild
-> SetupInfo
-> WantedCompiler
-> VersionCheck
-> Maybe [Char]
-> RIO env Tool
downloadAndInstallCompiler CompilerBuild
b SetupInfo
si WantedCompiler
wanted VersionCheck
versionCheck Maybe [Char]
mbindistURL
        case Either SetupException Tool
er of
            Left e' :: SetupException
e'@(UnknownCompilerVersion Set Text
ks' WantedCompiler
w' Set ActualCompiler
vs') ->
                case Maybe SetupException
e of
                    Maybe SetupException
Nothing -> [CompilerBuild]
-> Maybe SetupException -> RIO env (Tool, CompilerBuild)
go [CompilerBuild]
bs (forall a. a -> Maybe a
Just SetupException
e')
                    Just (UnknownOSKey Text
k) ->
                        [CompilerBuild]
-> Maybe SetupException -> RIO env (Tool, CompilerBuild)
go [CompilerBuild]
bs forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Set Text -> WantedCompiler -> Set ActualCompiler -> SetupException
UnknownCompilerVersion (forall a. Ord a => a -> Set a -> Set a
Set.insert Text
k Set Text
ks') WantedCompiler
w' Set ActualCompiler
vs'
                    Just (UnknownCompilerVersion Set Text
ks WantedCompiler
_ Set ActualCompiler
vs) ->
                        [CompilerBuild]
-> Maybe SetupException -> RIO env (Tool, CompilerBuild)
go [CompilerBuild]
bs forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Set Text -> WantedCompiler -> Set ActualCompiler -> SetupException
UnknownCompilerVersion (forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Text
ks' Set Text
ks) WantedCompiler
w' (forall a. Ord a => Set a -> Set a -> Set a
Set.union Set ActualCompiler
vs' Set ActualCompiler
vs)
                    Just SetupException
x -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SetupException
x
            Left e' :: SetupException
e'@(UnknownOSKey Text
k') ->
                case Maybe SetupException
e of
                    Maybe SetupException
Nothing -> [CompilerBuild]
-> Maybe SetupException -> RIO env (Tool, CompilerBuild)
go [CompilerBuild]
bs (forall a. a -> Maybe a
Just SetupException
e')
                    Just (UnknownOSKey Text
_) -> [CompilerBuild]
-> Maybe SetupException -> RIO env (Tool, CompilerBuild)
go [CompilerBuild]
bs Maybe SetupException
e
                    Just (UnknownCompilerVersion Set Text
ks WantedCompiler
w Set ActualCompiler
vs) ->
                        [CompilerBuild]
-> Maybe SetupException -> RIO env (Tool, CompilerBuild)
go [CompilerBuild]
bs forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Set Text -> WantedCompiler -> Set ActualCompiler -> SetupException
UnknownCompilerVersion (forall a. Ord a => a -> Set a -> Set a
Set.insert Text
k' Set Text
ks) WantedCompiler
w Set ActualCompiler
vs
                    Just SetupException
x -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SetupException
x
            Left SetupException
e' -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SetupException
e'
            Right Tool
r -> forall (m :: * -> *) a. Monad m => a -> m a
return (Tool
r, CompilerBuild
b)

getGhcKey :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m)
          => CompilerBuild -> m Text
getGhcKey :: forall env (m :: * -> *).
(MonadReader env m, HasPlatform env, HasGHCVariant env,
 MonadThrow m) =>
CompilerBuild -> m Text
getGhcKey CompilerBuild
ghcBuild = do
    GHCVariant
ghcVariant <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasGHCVariant env => SimpleGetter env GHCVariant
ghcVariantL
    Platform
platform <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL
    Text
osKey <- forall (m :: * -> *). MonadThrow m => Platform -> m Text
getOSKey Platform
platform
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
osKey forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (GHCVariant -> [Char]
ghcVariantSuffix GHCVariant
ghcVariant) forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (CompilerBuild -> [Char]
compilerBuildSuffix CompilerBuild
ghcBuild)

getOSKey :: (MonadThrow m)
         => Platform -> m Text
getOSKey :: forall (m :: * -> *). MonadThrow m => Platform -> m Text
getOSKey Platform
platform =
    case Platform
platform of
        Platform Arch
I386                  OS
Cabal.Linux   -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"linux32"
        Platform Arch
X86_64                OS
Cabal.Linux   -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"linux64"
        Platform Arch
I386                  OS
Cabal.OSX     -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"macosx"
        Platform Arch
X86_64                OS
Cabal.OSX     -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"macosx"
        Platform Arch
I386                  OS
Cabal.FreeBSD -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"freebsd32"
        Platform Arch
X86_64                OS
Cabal.FreeBSD -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"freebsd64"
        Platform Arch
I386                  OS
Cabal.OpenBSD -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"openbsd32"
        Platform Arch
X86_64                OS
Cabal.OpenBSD -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"openbsd64"
        Platform Arch
I386                  OS
Cabal.Windows -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"windows32"
        Platform Arch
X86_64                OS
Cabal.Windows -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"windows64"
        Platform Arch
Arm                   OS
Cabal.Linux   -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"linux-armv7"
        Platform Arch
AArch64               OS
Cabal.Linux   -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"linux-aarch64"
        Platform Arch
Sparc                 OS
Cabal.Linux   -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"linux-sparc"
        Platform Arch
AArch64               OS
Cabal.OSX     -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"macosx-aarch64"
        Platform Arch
AArch64               OS
Cabal.FreeBSD -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"freebsd-aarch64"
        Platform Arch
arch OS
os -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ OS -> Arch -> SetupException
UnsupportedSetupCombo OS
os Arch
arch

downloadOrUseLocal
    :: (HasTerm env, HasBuildConfig env)
    => Text -> DownloadInfo -> Path Abs File -> RIO env (Path Abs File)
downloadOrUseLocal :: forall env.
(HasTerm env, HasBuildConfig env) =>
Text -> DownloadInfo -> Path Abs File -> RIO env (Path Abs File)
downloadOrUseLocal Text
downloadLabel DownloadInfo
downloadInfo Path Abs File
destination =
  case [Char]
url of
    (forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseUrlThrow -> Just Request
_) -> do
        forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (forall b t. Path b t -> Path b Dir
parent Path Abs File
destination)
        forall env.
HasTerm env =>
Text -> DownloadInfo -> Path Abs File -> RIO env ()
chattyDownload Text
downloadLabel DownloadInfo
downloadInfo Path Abs File
destination
        forall (m :: * -> *) a. Monad m => a -> m a
return Path Abs File
destination
    (forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs File)
parseAbsFile -> Just Path Abs File
path) -> do
        RIO env ()
warnOnIgnoredChecks
        forall (m :: * -> *) a. Monad m => a -> m a
return Path Abs File
path
    (forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile -> Just Path Rel File
path) -> do
        RIO env ()
warnOnIgnoredChecks
        Path Abs Dir
root <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env r. HasBuildConfig env => Getting r env (Path Abs Dir)
projectRootL
        forall (m :: * -> *) a. Monad m => a -> m a
return (Path Abs Dir
root forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
path)
    [Char]
_ ->
        forall (m :: * -> *) a. (MonadIO m, HasCallStack) => [Char] -> m a
throwString forall a b. (a -> b) -> a -> b
$ [Char]
"Error: `url` must be either an HTTP URL or a file path: " forall a. [a] -> [a] -> [a]
++ [Char]
url
  where
    url :: [Char]
url = Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ DownloadInfo -> Text
downloadInfoUrl DownloadInfo
downloadInfo
    warnOnIgnoredChecks :: RIO env ()
warnOnIgnoredChecks = do
      let DownloadInfo{downloadInfoContentLength :: DownloadInfo -> Maybe Int
downloadInfoContentLength=Maybe Int
contentLength, downloadInfoSha1 :: DownloadInfo -> Maybe ByteString
downloadInfoSha1=Maybe ByteString
sha1,
                       downloadInfoSha256 :: DownloadInfo -> Maybe ByteString
downloadInfoSha256=Maybe ByteString
sha256} = DownloadInfo
downloadInfo
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe Int
contentLength) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"`content-length` is not checked and should not be specified when `url` is a file path"
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe ByteString
sha1) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"`sha1` is not checked and should not be specified when `url` is a file path"
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe ByteString
sha256) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"`sha256` is not checked and should not be specified when `url` is a file path"

downloadFromInfo
    :: (HasTerm env, HasBuildConfig env)
    => Path Abs Dir -> DownloadInfo -> Tool -> RIO env (Path Abs File, ArchiveType)
downloadFromInfo :: forall env.
(HasTerm env, HasBuildConfig env) =>
Path Abs Dir
-> DownloadInfo -> Tool -> RIO env (Path Abs File, ArchiveType)
downloadFromInfo Path Abs Dir
programsDir DownloadInfo
downloadInfo Tool
tool = do
    ArchiveType
archiveType <-
        case [Char]
extension of
            [Char]
".tar.xz" -> forall (m :: * -> *) a. Monad m => a -> m a
return ArchiveType
TarXz
            [Char]
".tar.bz2" -> forall (m :: * -> *) a. Monad m => a -> m a
return ArchiveType
TarBz2
            [Char]
".tar.gz" -> forall (m :: * -> *) a. Monad m => a -> m a
return ArchiveType
TarGz
            [Char]
".7z.exe" -> forall (m :: * -> *) a. Monad m => a -> m a
return ArchiveType
SevenZ
            [Char]
_ -> forall (m :: * -> *) a. (MonadIO m, HasCallStack) => [Char] -> m a
throwString forall a b. (a -> b) -> a -> b
$ [Char]
"Error: Unknown extension for url: " forall a. [a] -> [a] -> [a]
++ [Char]
url

    Path Rel File
relativeFile <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile forall a b. (a -> b) -> a -> b
$ Tool -> [Char]
toolString Tool
tool forall a. [a] -> [a] -> [a]
++ [Char]
extension
    let destinationPath :: Path Abs File
destinationPath = Path Abs Dir
programsDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relativeFile
    Path Abs File
localPath <- forall env.
(HasTerm env, HasBuildConfig env) =>
Text -> DownloadInfo -> Path Abs File -> RIO env (Path Abs File)
downloadOrUseLocal ([Char] -> Text
T.pack (Tool -> [Char]
toolString Tool
tool)) DownloadInfo
downloadInfo Path Abs File
destinationPath
    forall (m :: * -> *) a. Monad m => a -> m a
return (Path Abs File
localPath, ArchiveType
archiveType)

  where
    url :: [Char]
url = Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ DownloadInfo -> Text
downloadInfoUrl DownloadInfo
downloadInfo
    extension :: [Char]
extension = ShowS
loop [Char]
url
      where
        loop :: ShowS
loop [Char]
fp
            | [Char]
ext forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
".tar", [Char]
".bz2", [Char]
".xz", [Char]
".exe", [Char]
".7z", [Char]
".gz"] = ShowS
loop [Char]
fp' forall a. [a] -> [a] -> [a]
++ [Char]
ext
            | Bool
otherwise = [Char]
""
          where
            ([Char]
fp', [Char]
ext) = [Char] -> ([Char], [Char])
FP.splitExtension [Char]
fp


data ArchiveType
    = TarBz2
    | TarXz
    | TarGz
    | SevenZ

installGHCPosix :: HasConfig env
                => GHCDownloadInfo
                -> SetupInfo
                -> Path Abs File
                -> ArchiveType
                -> Path Abs Dir
                -> Path Abs Dir
                -> RIO env ()
installGHCPosix :: forall env.
HasConfig env =>
GHCDownloadInfo
-> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
installGHCPosix GHCDownloadInfo
downloadInfo SetupInfo
_ Path Abs File
archiveFile ArchiveType
archiveType Path Abs Dir
tempDir Path Abs Dir
destDir = do
    Platform
platform <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL
    ProcessContext
menv0 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasProcessContext env => Lens' env ProcessContext
processContextL
    ProcessContext
menv <- forall (m :: * -> *).
MonadIO m =>
Map Text Text -> m ProcessContext
mkProcessContext (Map Text Text -> Map Text Text
removeHaskellEnvVars (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env.
HasProcessContext env =>
SimpleGetter env (Map Text Text)
envVarsL ProcessContext
menv0))
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"menv = " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env.
HasProcessContext env =>
SimpleGetter env (Map Text Text)
envVarsL ProcessContext
menv)
    ([Char]
zipTool', Char
compOpt) <-
        case ArchiveType
archiveType of
            ArchiveType
TarXz -> forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
"xz", Char
'J')
            ArchiveType
TarBz2 -> forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
"bzip2", Char
'j')
            ArchiveType
TarGz -> forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
"gzip", Char
'z')
            ArchiveType
SevenZ -> forall (m :: * -> *) a. (MonadIO m, HasCallStack) => [Char] -> m a
throwString [Char]
"Don't know how to deal with .7z files on non-Windows"
    -- Slight hack: OpenBSD's tar doesn't support xz.

    -- https://github.com/commercialhaskell/stack/issues/2283#issuecomment-237980986

    let tarDep :: CheckDependency env [Char]
tarDep =
          case (Platform
platform, ArchiveType
archiveType) of
            (Platform Arch
_ OS
Cabal.OpenBSD, ArchiveType
TarXz) -> forall env.
HasProcessContext env =>
[Char] -> CheckDependency env [Char]
checkDependency [Char]
"gtar"
            (Platform, ArchiveType)
_ -> forall env.
HasProcessContext env =>
[Char] -> CheckDependency env [Char]
checkDependency [Char]
"tar"
    ([Char]
zipTool, [Char]
makeTool, [Char]
tarTool) <- forall env a. CheckDependency env a -> RIO env a
checkDependencies forall a b. (a -> b) -> a -> b
$ (,,)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env.
HasProcessContext env =>
[Char] -> CheckDependency env [Char]
checkDependency [Char]
zipTool'
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall env.
HasProcessContext env =>
[Char] -> CheckDependency env [Char]
checkDependency [Char]
"gmake" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall env.
HasProcessContext env =>
[Char] -> CheckDependency env [Char]
checkDependency [Char]
"make")
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CheckDependency env [Char]
tarDep

    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"ziptool: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
zipTool
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"make: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
makeTool
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"tar: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
tarTool

    let runStep :: StyleDoc
-> Path Abs Dir
-> Map Text Text
-> [Char]
-> [[Char]]
-> RIO env ()
runStep StyleDoc
step Path Abs Dir
wd Map Text Text
env [Char]
cmd [[Char]]
args = do
          ProcessContext
menv' <- forall (m :: * -> *).
MonadIO m =>
ProcessContext
-> (Map Text Text -> Map Text Text) -> m ProcessContext
modifyEnvVars ProcessContext
menv (forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Text Text
env)
          let logLines :: (Utf8Builder -> m ()) -> ConduitT ByteString c m ()
logLines Utf8Builder -> m ()
lvl = forall (m :: * -> *).
Monad m =>
ConduitT ByteString ByteString m ()
CB.lines forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ (Utf8Builder -> m ()
lvl forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Utf8Builder
displayBytesUtf8)
              logStdout :: ConduitT ByteString c (RIO env) ()
logStdout = forall {m :: * -> *} {c}.
Monad m =>
(Utf8Builder -> m ()) -> ConduitT ByteString c m ()
logLines forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug
              logStderr :: ConduitT ByteString c (RIO env) ()
logStderr = forall {m :: * -> *} {c}.
Monad m =>
(Utf8Builder -> m ()) -> ConduitT ByteString c m ()
logLines forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError
          forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
[Char] -> m a -> m a
withWorkingDir (forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
wd) forall a b. (a -> b) -> a -> b
$
                forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv' forall a b. (a -> b) -> a -> b
$
                forall e o env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
[Char]
-> [[Char]]
-> ConduitM ByteString Void (RIO env) e
-> ConduitM ByteString Void (RIO env) o
-> RIO env (e, o)
sinkProcessStderrStdout [Char]
cmd [[Char]]
args forall {c}. ConduitT ByteString c (RIO env) ()
logStderr forall {c}. ConduitT ByteString c (RIO env) ()
logStdout
                forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
ex -> do
                  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Utf8Builder
displayShow SomeException
ex
                  forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError forall a b. (a -> b) -> a -> b
$ Int -> StyleDoc -> StyleDoc
hang Int
2 (
                      StyleDoc
"Error encountered while" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
step StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
"GHC with"
                      forall a. Semigroup a => a -> a -> a
<> StyleDoc
line forall a. Semigroup a => a -> a -> a
<>
                      Style -> StyleDoc -> StyleDoc
style Style
Shell (forall a. IsString a => [Char] -> a
fromString ([[Char]] -> [Char]
unwords ([Char]
cmd forall a. a -> [a] -> [a]
: [[Char]]
args)))
                      forall a. Semigroup a => a -> a -> a
<> StyleDoc
line forall a. Semigroup a => a -> a -> a
<>
                      -- TODO: Figure out how to insert \ in the appropriate spots

                      -- hang 2 (shellColor (fillSep (fromString cmd : map fromString args))) <> line <>

                      StyleDoc
"run in " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
wd
                      )
                    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line forall a. Semigroup a => a -> a -> a
<> StyleDoc
line forall a. Semigroup a => a -> a -> a
<>
                    StyleDoc
"The following directories may now contain files, but won't be used by stack:"
                    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line forall a. Semigroup a => a -> a -> a
<>
                    StyleDoc
"  -" StyleDoc -> StyleDoc -> StyleDoc
<+> forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
tempDir
                    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line forall a. Semigroup a => a -> a -> a
<>
                    StyleDoc
"  -" StyleDoc -> StyleDoc -> StyleDoc
<+> forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
destDir
                    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line forall a. Semigroup a => a -> a -> a
<> StyleDoc
line forall a. Semigroup a => a -> a -> a
<>
                    StyleDoc
"For more information consider rerunning with --verbose flag"
                    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
                  forall (m :: * -> *) a. MonadIO m => m a
exitFailure

    forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logSticky forall a b. (a -> b) -> a -> b
$
      Utf8Builder
"Unpacking GHC into " forall a. Semigroup a => a -> a -> a
<>
      forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
tempDir) forall a. Semigroup a => a -> a -> a
<>
      Utf8Builder
" ..."
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Unpacking " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs File
archiveFile)
    StyleDoc
-> Path Abs Dir
-> Map Text Text
-> [Char]
-> [[Char]]
-> RIO env ()
runStep StyleDoc
"unpacking" Path Abs Dir
tempDir forall a. Monoid a => a
mempty [Char]
tarTool [Char
compOpt forall a. a -> [a] -> [a]
: [Char]
"xf", forall b t. Path b t -> [Char]
toFilePath Path Abs File
archiveFile]

    Path Abs Dir
dir <- forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs File -> Path Abs Dir -> m (Path Abs Dir)
expectSingleUnpackedDir Path Abs File
archiveFile Path Abs Dir
tempDir

    Maybe (Path Abs File)
mOverrideGccPath <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> Maybe (Path Abs File)
configOverrideGccPath

    -- The make application uses the CC environment variable to configure the

    -- program for compiling C programs

    let mGccEnv :: Maybe (Map Text Text)
mGccEnv = let gccEnvFromPath :: Path b t -> Map k Text
gccEnvFromPath Path b t
p =
                        forall k a. k -> a -> Map k a
Map.singleton k
"CC" forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack (forall b t. Path b t -> [Char]
toFilePath Path b t
p)
                  in  forall {k} {b} {t}. IsString k => Path b t -> Map k Text
gccEnvFromPath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Path Abs File)
mOverrideGccPath

    -- Data.Map.union provides a left-biased union, so mGccEnv will prevail

    let ghcConfigureEnv :: Map Text Text
ghcConfigureEnv =
          forall a. a -> Maybe a -> a
fromMaybe forall k a. Map k a
Map.empty Maybe (Map Text Text)
mGccEnv forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` GHCDownloadInfo -> Map Text Text
gdiConfigureEnv GHCDownloadInfo
downloadInfo

    forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logSticky Utf8Builder
"Configuring GHC ..."
    StyleDoc
-> Path Abs Dir
-> Map Text Text
-> [Char]
-> [[Char]]
-> RIO env ()
runStep StyleDoc
"configuring" Path Abs Dir
dir
        Map Text Text
ghcConfigureEnv
        (forall b t. Path b t -> [Char]
toFilePath forall a b. (a -> b) -> a -> b
$ Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileConfigure)
        (([Char]
"--prefix=" forall a. [a] -> [a] -> [a]
++ forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
destDir) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
T.unpack (GHCDownloadInfo -> [Text]
gdiConfigureOpts GHCDownloadInfo
downloadInfo))

    forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logSticky Utf8Builder
"Installing GHC ..."
    StyleDoc
-> Path Abs Dir
-> Map Text Text
-> [Char]
-> [[Char]]
-> RIO env ()
runStep StyleDoc
"installing" Path Abs Dir
dir forall a. Monoid a => a
mempty [Char]
makeTool [[Char]
"install"]

    forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Installed GHC."
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"GHC installed to " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
destDir)

-- | Check if given processes appear to be present, throwing an exception if

-- missing.

checkDependencies :: CheckDependency env a -> RIO env a
checkDependencies :: forall env a. CheckDependency env a -> RIO env a
checkDependencies (CheckDependency RIO env (Either [[Char]] a)
f) = RIO env (Either [[Char]] a)
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> SetupException
MissingDependencies) forall (m :: * -> *) a. Monad m => a -> m a
return

checkDependency :: HasProcessContext env => String -> CheckDependency env String
checkDependency :: forall env.
HasProcessContext env =>
[Char] -> CheckDependency env [Char]
checkDependency [Char]
tool = forall env a. RIO env (Either [[Char]] a) -> CheckDependency env a
CheckDependency forall a b. (a -> b) -> a -> b
$ do
    Bool
exists <- forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
[Char] -> m Bool
doesExecutableExist [Char]
tool
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
exists then forall a b. b -> Either a b
Right [Char]
tool else forall a b. a -> Either a b
Left [[Char]
tool]

newtype CheckDependency env a = CheckDependency (RIO env (Either [String] a))
    deriving forall a b. a -> CheckDependency env b -> CheckDependency env a
forall a b.
(a -> b) -> CheckDependency env a -> CheckDependency env b
forall env a b. a -> CheckDependency env b -> CheckDependency env a
forall env a b.
(a -> b) -> CheckDependency env a -> CheckDependency env b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> CheckDependency env b -> CheckDependency env a
$c<$ :: forall env a b. a -> CheckDependency env b -> CheckDependency env a
fmap :: forall a b.
(a -> b) -> CheckDependency env a -> CheckDependency env b
$cfmap :: forall env a b.
(a -> b) -> CheckDependency env a -> CheckDependency env b
Functor
instance Applicative (CheckDependency env) where
    pure :: forall a. a -> CheckDependency env a
pure a
x = forall env a. RIO env (Either [[Char]] a) -> CheckDependency env a
CheckDependency forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right a
x)
    CheckDependency RIO env (Either [[Char]] (a -> b))
f <*> :: forall a b.
CheckDependency env (a -> b)
-> CheckDependency env a -> CheckDependency env b
<*> CheckDependency RIO env (Either [[Char]] a)
x = forall env a. RIO env (Either [[Char]] a) -> CheckDependency env a
CheckDependency forall a b. (a -> b) -> a -> b
$ do
        Either [[Char]] (a -> b)
f' <- RIO env (Either [[Char]] (a -> b))
f
        Either [[Char]] a
x' <- RIO env (Either [[Char]] a)
x
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
            case (Either [[Char]] (a -> b)
f', Either [[Char]] a
x') of
                (Left [[Char]]
e1, Left [[Char]]
e2) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [[Char]]
e1 forall a. [a] -> [a] -> [a]
++ [[Char]]
e2
                (Left [[Char]]
e, Right a
_) -> forall a b. a -> Either a b
Left [[Char]]
e
                (Right a -> b
_, Left [[Char]]
e) -> forall a b. a -> Either a b
Left [[Char]]
e
                (Right a -> b
f'', Right a
x'') -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ a -> b
f'' a
x''
instance Alternative (CheckDependency env) where
    empty :: forall a. CheckDependency env a
empty = forall env a. RIO env (Either [[Char]] a) -> CheckDependency env a
CheckDependency forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left []
    CheckDependency RIO env (Either [[Char]] a)
x <|> :: forall a.
CheckDependency env a
-> CheckDependency env a -> CheckDependency env a
<|> CheckDependency RIO env (Either [[Char]] a)
y = forall env a. RIO env (Either [[Char]] a) -> CheckDependency env a
CheckDependency forall a b. (a -> b) -> a -> b
$ do
        Either [[Char]] a
res1 <- RIO env (Either [[Char]] a)
x
        case Either [[Char]] a
res1 of
            Left [[Char]]
_ -> RIO env (Either [[Char]] a)
y
            Right a
x' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right a
x'

installGHCWindows :: HasBuildConfig env
                  => SetupInfo
                  -> Path Abs File
                  -> ArchiveType
                  -> Path Abs Dir
                  -> Path Abs Dir
                  -> RIO env ()
installGHCWindows :: forall env.
HasBuildConfig env =>
SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
installGHCWindows SetupInfo
si Path Abs File
archiveFile ArchiveType
archiveType Path Abs Dir
_tempDir Path Abs Dir
destDir = do
    forall env.
HasBuildConfig env =>
[Char]
-> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> RIO env ()
withUnpackedTarball7z [Char]
"GHC" SetupInfo
si Path Abs File
archiveFile ArchiveType
archiveType Path Abs Dir
destDir
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"GHC installed to " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
destDir)

installMsys2Windows :: HasBuildConfig env
                  => SetupInfo
                  -> Path Abs File
                  -> ArchiveType
                  -> Path Abs Dir
                  -> Path Abs Dir
                  -> RIO env ()
installMsys2Windows :: forall env.
HasBuildConfig env =>
SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
installMsys2Windows SetupInfo
si Path Abs File
archiveFile ArchiveType
archiveType Path Abs Dir
_tempDir Path Abs Dir
destDir = do
    Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
D.doesDirectoryExist forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
destDir
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ()
D.removeDirectoryRecursive forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
destDir) forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (IOException -> m a) -> m a
`catchIO` \IOException
e -> do
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$
            Utf8Builder
"Could not delete existing msys directory: " forall a. Semigroup a => a -> a -> a
<>
            forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
destDir)
        forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM IOException
e

    forall env.
HasBuildConfig env =>
[Char]
-> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> RIO env ()
withUnpackedTarball7z [Char]
"MSYS2" SetupInfo
si Path Abs File
archiveFile ArchiveType
archiveType Path Abs Dir
destDir


    -- I couldn't find this officially documented anywhere, but you need to run

    -- the MSYS shell once in order to initialize some pacman stuff. Once that

    -- run happens, you can just run commands as usual.

    ProcessContext
menv0 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasProcessContext env => Lens' env ProcessContext
processContextL
    ProcessContext
newEnv0 <- forall (m :: * -> *).
MonadIO m =>
ProcessContext
-> (Map Text Text -> Map Text Text) -> m ProcessContext
modifyEnvVars ProcessContext
menv0 forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"MSYSTEM" Text
"MSYS"
    Map Text Text
newEnv <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [[Char]]
-> Map Text Text -> Either ProcessException (Map Text Text)
augmentPathMap
                  [forall b t. Path b t -> [Char]
toFilePath forall a b. (a -> b) -> a -> b
$ Path Abs Dir
destDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirUsr forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirBin]
                  (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env.
HasProcessContext env =>
SimpleGetter env (Map Text Text)
envVarsL ProcessContext
newEnv0)
    ProcessContext
menv <- forall (m :: * -> *).
MonadIO m =>
Map Text Text -> m ProcessContext
mkProcessContext Map Text Text
newEnv
    forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
[Char] -> m a -> m a
withWorkingDir (forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
destDir) forall a b. (a -> b) -> a -> b
$ forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv
      forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc [Char]
"sh" [[Char]
"--login", [Char]
"-c", [Char]
"true"] forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_

    -- No longer installing git, it's unreliable

    -- (https://github.com/commercialhaskell/stack/issues/1046) and the

    -- MSYS2-installed version has bad CRLF defaults.

    --

    -- Install git. We could install other useful things in the future too.

    -- runCmd (Cmd (Just destDir) "pacman" menv ["-Sy", "--noconfirm", "git"]) Nothing


-- | Unpack a compressed tarball using 7zip.  Expects a single directory in

-- the unpacked results, which is renamed to the destination directory.

withUnpackedTarball7z :: HasBuildConfig env
                      => String -- ^ Name of tool, used in error messages

                      -> SetupInfo
                      -> Path Abs File -- ^ Path to archive file

                      -> ArchiveType
                      -> Path Abs Dir -- ^ Destination directory.

                      -> RIO env ()
withUnpackedTarball7z :: forall env.
HasBuildConfig env =>
[Char]
-> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> RIO env ()
withUnpackedTarball7z [Char]
name SetupInfo
si Path Abs File
archiveFile ArchiveType
archiveType Path Abs Dir
destDir = do
    Text
suffix <-
        case ArchiveType
archiveType of
            ArchiveType
TarXz -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
".xz"
            ArchiveType
TarBz2 -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
".bz2"
            ArchiveType
TarGz -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
".gz"
            ArchiveType
_ -> forall (m :: * -> *) a. (MonadIO m, HasCallStack) => [Char] -> m a
throwString forall a b. (a -> b) -> a -> b
$ [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
" must be a tarball file"
    Path Rel File
tarFile <-
        case Text -> Text -> Maybe Text
T.stripSuffix Text
suffix forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> [Char]
toFilePath (forall b. Path b File -> Path Rel File
filename Path Abs File
archiveFile) of
            Maybe Text
Nothing -> forall (m :: * -> *) a. (MonadIO m, HasCallStack) => [Char] -> m a
throwString forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid " forall a. [a] -> [a] -> [a]
++ [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
" filename: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Path Abs File
archiveFile
            Just Text
x -> forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
x
    Path Abs Dir -> Path Abs File -> RIO env ()
run7z <- forall env (m :: * -> *).
(HasBuildConfig env, MonadIO m) =>
SetupInfo -> RIO env (Path Abs Dir -> Path Abs File -> m ())
setup7z SetupInfo
si
    let tmpName :: [Char]
tmpName = forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep (forall b. Path b Dir -> Path Rel Dir
dirname Path Abs Dir
destDir) forall a. [a] -> [a] -> [a]
++ [Char]
"-tmp"
    forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (forall b t. Path b t -> Path b Dir
parent Path Abs Dir
destDir)
    forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. RIO env a -> IO a
run -> forall (m :: * -> *) b a.
(MonadIO m, MonadMask m) =>
Path b Dir -> [Char] -> (Path Abs Dir -> m a) -> m a
withTempDir (forall b t. Path b t -> Path b Dir
parent Path Abs Dir
destDir) [Char]
tmpName forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
tmpDir -> forall a. RIO env a -> IO a
run forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path Abs Dir
destDir)
        Path Abs Dir -> Path Abs File -> RIO env ()
run7z Path Abs Dir
tmpDir Path Abs File
archiveFile
        Path Abs Dir -> Path Abs File -> RIO env ()
run7z Path Abs Dir
tmpDir (Path Abs Dir
tmpDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
tarFile)
        Path Abs Dir
absSrcDir <- forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs File -> Path Abs Dir -> m (Path Abs Dir)
expectSingleUnpackedDir Path Abs File
archiveFile Path Abs Dir
tmpDir
        forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 Dir -> Path b1 Dir -> m ()
renameDir Path Abs Dir
absSrcDir Path Abs Dir
destDir

expectSingleUnpackedDir :: (MonadIO m, MonadThrow m) => Path Abs File -> Path Abs Dir -> m (Path Abs Dir)
expectSingleUnpackedDir :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs File -> Path Abs Dir -> m (Path Abs Dir)
expectSingleUnpackedDir Path Abs File
archiveFile Path Abs Dir
destDir = do
    ([Path Abs Dir], [Path Abs File])
contents <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
destDir
    case ([Path Abs Dir], [Path Abs File])
contents of
        ([Path Abs Dir
dir], [Path Abs File]
_ ) -> forall (m :: * -> *) a. Monad m => a -> m a
return Path Abs Dir
dir
        ([Path Abs Dir], [Path Abs File])
_ -> forall (m :: * -> *) a. (MonadIO m, HasCallStack) => [Char] -> m a
throwString forall a b. (a -> b) -> a -> b
$ [Char]
"Expected a single directory within unpacked " forall a. [a] -> [a] -> [a]
++ forall b t. Path b t -> [Char]
toFilePath Path Abs File
archiveFile

-- | Download 7z as necessary, and get a function for unpacking things.

--

-- Returned function takes an unpack directory and archive.

setup7z :: (HasBuildConfig env, MonadIO m)
        => SetupInfo
        -> RIO env (Path Abs Dir -> Path Abs File -> m ())
setup7z :: forall env (m :: * -> *).
(HasBuildConfig env, MonadIO m) =>
SetupInfo -> RIO env (Path Abs Dir -> Path Abs File -> m ())
setup7z SetupInfo
si = do
    Path Abs Dir
dir <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> Path Abs Dir
configLocalPrograms
    forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
dir
    let exeDestination :: Path Abs File
exeDestination = Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFile7zexe
        dllDestination :: Path Abs File
dllDestination = Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFile7zdll
    case (SetupInfo -> Maybe DownloadInfo
siSevenzDll SetupInfo
si, SetupInfo -> Maybe DownloadInfo
siSevenzExe SetupInfo
si) of
        (Just DownloadInfo
sevenzDll, Just DownloadInfo
sevenzExe) -> do
            Path Abs File
_ <- forall env.
(HasTerm env, HasBuildConfig env) =>
Text -> DownloadInfo -> Path Abs File -> RIO env (Path Abs File)
downloadOrUseLocal Text
"7z.dll" DownloadInfo
sevenzDll Path Abs File
dllDestination
            Path Abs File
exePath <- forall env.
(HasTerm env, HasBuildConfig env) =>
Text -> DownloadInfo -> Path Abs File -> RIO env (Path Abs File)
downloadOrUseLocal Text
"7z.exe" DownloadInfo
sevenzExe Path Abs File
exeDestination
            forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. RIO env a -> IO a
run -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
outdir Path Abs File
archive -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. RIO env a -> IO a
run forall a b. (a -> b) -> a -> b
$ do
                let cmd :: [Char]
cmd = forall b t. Path b t -> [Char]
toFilePath Path Abs File
exePath
                    args :: [[Char]]
args =
                        [ [Char]
"x"
                        , [Char]
"-o" forall a. [a] -> [a] -> [a]
++ forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
outdir
                        , [Char]
"-y"
                        , forall b t. Path b t -> [Char]
toFilePath Path Abs File
archive
                        ]
                let archiveDisplay :: Utf8Builder
archiveDisplay = forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ ShowS
FP.takeFileName forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> [Char]
toFilePath Path Abs File
archive
                    isExtract :: Bool
isExtract = ShowS
FP.takeExtension (forall b t. Path b t -> [Char]
toFilePath Path Abs File
archive) forall a. Eq a => a -> a -> Bool
== [Char]
".tar"
                forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$
                  (if Bool
isExtract then Utf8Builder
"Extracting " else Utf8Builder
"Decompressing ") forall a. Semigroup a => a -> a -> a
<>
                  Utf8Builder
archiveDisplay forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"..."
                ExitCode
ec <-
                  forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc [Char]
cmd [[Char]]
args forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
pc ->
                  if Bool
isExtract
                    then forall (m :: * -> *) stdin stdout stderr a.
MonadUnliftIO m =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
withProcessWait (forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout forall (m :: * -> *) i.
MonadIO m =>
StreamSpec 'STOutput (ConduitM i ByteString m ())
createSource ProcessConfig () () ()
pc) forall a b. (a -> b) -> a -> b
$ \Process () (ConduitM () ByteString (RIO env) ()) ()
p -> do
                        Int
total <- forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit
                            forall a b. (a -> b) -> a -> b
$ forall stdin stdout stderr. Process stdin stdout stderr -> stdout
getStdout Process () (ConduitM () ByteString (RIO env) ()) ()
p
                           forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall seq (m :: * -> *).
(IsSequence seq, Monad m) =>
(Element seq -> Bool) -> ConduitT seq seq m ()
filterCE (forall a. Eq a => a -> a -> Bool
== Word8
10) -- newline characters

                           forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a b o.
Monad m =>
(a -> b -> m a) -> a -> ConduitT b o m a
foldMC
                                (\Int
count ByteString
bs -> do
                                    let count' :: Int
count' = Int
count forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
bs
                                    forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logSticky forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Extracted " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
RIO.display Int
count' forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" files"
                                    forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
count'
                                )
                                Int
0
                        forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone forall a b. (a -> b) -> a -> b
$
                          Utf8Builder
"Extracted total of " forall a. Semigroup a => a -> a -> a
<>
                          forall a. Display a => a -> Utf8Builder
RIO.display Int
total forall a. Semigroup a => a -> a -> a
<>
                          Utf8Builder
" files from " forall a. Semigroup a => a -> a -> a
<>
                          Utf8Builder
archiveDisplay
                        forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
Process stdin stdout stderr -> m ExitCode
waitExitCode Process () (ConduitM () ByteString (RIO env) ()) ()
p
                    else forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ExitCode
runProcess ProcessConfig () () ()
pc
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
ec forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess)
                    forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Path Abs File -> SetupException
ProblemWhileDecompressing Path Abs File
archive)
        (Maybe DownloadInfo, Maybe DownloadInfo)
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SetupException
SetupInfoMissingSevenz

chattyDownload :: HasTerm env
               => Text          -- ^ label

               -> DownloadInfo  -- ^ URL, content-length, sha1, and sha256

               -> Path Abs File -- ^ destination

               -> RIO env ()
chattyDownload :: forall env.
HasTerm env =>
Text -> DownloadInfo -> Path Abs File -> RIO env ()
chattyDownload Text
label DownloadInfo
downloadInfo Path Abs File
path = do
    let url :: Text
url = DownloadInfo -> Text
downloadInfoUrl DownloadInfo
downloadInfo
    Request
req <- forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseUrlThrow forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
url
    forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logSticky forall a b. (a -> b) -> a -> b
$
      Utf8Builder
"Preparing to download " forall a. Semigroup a => a -> a -> a
<>
      forall a. Display a => a -> Utf8Builder
RIO.display Text
label forall a. Semigroup a => a -> a -> a
<>
      Utf8Builder
" ..."
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$
      Utf8Builder
"Downloading from " forall a. Semigroup a => a -> a -> a
<>
      forall a. Display a => a -> Utf8Builder
RIO.display Text
url forall a. Semigroup a => a -> a -> a
<>
      Utf8Builder
" to " forall a. Semigroup a => a -> a -> a
<>
      forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs File
path) forall a. Semigroup a => a -> a -> a
<>
      Utf8Builder
" ..."
    [HashCheck]
hashChecks <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM
      [ (Utf8Builder
"sha1",   forall a.
(Show a, HashAlgorithm a) =>
a -> CheckHexDigest -> HashCheck
HashCheck SHA1
SHA1,   DownloadInfo -> Maybe ByteString
downloadInfoSha1)
      , (Utf8Builder
"sha256", forall a.
(Show a, HashAlgorithm a) =>
a -> CheckHexDigest -> HashCheck
HashCheck SHA256
SHA256, DownloadInfo -> Maybe ByteString
downloadInfoSha256)
      ]
      forall a b. (a -> b) -> a -> b
$ \(Utf8Builder
name, CheckHexDigest -> HashCheck
constr, DownloadInfo -> Maybe ByteString
getter) ->
        case DownloadInfo -> Maybe ByteString
getter DownloadInfo
downloadInfo of
          Just ByteString
bs -> do
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$
                Utf8Builder
"Will check against " forall a. Semigroup a => a -> a -> a
<>
                Utf8Builder
name forall a. Semigroup a => a -> a -> a
<>
                Utf8Builder
" hash: " forall a. Semigroup a => a -> a -> a
<>
                ByteString -> Utf8Builder
displayBytesUtf8 ByteString
bs
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ CheckHexDigest -> HashCheck
constr forall a b. (a -> b) -> a -> b
$ ByteString -> CheckHexDigest
CheckHexDigestByteString ByteString
bs
          Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HashCheck]
hashChecks) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
        Utf8Builder
"No sha1 or sha256 found in metadata," forall a. Semigroup a => a -> a -> a
<>
        Utf8Builder
" download hash won't be checked."
    let dReq :: DownloadRequest
dReq = [HashCheck] -> DownloadRequest -> DownloadRequest
setHashChecks [HashCheck]
hashChecks forall a b. (a -> b) -> a -> b
$
               Maybe Int -> DownloadRequest -> DownloadRequest
setLengthCheck Maybe Int
mtotalSize forall a b. (a -> b) -> a -> b
$
               Request -> DownloadRequest
mkDownloadRequest Request
req
    Bool
x <- forall env.
HasTerm env =>
DownloadRequest
-> Path Abs File -> Text -> Maybe Int -> RIO env Bool
verifiedDownloadWithProgress DownloadRequest
dReq Path Abs File
path Text
label Maybe Int
mtotalSize
    if Bool
x
        then forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone (Utf8Builder
"Downloaded " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
RIO.display Text
label forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".")
        else forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone Utf8Builder
"Already downloaded."
  where
    mtotalSize :: Maybe Int
mtotalSize = DownloadInfo -> Maybe Int
downloadInfoContentLength DownloadInfo
downloadInfo

-- | Perform a basic sanity check of GHC

sanityCheck :: (HasProcessContext env, HasLogFunc env)
            => Path Abs File -> RIO env ()
sanityCheck :: forall env.
(HasProcessContext env, HasLogFunc env) =>
Path Abs File -> RIO env ()
sanityCheck Path Abs File
ghc = forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> (Path Abs Dir -> m a) -> m a
withSystemTempDir [Char]
"stack-sanity-check" forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir -> do
    let fp :: [Char]
fp = forall b t. Path b t -> [Char]
toFilePath forall a b. (a -> b) -> a -> b
$ Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileMainHs
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> IO ()
S.writeFile [Char]
fp forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines
        [ [Char]
"import Distribution.Simple" -- ensure Cabal library is present

        , [Char]
"main = putStrLn \"Hello World\""
        ]
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Performing a sanity check on: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs File
ghc)
    Either SomeException (ByteString, ByteString)
eres <- forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
[Char] -> m a -> m a
withWorkingDir (forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
dir) forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc (forall b t. Path b t -> [Char]
toFilePath Path Abs File
ghc)
        [ [Char]
fp
        , [Char]
"-no-user-package-db"
        ] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_
    case Either SomeException (ByteString, ByteString)
eres of
        Left SomeException
e -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ SomeException -> Path Abs File -> SetupException
GHCSanityCheckCompileFailed SomeException
e Path Abs File
ghc
        Right (ByteString, ByteString)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return () -- TODO check that the output of running the command is correct


-- Remove potentially confusing environment variables

removeHaskellEnvVars :: Map Text Text -> Map Text Text
removeHaskellEnvVars :: Map Text Text -> Map Text Text
removeHaskellEnvVars =
    forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"GHC_PACKAGE_PATH" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"GHC_ENVIRONMENT" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"HASKELL_PACKAGE_SANDBOX" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"HASKELL_PACKAGE_SANDBOXES" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"HASKELL_DIST_DIR" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    -- https://github.com/commercialhaskell/stack/issues/1460

    forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"DESTDIR" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    -- https://github.com/commercialhaskell/stack/issues/3444

    forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"GHCRTS"

-- | Get map of environment variables to set to change the GHC's encoding to UTF-8

getUtf8EnvVars
    :: (HasProcessContext env, HasPlatform env, HasLogFunc env)
    => ActualCompiler
    -> RIO env (Map Text Text)
getUtf8EnvVars :: forall env.
(HasProcessContext env, HasPlatform env, HasLogFunc env) =>
ActualCompiler -> RIO env (Map Text Text)
getUtf8EnvVars ActualCompiler
compilerVer =
    if ActualCompiler -> Version
getGhcVersion ActualCompiler
compilerVer forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
7, Int
10, Int
3]
        -- GHC_CHARENC supported by GHC >=7.10.3

        then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton Text
"GHC_CHARENC" Text
"UTF-8"
        else RIO env (Map Text Text)
legacyLocale
  where
    legacyLocale :: RIO env (Map Text Text)
legacyLocale = do
        ProcessContext
menv <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasProcessContext env => Lens' env ProcessContext
processContextL
        Platform Arch
_ OS
os <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL
        if OS
os forall a. Eq a => a -> a -> Bool
== OS
Cabal.Windows
            then
                 -- On Windows, locale is controlled by the code page, so we don't set any environment

                 -- variables.

                 forall (m :: * -> *) a. Monad m => a -> m a
return
                     forall k a. Map k a
Map.empty
            else do
                let checkedVars :: [([Text], Set Text)]
checkedVars = forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> ([Text], Set Text)
checkVar (forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env.
HasProcessContext env =>
SimpleGetter env (Map Text Text)
envVarsL ProcessContext
menv)
                    -- List of environment variables that will need to be updated to set UTF-8 (because

                    -- they currently do not specify UTF-8).

                    needChangeVars :: [Text]
needChangeVars = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> a
fst [([Text], Set Text)]
checkedVars
                    -- Set of locale-related environment variables that have already have a value.

                    existingVarNames :: Set Text
existingVarNames = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [([Text], Set Text)]
checkedVars)
                    -- True if a locale is already specified by one of the "global" locale variables.

                    hasAnyExisting :: Bool
hasAnyExisting =
                        forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
existingVarNames) [Text
"LANG", Text
"LANGUAGE", Text
"LC_ALL"]
                if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
needChangeVars Bool -> Bool -> Bool
&& Bool
hasAnyExisting
                    then
                         -- If no variables need changes and at least one "global" variable is set, no

                         -- changes to environment need to be made.

                         forall (m :: * -> *) a. Monad m => a -> m a
return
                             forall k a. Map k a
Map.empty
                    else do
                        -- Get a list of known locales by running @locale -a@.

                        Either SomeException ByteString
elocales <- forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc [Char]
"locale" [[Char]
"-a"] forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_
                        let
                            -- Filter the list to only include locales with UTF-8 encoding.

                            utf8Locales :: [Text]
utf8Locales =
                                case Either SomeException ByteString
elocales of
                                    Left SomeException
_ -> []
                                    Right ByteString
locales ->
                                        forall a. (a -> Bool) -> [a] -> [a]
filter
                                            Text -> Bool
isUtf8Locale
                                            (Text -> [Text]
T.lines forall a b. (a -> b) -> a -> b
$
                                             OnDecodeError -> ByteString -> Text
T.decodeUtf8With
                                                 OnDecodeError
T.lenientDecode forall a b. (a -> b) -> a -> b
$
                                                 ByteString -> ByteString
LBS.toStrict ByteString
locales)
                            mfallback :: Maybe Text
mfallback = [Text] -> Maybe Text
getFallbackLocale [Text]
utf8Locales
                        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
                            (forall a. Maybe a -> Bool
isNothing Maybe Text
mfallback)
                            (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
                                 Utf8Builder
"Warning: unable to set locale to UTF-8 encoding; GHC may fail with 'invalid character'")
                        let
                            -- Get the new values of variables to adjust.

                            changes :: Map Text Text
changes =
                                forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions forall a b. (a -> b) -> a -> b
$
                                forall a b. (a -> b) -> [a] -> [b]
map
                                    (ProcessContext -> [Text] -> Maybe Text -> Text -> Map Text Text
adjustedVarValue ProcessContext
menv [Text]
utf8Locales Maybe Text
mfallback)
                                    [Text]
needChangeVars
                            -- Get the values of variables to add.

                            adds :: Map Text Text
adds
                              | Bool
hasAnyExisting =
                                  -- If we already have a "global" variable, then nothing needs

                                  -- to be added.

                                  forall k a. Map k a
Map.empty
                              | Bool
otherwise =
                                  -- If we don't already have a "global" variable, then set LANG to the

                                  -- fallback.

                                  case Maybe Text
mfallback of
                                      Maybe Text
Nothing -> forall k a. Map k a
Map.empty
                                      Just Text
fallback ->
                                          forall k a. k -> a -> Map k a
Map.singleton Text
"LANG" Text
fallback
                        forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Text Text
changes Map Text Text
adds)
    -- Determines whether an environment variable is locale-related and, if so, whether it needs to

    -- be adjusted.

    checkVar
        :: (Text, Text) -> ([Text], Set Text)
    checkVar :: (Text, Text) -> ([Text], Set Text)
checkVar (Text
k,Text
v) =
        if Text
k forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"LANG", Text
"LANGUAGE"] Bool -> Bool -> Bool
|| Text
"LC_" Text -> Text -> Bool
`T.isPrefixOf` Text
k
            then if Text -> Bool
isUtf8Locale Text
v
                     then ([], forall a. a -> Set a
Set.singleton Text
k)
                     else ([Text
k], forall a. a -> Set a
Set.singleton Text
k)
            else ([], forall a. Set a
Set.empty)
    -- Adjusted value of an existing locale variable.  Looks for valid UTF-8 encodings with

    -- same language /and/ territory, then with same language, and finally the first UTF-8 locale

    -- returned by @locale -a@.

    adjustedVarValue
        :: ProcessContext -> [Text] -> Maybe Text -> Text -> Map Text Text
    adjustedVarValue :: ProcessContext -> [Text] -> Maybe Text -> Text -> Map Text Text
adjustedVarValue ProcessContext
menv [Text]
utf8Locales Maybe Text
mfallback Text
k =
        case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
k (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env.
HasProcessContext env =>
SimpleGetter env (Map Text Text)
envVarsL ProcessContext
menv) of
            Maybe Text
Nothing -> forall k a. Map k a
Map.empty
            Just Text
v ->
                case forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
                         ([Text] -> Text -> [Text]
matchingLocales [Text]
utf8Locales)
                         [ (Char -> Bool) -> Text -> Text
T.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'.') Text
v forall a. Semigroup a => a -> a -> a
<> Text
"."
                         , (Char -> Bool) -> Text -> Text
T.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'_') Text
v forall a. Semigroup a => a -> a -> a
<> Text
"_"] of
                    (Text
v':[Text]
_) -> forall k a. k -> a -> Map k a
Map.singleton Text
k Text
v'
                    [] ->
                        case Maybe Text
mfallback of
                            Just Text
fallback -> forall k a. k -> a -> Map k a
Map.singleton Text
k Text
fallback
                            Maybe Text
Nothing -> forall k a. Map k a
Map.empty
    -- Determine the fallback locale, by looking for any UTF-8 locale prefixed with the list in

    -- @fallbackPrefixes@, and if not found, picking the first UTF-8 encoding returned by @locale

    -- -a@.

    getFallbackLocale
        :: [Text] -> Maybe Text
    getFallbackLocale :: [Text] -> Maybe Text
getFallbackLocale [Text]
utf8Locales =
        case forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Text] -> Text -> [Text]
matchingLocales [Text]
utf8Locales) [Text]
fallbackPrefixes of
            (Text
v:[Text]
_) -> forall a. a -> Maybe a
Just Text
v
            [] ->
                case [Text]
utf8Locales of
                    [] -> forall a. Maybe a
Nothing
                    (Text
v:[Text]
_) -> forall a. a -> Maybe a
Just Text
v
    -- Filter the list of locales for any with the given prefixes (case-insensitive).

    matchingLocales
        :: [Text] -> Text -> [Text]
    matchingLocales :: [Text] -> Text -> [Text]
matchingLocales [Text]
utf8Locales Text
prefix =
        forall a. (a -> Bool) -> [a] -> [a]
filter (\Text
v -> Text -> Text
T.toLower Text
prefix Text -> Text -> Bool
`T.isPrefixOf` Text -> Text
T.toLower Text
v) [Text]
utf8Locales
    -- Does the locale have one of the encodings in @utf8Suffixes@ (case-insensitive)?

    isUtf8Locale :: Text -> Bool
isUtf8Locale Text
locale =
      forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ Text
v -> Text -> Text
T.toLower Text
v Text -> Text -> Bool
`T.isSuffixOf` Text -> Text
T.toLower Text
locale) [Text]
utf8Suffixes
    -- Prefixes of fallback locales (case-insensitive)

    fallbackPrefixes :: [Text]
fallbackPrefixes = [Text
"C.", Text
"en_US.", Text
"en_"]
    -- Suffixes of UTF-8 locales (case-insensitive)

    utf8Suffixes :: [Text]
utf8Suffixes = [Text
".UTF-8", Text
".utf8"]

-- Binary Stack upgrades


-- | Information on a binary release of Stack

data StackReleaseInfo
  = SRIGitHub !Value
  -- ^ Metadata downloaded from GitHub releases about available binaries.

  | SRIHaskellStackOrg !HaskellStackOrg
  -- ^ Information on the latest available binary for the current platforms.


data HaskellStackOrg = HaskellStackOrg
  { HaskellStackOrg -> Text
hsoUrl :: !Text
  , HaskellStackOrg -> Version
hsoVersion :: !Version
  }
  deriving Int -> HaskellStackOrg -> ShowS
[HaskellStackOrg] -> ShowS
HaskellStackOrg -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [HaskellStackOrg] -> ShowS
$cshowList :: [HaskellStackOrg] -> ShowS
show :: HaskellStackOrg -> [Char]
$cshow :: HaskellStackOrg -> [Char]
showsPrec :: Int -> HaskellStackOrg -> ShowS
$cshowsPrec :: Int -> HaskellStackOrg -> ShowS
Show

downloadStackReleaseInfo
  :: (HasPlatform env, HasLogFunc env)
  => Maybe String -- GitHub org

  -> Maybe String -- GitHub repo

  -> Maybe String -- ^ optional version

  -> RIO env StackReleaseInfo
downloadStackReleaseInfo :: forall env.
(HasPlatform env, HasLogFunc env) =>
Maybe [Char]
-> Maybe [Char] -> Maybe [Char] -> RIO env StackReleaseInfo
downloadStackReleaseInfo Maybe [Char]
Nothing Maybe [Char]
Nothing Maybe [Char]
Nothing = do
    Platform
platform <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL
    -- Fallback list of URLs to try for upgrading.

    let urls0 :: [Text]
urls0 =
          case Platform
platform of
            Platform Arch
X86_64 OS
Cabal.Linux ->
              [ Text
"https://get.haskellstack.org/upgrade/linux-x86_64-static.tar.gz"
              , Text
"https://get.haskellstack.org/upgrade/linux-x86_64.tar.gz"
              ]
            Platform Arch
X86_64 OS
Cabal.OSX ->
              [ Text
"https://get.haskellstack.org/upgrade/osx-x86_64.tar.gz"
              ]
            Platform Arch
X86_64 OS
Cabal.Windows ->
              [ Text
"https://get.haskellstack.org/upgrade/windows-x86_64.tar.gz"
              ]
            Platform
_ -> []
        -- Helper function: extract the version from a GitHub releases URL.

    let extractVersion :: Text -> Either [Char] Version
extractVersion Text
loc = do
          [Char]
version0 <-
            case forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> [[a]]
splitOn [Char]
"/" forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
loc of
              [Char]
_final:[Char]
version0:[[Char]]
_ -> forall a b. b -> Either a b
Right [Char]
version0
              [[Char]]
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char]
"Insufficient pieces in location: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Text
loc
          [Char]
version1 <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left [Char]
"no leading v on version") forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
"v" [Char]
version0
          forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid version: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
version1) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe Version
parseVersion [Char]
version1

        -- Try out different URLs. If we've exhausted all of them, fall back to GitHub.

        loop :: [Text] -> m StackReleaseInfo
loop [] = do
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Could not get binary from haskellstack.org, trying GitHub"
          forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Maybe [Char] -> Maybe [Char] -> Maybe [Char] -> m StackReleaseInfo
downloadStackReleaseInfoGitHub forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing

        -- Try the next URL

        loop (Text
url:[Text]
urls) = do
          -- Make a HEAD request without any redirects

          Request
req <- ByteString -> Request -> Request
setRequestMethod ByteString
"HEAD" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseRequest (Text -> [Char]
T.unpack Text
url)
          Response ByteString
res <- forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpLbs Request
req { redirectCount :: Int
redirectCount = Int
0 }

          -- Look for a redirect. We're looking for a standard GitHub releases

          -- URL where we can extract version information from.

          case forall a. HeaderName -> Response a -> [ByteString]
getResponseHeader HeaderName
"location" Response ByteString
res of
            [] -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"No location header found, continuing" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Text] -> m StackReleaseInfo
loop [Text]
urls
            -- Exactly one location header.

            [ByteString
locBS] ->
              case ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
locBS of
                Left UnicodeException
e -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Invalid UTF8: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow (ByteString
locBS, UnicodeException
e)) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Text] -> m StackReleaseInfo
loop [Text]
urls
                Right Text
loc ->
                  case Text -> Either [Char] Version
extractVersion Text
loc of
                    Left [Char]
s -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"No version found: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow (Text
url, Text
loc, [Char]
s)) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Text] -> m StackReleaseInfo
loop (Text
locforall a. a -> [a] -> [a]
:[Text]
urls)
                    -- We found a valid URL, let's use it!

                    Right Version
version -> do
                      let hso :: HaskellStackOrg
hso = HaskellStackOrg
                                  { hsoUrl :: Text
hsoUrl = Text
loc
                                  , hsoVersion :: Version
hsoVersion = Version
version
                                  }
                      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Downloading from haskellstack.org: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow HaskellStackOrg
hso
                      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ HaskellStackOrg -> StackReleaseInfo
SRIHaskellStackOrg HaskellStackOrg
hso
            [ByteString]
locs -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Multiple location headers found: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow [ByteString]
locs) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Text] -> m StackReleaseInfo
loop [Text]
urls
    forall {env} {m :: * -> *}.
(MonadReader env m, MonadThrow m, MonadIO m, HasLogFunc env) =>
[Text] -> m StackReleaseInfo
loop [Text]
urls0
downloadStackReleaseInfo Maybe [Char]
morg Maybe [Char]
mrepo Maybe [Char]
mver = forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Maybe [Char] -> Maybe [Char] -> Maybe [Char] -> m StackReleaseInfo
downloadStackReleaseInfoGitHub Maybe [Char]
morg Maybe [Char]
mrepo Maybe [Char]
mver

-- | Same as above, but always uses GitHub

downloadStackReleaseInfoGitHub
  :: (MonadIO m, MonadThrow m)
  => Maybe String -- GitHub org

  -> Maybe String -- GitHub repo

  -> Maybe String -- ^ optional version

  -> m StackReleaseInfo
downloadStackReleaseInfoGitHub :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Maybe [Char] -> Maybe [Char] -> Maybe [Char] -> m StackReleaseInfo
downloadStackReleaseInfoGitHub Maybe [Char]
morg Maybe [Char]
mrepo Maybe [Char]
mver = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    let org :: [Char]
org = forall a. a -> Maybe a -> a
fromMaybe [Char]
"commercialhaskell" Maybe [Char]
morg
        repo :: [Char]
repo = forall a. a -> Maybe a -> a
fromMaybe [Char]
"stack" Maybe [Char]
mrepo
    let url :: [Char]
url = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [Char]
"https://api.github.com/repos/"
            , [Char]
org
            , [Char]
"/"
            , [Char]
repo
            , [Char]
"/releases/"
            , case Maybe [Char]
mver of
                Maybe [Char]
Nothing -> [Char]
"latest"
                Just [Char]
ver -> [Char]
"tags/v" forall a. [a] -> [a] -> [a]
++ [Char]
ver
            ]
    Request
req <- forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseRequest [Char]
url
    Response Value
res <- forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON forall a b. (a -> b) -> a -> b
$ Request -> Request
setGitHubHeaders Request
req
    let code :: Int
code = forall a. Response a -> Int
getResponseStatusCode Response Value
res
    if Int
code forall a. Ord a => a -> a -> Bool
>= Int
200 Bool -> Bool -> Bool
&& Int
code forall a. Ord a => a -> a -> Bool
< Int
300
        then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> StackReleaseInfo
SRIGitHub forall a b. (a -> b) -> a -> b
$ forall a. Response a -> a
getResponseBody Response Value
res
        else forall (m :: * -> *) a. (MonadIO m, HasCallStack) => [Char] -> m a
throwString forall a b. (a -> b) -> a -> b
$ [Char]
"Could not get release information for Stack from: " forall a. [a] -> [a] -> [a]
++ [Char]
url

preferredPlatforms :: (MonadReader env m, HasPlatform env, MonadThrow m)
                   => m [(Bool, String)]
preferredPlatforms :: forall env (m :: * -> *).
(MonadReader env m, HasPlatform env, MonadThrow m) =>
m [(Bool, [Char])]
preferredPlatforms = do
    Platform Arch
arch' OS
os' <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL
    (Bool
isWindows, [Char]
os) <-
      case OS
os' of
        OS
Cabal.Linux -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [Char]
"linux")
        OS
Cabal.Windows -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, [Char]
"windows")
        OS
Cabal.OSX -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [Char]
"osx")
        OS
Cabal.FreeBSD -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [Char]
"freebsd")
        OS
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ HasCallStack => [Char] -> StringException
stringException forall a b. (a -> b) -> a -> b
$ [Char]
"Binary upgrade not yet supported on OS: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show OS
os'
    [Char]
arch <-
      case Arch
arch' of
        Arch
I386 -> forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"i386"
        Arch
X86_64 -> forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"x86_64"
        Arch
Arm -> forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"arm"
        Arch
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ HasCallStack => [Char] -> StringException
stringException forall a b. (a -> b) -> a -> b
$ [Char]
"Binary upgrade not yet supported on arch: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Arch
arch'
    Bool
hasgmp4 <- forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False -- FIXME import relevant code from Stack.Setup? checkLib $(mkRelFile "libgmp.so.3")

    let suffixes :: [[Char]]
suffixes
          | Bool
hasgmp4 = [[Char]
"-static", [Char]
"-gmp4", [Char]
""]
          | Bool
otherwise = [[Char]
"-static", [Char]
""]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\[Char]
suffix -> (Bool
isWindows, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
os, [Char]
"-", [Char]
arch, [Char]
suffix])) [[Char]]
suffixes

downloadStackExe
    :: HasConfig env
    => [(Bool, String)] -- ^ acceptable platforms

    -> StackReleaseInfo
    -> Path Abs Dir -- ^ destination directory

    -> Bool -- ^ perform PATH-aware checking, see #3232

    -> (Path Abs File -> IO ()) -- ^ test the temp exe before renaming

    -> RIO env ()
downloadStackExe :: forall env.
HasConfig env =>
[(Bool, [Char])]
-> StackReleaseInfo
-> Path Abs Dir
-> Bool
-> (Path Abs File -> IO ())
-> RIO env ()
downloadStackExe [(Bool, [Char])]
platforms0 StackReleaseInfo
archiveInfo Path Abs Dir
destDir Bool
checkPath Path Abs File -> IO ()
testExe = do
    (Bool
isWindows, Text
archiveURL) <-
      let loop :: [(Bool, [Char])] -> RIO env (Bool, Text)
loop [] = forall (m :: * -> *) a. (MonadIO m, HasCallStack) => [Char] -> m a
throwString forall a b. (a -> b) -> a -> b
$ [Char]
"Unable to find binary Stack archive for platforms: "
                                forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Bool, [Char])]
platforms0)
          loop ((Bool
isWindows, [Char]
p'):[(Bool, [Char])]
ps) = do
            let p :: Text
p = [Char] -> Text
T.pack [Char]
p'
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Querying for archive location for platform: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
p'
            case StackReleaseInfo -> Text -> Maybe Text
findArchive StackReleaseInfo
archiveInfo Text
p of
              Just Text
x -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
isWindows, Text
x)
              Maybe Text
Nothing -> [(Bool, [Char])] -> RIO env (Bool, Text)
loop [(Bool, [Char])]
ps
       in [(Bool, [Char])] -> RIO env (Bool, Text)
loop [(Bool, [Char])]
platforms0

    let (Path Abs File
destFile, Path Abs File
tmpFile)
            | Bool
isWindows =
                ( Path Abs Dir
destDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileStackDotExe
                , Path Abs Dir
destDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileStackDotTmpDotExe
                )
            | Bool
otherwise =
                ( Path Abs Dir
destDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileStack
                , Path Abs Dir
destDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileStackDotTmp
                )

    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Downloading from: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
RIO.display Text
archiveURL

    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
      case () of
        ()
          | Text
".tar.gz" Text -> Text -> Bool
`T.isSuffixOf` Text
archiveURL -> Path Abs File -> Bool -> Text -> IO ()
handleTarball Path Abs File
tmpFile Bool
isWindows Text
archiveURL
          | Text
".zip" Text -> Text -> Bool
`T.isSuffixOf` Text
archiveURL -> forall a. HasCallStack => [Char] -> a
error [Char]
"FIXME: Handle zip files"
          | Bool
otherwise -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Unknown archive format for Stack archive: " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
archiveURL

    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Download complete, testing executable"

    Platform
platform <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL

    -- We need to call getExecutablePath before we overwrite the

    -- currently running binary: after that, Linux will append

    -- (deleted) to the filename.

    [Char]
currExe <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [Char]
getExecutablePath

    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *). MonadIO m => [Char] -> m ()
setFileExecutable (forall b t. Path b t -> [Char]
toFilePath Path Abs File
tmpFile)

      Path Abs File -> IO ()
testExe Path Abs File
tmpFile

      case Platform
platform of
          Platform Arch
_ OS
Cabal.Windows | [Char] -> [Char] -> Bool
FP.equalFilePath (forall b t. Path b t -> [Char]
toFilePath Path Abs File
destFile) [Char]
currExe -> do
              Path Abs File
old <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs File)
parseAbsFile (forall b t. Path b t -> [Char]
toFilePath Path Abs File
destFile forall a. [a] -> [a] -> [a]
++ [Char]
".old")
              forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
renameFile Path Abs File
destFile Path Abs File
old
              forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
renameFile Path Abs File
tmpFile Path Abs File
destFile
          Platform
_ -> forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
renameFile Path Abs File
tmpFile Path Abs File
destFile

    [Char]
destDir' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO [Char]
D.canonicalizePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> [Char]
toFilePath forall a b. (a -> b) -> a -> b
$ Path Abs Dir
destDir
    forall env. HasConfig env => [Char] -> [Text] -> RIO env ()
warnInstallSearchPathIssues [Char]
destDir' [Text
"stack"]

    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"New stack executable available at " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs File
destFile)

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
checkPath forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Path Abs File -> [Char] -> RIO env ()
performPathChecking Path Abs File
destFile [Char]
currExe
      forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> Utf8Builder
displayShow)
  where

    findArchive :: StackReleaseInfo -> Text -> Maybe Text
findArchive (SRIGitHub Value
val) Text
pattern = do
        Object Object
top <- forall (m :: * -> *) a. Monad m => a -> m a
return Value
val
        Array Array
assets <- forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"assets" Object
top
        forall a. First a -> Maybe a
getFirst forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Maybe a -> First a
First forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value -> Maybe Text
findMatch Text
pattern') Array
assets
      where
        pattern' :: Text
pattern' = forall a. Monoid a => [a] -> a
mconcat [Text
"-", Text
pattern, Text
"."]

        findMatch :: Text -> Value -> Maybe Text
findMatch Text
pattern'' (Object Object
o) = do
            String Text
name <- forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"name" Object
o
            forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text
".asc" Text -> Text -> Bool
`T.isSuffixOf` Text
name
            forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Text
pattern'' Text -> Text -> Bool
`T.isInfixOf` Text
name
            String Text
url <- forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"browser_download_url" Object
o
            forall a. a -> Maybe a
Just Text
url
        findMatch Text
_ Value
_ = forall a. Maybe a
Nothing
    findArchive (SRIHaskellStackOrg HaskellStackOrg
hso) Text
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ HaskellStackOrg -> Text
hsoUrl HaskellStackOrg
hso

    handleTarball :: Path Abs File -> Bool -> T.Text -> IO ()
    handleTarball :: Path Abs File -> Bool -> Text -> IO ()
handleTarball Path Abs File
tmpFile Bool
isWindows Text
url = do
        Request
req <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Request -> Request
setGitHubHeaders forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseUrlThrow forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
url
        forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
Request -> (Response (ConduitM i ByteString n ()) -> m a) -> m a
withResponse Request
req forall a b. (a -> b) -> a -> b
$ \Response (ConduitM () ByteString IO ())
res -> do
            Entries FormatError
entries <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Entries FormatError
Tar.read forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
LBS.fromChunks)
                     forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadUnliftIO m, MonadActive m) =>
Source m a -> m [a]
lazyConsume
                     forall a b. (a -> b) -> a -> b
$ forall a. Response a -> a
getResponseBody Response (ConduitM () ByteString IO ())
res forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *).
(PrimMonad m, MonadThrow m) =>
ConduitT ByteString ByteString m ()
ungzip
            let loop :: Entries FormatError -> IO ()
loop Entries FormatError
Tar.Done = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                    [ [Char]
"Stack executable "
                    , forall a. Show a => a -> [Char]
show [Char]
exeName
                    , [Char]
" not found in archive from "
                    , Text -> [Char]
T.unpack Text
url
                    ]
                loop (Tar.Fail FormatError
e) = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM FormatError
e
                loop (Tar.Next Entry
e Entries FormatError
es) =
                    case [Char] -> [[Char]]
FP.splitPath (Entry -> [Char]
Tar.entryPath Entry
e) of
                        -- Ignore the first component, see: https://github.com/commercialhaskell/stack/issues/5288

                        [[Char]
_ignored, [Char]
name] | [Char]
name forall a. Eq a => a -> a -> Bool
== [Char]
exeName -> do
                            case Entry -> EntryContent
Tar.entryContent Entry
e of
                                Tar.NormalFile ByteString
lbs FileSize
_ -> do
                                  forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
destDir
                                  [Char] -> ByteString -> IO ()
LBS.writeFile (forall b t. Path b t -> [Char]
toFilePath Path Abs File
tmpFile) ByteString
lbs
                                EntryContent
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                                    [ [Char]
"Invalid file type for tar entry named "
                                    , Entry -> [Char]
Tar.entryPath Entry
e
                                    , [Char]
" downloaded from "
                                    , Text -> [Char]
T.unpack Text
url
                                    ]
                        [[Char]]
_ -> Entries FormatError -> IO ()
loop Entries FormatError
es
            Entries FormatError -> IO ()
loop Entries FormatError
entries
      where
        exeName :: [Char]
exeName
          | Bool
isWindows = [Char]
"stack.exe"
          | Bool
otherwise = [Char]
"stack"

-- | Ensure that the Stack executable download is in the same location

-- as the currently running executable. See:

-- https://github.com/commercialhaskell/stack/issues/3232

performPathChecking
    :: HasConfig env
    => Path Abs File -- ^ location of the newly downloaded file

    -> String -- ^ currently running executable

    -> RIO env ()
performPathChecking :: forall env. HasConfig env => Path Abs File -> [Char] -> RIO env ()
performPathChecking Path Abs File
newFile [Char]
executablePath = do
  Path Abs File
executablePath' <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs File)
parseAbsFile [Char]
executablePath
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall b t. Path b t -> [Char]
toFilePath Path Abs File
newFile forall a. Eq a => a -> a -> Bool
== [Char]
executablePath) forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Also copying stack executable to " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
executablePath
    Path Abs File
tmpFile <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs File)
parseAbsFile forall a b. (a -> b) -> a -> b
$ [Char]
executablePath forall a. [a] -> [a] -> [a]
++ [Char]
".tmp"
    Either IOException ()
eres <- forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
tryIO forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
copyFile Path Abs File
newFile Path Abs File
tmpFile
      forall (m :: * -> *). MonadIO m => [Char] -> m ()
setFileExecutable (forall b t. Path b t -> [Char]
toFilePath Path Abs File
tmpFile)
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
renameFile Path Abs File
tmpFile Path Abs File
executablePath'
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Stack executable copied successfully!"
    case Either IOException ()
eres of
      Right () -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Left IOException
e
        | IOException -> Bool
isPermissionError IOException
e -> do
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Permission error when trying to copy: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow IOException
e
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Should I try to perform the file copy using sudo? This may fail"
            Bool
toSudo <- forall (m :: * -> *). MonadIO m => Text -> m Bool
promptBool Text
"Try using sudo? (y/n) "
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
toSudo forall a b. (a -> b) -> a -> b
$ do
              let run :: [Char] -> [[Char]] -> m ()
run [Char]
cmd [[Char]]
args = do
                    ExitCode
ec <- forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc [Char]
cmd [[Char]]
args forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ExitCode
runProcess
                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
ec forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                          [ [Char]
"Process exited with "
                          , forall a. Show a => a -> [Char]
show ExitCode
ec
                          , [Char]
": "
                          , [[Char]] -> [Char]
unwords ([Char]
cmdforall a. a -> [a] -> [a]
:[[Char]]
args)
                          ]
                  commands :: [([Char], [[Char]])]
commands =
                    [ ([Char]
"sudo",
                        [ [Char]
"cp"
                        , forall b t. Path b t -> [Char]
toFilePath Path Abs File
newFile
                        , forall b t. Path b t -> [Char]
toFilePath Path Abs File
tmpFile
                        ])
                    , ([Char]
"sudo",
                        [ [Char]
"mv"
                        , forall b t. Path b t -> [Char]
toFilePath Path Abs File
tmpFile
                        , [Char]
executablePath
                        ])
                    ]
              forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Going to run the following commands:"
              forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
""
              forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [([Char], [[Char]])]
commands forall a b. (a -> b) -> a -> b
$ \([Char]
cmd, [[Char]]
args) ->
                forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"-  " forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
intersperse Utf8Builder
" " (forall a. IsString a => [Char] -> a
fromString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char]
cmdforall a. a -> [a] -> [a]
:[[Char]]
args)))
              forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall {m :: * -> *} {env}.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m) =>
[Char] -> [[Char]] -> m ()
run) [([Char], [[Char]])]
commands
              forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
""
              forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"sudo file copy worked!"
        | Bool
otherwise -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM IOException
e

getDownloadVersion :: StackReleaseInfo -> Maybe Version
getDownloadVersion :: StackReleaseInfo -> Maybe Version
getDownloadVersion (SRIGitHub Value
val) = do
    Object Object
o <- forall a. a -> Maybe a
Just Value
val
    String Text
rawName <- forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"name" Object
o
    -- drop the "v" at the beginning of the name

    [Char] -> Maybe Version
parseVersion forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack (Int -> Text -> Text
T.drop Int
1 Text
rawName)
getDownloadVersion (SRIHaskellStackOrg HaskellStackOrg
hso) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ HaskellStackOrg -> Version
hsoVersion HaskellStackOrg
hso