{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE MultiWayIf          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# 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
                   ( ConduitT, await, concatMapMC, filterCE, foldMC, yield )
import           Control.Applicative ( empty )
import           Crypto.Hash ( SHA1 (..), SHA256 (..) )
import qualified Data.Aeson.KeyMap as KeyMap
import           Data.Aeson.Types ( Value (..) )
import           Data.Aeson.WarningParser
                   ( WithJSONWarnings (..), logJSONWarnings )
import qualified Data.Attoparsec.Text as P
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as LBS
import           Data.Char ( isDigit )
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.Split ( splitOn )
import qualified Data.Map as Map
import           Data.Maybe ( fromJust )
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 ( Arch (..), OS, 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, setRequestMethod
                   , verifiedDownloadWithProgress, withResponse
                   )
import           Network.HTTP.Simple ( getResponseHeader )
import           Path
                   ( (</>), addExtension, filename, fromAbsDir, parent
                   , parseAbsDir, parseAbsFile, parseRelDir, parseRelFile
                   , toFilePath
                   )
import           Path.CheckInstall ( warnInstallSearchPathIssues )
import           Path.Extended ( fileExtension )
import           Path.Extra ( toFilePathNoTrailingSep )
import           Path.IO
                   ( canonicalizePath, doesFileExist, ensureDir, executable
                   , getPermissions, ignoringAbsence, listDir, removeDirRecur
                   , renameDir, renameFile, resolveFile', withTempDir
                   )
import           RIO.List
                   ( headMaybe, intercalate, intersperse, isPrefixOf
                   , maximumByMaybe, sort, sortOn, stripPrefix )
import           RIO.Process
                   ( EnvVars, HasProcessContext (..), ProcessContext
                   , augmentPath, augmentPathMap, doesExecutableExist, envVarsL
                   , exeSearchPathL, getStdout, mkProcessContext, modifyEnvVars
                   , proc, readProcess_, readProcessStdout, runProcess
                   , runProcess_, setStdout, waitExitCode, withModifyEnvVars
                   , withProcessWait, withWorkingDir, workingDirL
                   )
import           Stack.Build.Haddock ( shouldHaddockDeps )
import           Stack.Build.Source ( hashSourceMapData, loadSourceMap )
import           Stack.Build.Target ( NeedTargets (..), parseTargets )
import           Stack.Config.ConfigureScript ( ensureConfigureScript )
import           Stack.Constants
                   ( cabalPackageName, ghcBootScript,ghcConfigureMacOS
                   , ghcConfigurePosix, ghcConfigureWindows, hadrianScriptsPosix
                   , hadrianScriptsWindows, libDirs, osIsMacOS, osIsWindows
                   , relDirBin, relDirUsr, relFile7zdll, relFile7zexe
                   , relFileConfigure, relFileHadrianStackDotYaml
                   , relFileLibcMuslx86_64So1, relFileLibgmpSo10
                   , relFileLibgmpSo3, relFileLibncurseswSo6, relFileLibtinfoSo5
                   , relFileLibtinfoSo6, relFileMainHs, relFileStack
                   , relFileStackDotExe, relFileStackDotTmp
                   , relFileStackDotTmpDotExe, stackProgName, usrLibDirs
                   )
import           Stack.Constants.Config ( distRelativeDir )
import           Stack.GhcPkg
                   ( createDatabase, getGlobalDB, ghcPkgPathEnvVar
                   , mkGhcPackagePath )
import           Stack.Prelude
import           Stack.Setup.Installed
                   ( Tool (..), extraDirs, filterTools, getCompilerVersion
                   , installDir, listInstalled, markInstalled, tempInstallDir
                   , toolString, unmarkInstalled
                   )
import           Stack.SourceMap
                   ( actualFromGhc, globalsFromDump, pruneGlobals )
import           Stack.Storage.User ( loadCompilerPaths, saveCompilerPaths )
import           Stack.Types.Build.Exception ( BuildException (..) )
import           Stack.Types.BuildConfig
                   ( BuildConfig (..), HasBuildConfig (..), projectRootL
                   , wantedCompilerVersionL
                   )
import           Stack.Types.BuildOpts ( BuildOptsCLI (..) )
import           Stack.Types.Compiler
                   ( ActualCompiler (..), CompilerException (..)
                   , CompilerRepository (..), WhichCompiler (..)
                   , compilerVersionText, getGhcVersion, isWantedCompiler
                   , wantedToActual, whichCompiler, whichCompilerL
                   )
import           Stack.Types.CompilerBuild
                   ( CompilerBuild (..), compilerBuildName, compilerBuildSuffix
                   )
import           Stack.Types.CompilerPaths
                   ( CompilerPaths (..), GhcPkgExe (..), HasCompiler (..) )
import           Stack.Types.Config
                   ( Config (..), HasConfig (..), envOverrideSettingsL
                   , ghcInstallHook
                   )
import           Stack.Types.DownloadInfo ( DownloadInfo (..) )
import           Stack.Types.DumpPackage ( DumpPackage (..) )
import           Stack.Types.EnvConfig
                   ( EnvConfig (..), HasEnvConfig (..), extraBinDirs
                   , packageDatabaseDeps, packageDatabaseExtra
                   , packageDatabaseLocal
                   )
import           Stack.Types.EnvSettings ( EnvSettings (..), minimalEnvSettings )
import           Stack.Types.ExtraDirs ( ExtraDirs (..) )
import           Stack.Types.FileDigestCache ( newFileDigestCache )
import           Stack.Types.GHCDownloadInfo ( GHCDownloadInfo (..) )
import           Stack.Types.GHCVariant
                   ( GHCVariant (..), HasGHCVariant (..), ghcVariantName
                   , ghcVariantSuffix
                   )
import           Stack.Types.Platform
                   ( HasPlatform (..), PlatformVariant (..)
                   , platformOnlyRelDir )
import           Stack.Types.Runner ( HasRunner (..) )
import           Stack.Types.SetupInfo ( SetupInfo (..) )
import           Stack.Types.SourceMap ( SMActual (..), SourceMap (..) )
import           Stack.Types.Version
                   ( VersionCheck, stackMinorVersion, stackVersion )
import           Stack.Types.VersionedDownloadInfo
                   ( VersionedDownloadInfo (..) )
import qualified System.Directory as D
import           System.Environment ( getExecutablePath, lookupEnv )
import           System.IO.Error ( isPermissionError )
import           System.FilePath ( searchPathSeparator, takeDrive )
import qualified System.FilePath as FP
import           System.Permissions ( setFileExecutable )
import           System.Uname ( getRelease )

-- | Type representing exceptions thrown by functions exported by the
-- "Stack.Setup" module
data SetupException
  = WorkingDirectoryInvalidBug
  | StackBinaryArchiveZipUnsupportedBug
  deriving (Show, Typeable)

instance Exception SetupException where
  displayException WorkingDirectoryInvalidBug = bugReport "[S-2076]"
    "Invalid working directory."
  displayException StackBinaryArchiveZipUnsupportedBug = bugReport "[S-3967]"
    "FIXME: Handle zip files."

-- | Type representing \'pretty\' exceptions thrown by functions exported by the
-- "Stack.Setup" module
data SetupPrettyException
  = GHCInstallFailed
      !SomeException
      !String
      !String
      ![String]
      !(Path Abs Dir)
      !(Path Abs Dir)
      !(Path Abs Dir)
  | InvalidGhcAt !(Path Abs File) !SomeException
  | ExecutableNotFound ![Path Abs File]
  | SandboxedCompilerNotFound ![String] ![Path Abs Dir]
  | UnsupportedSetupCombo !OS !Arch
  | MissingDependencies ![String]
  | UnknownCompilerVersion
      !(Set.Set Text)
      !WantedCompiler
      !(Set.Set ActualCompiler)
  | UnknownOSKey !Text
  | GHCSanityCheckCompileFailed !SomeException !(Path Abs File)
  | RequireCustomGHCVariant
  | ProblemWhileDecompressing !(Path Abs File)
  | SetupInfoMissingSevenz
  | UnsupportedSetupConfiguration
  | MSYS2NotFound !Text
  | UnwantedCompilerVersion
  | UnwantedArchitecture
  | GHCInfoNotValidUTF8 !UnicodeException
  | GHCInfoNotListOfPairs
  | GHCInfoMissingGlobalPackageDB
  | GHCInfoMissingTargetPlatform
  | GHCInfoTargetPlatformInvalid !String
  | CabalNotFound !(Path Abs File)
  | GhcBootScriptNotFound
  | HadrianScriptNotFound
  | URLInvalid !String
  | UnknownArchiveExtension !String
  | Unsupported7z
  | TarballInvalid !String
  | TarballFileInvalid !String !(Path Abs File)
  | UnknownArchiveStructure !(Path Abs File)
  | StackReleaseInfoNotFound !String
  | StackBinaryArchiveNotFound ![String]
  | HadrianBindistNotFound
  | DownloadAndInstallCompilerError
  | StackBinaryArchiveUnsupported !Text
  | StackBinaryNotInArchive !String !Text
  | FileTypeInArchiveInvalid !Tar.Entry !Text
  | BinaryUpgradeOnOSUnsupported !Cabal.OS
  | BinaryUpgradeOnArchUnsupported !Cabal.Arch
  | ExistingMSYS2NotDeleted !(Path Abs Dir) !IOException
  deriving (Show, Typeable)

instance Pretty SetupPrettyException where
  pretty (GHCInstallFailed ex step cmd args wd tempDir destDir) =
    "[S-7441]"
    <> line
    <> string (displayException ex)
    <> line
    <> hang 2 (  fillSep
                   [ flow "Error encountered while"
                   , fromString step
                   , flow "GHC with"
                   ]
              <> line
              <> style Shell (fromString (unwords (cmd : args)))
              <> line
              -- TODO: Figure out how to insert \ in the appropriate spots
              -- hang 2 (shellColor (fillSep (fromString cmd : map fromString args))) <> line <>
              <> fillSep
                   [ flow "run in"
                   , pretty wd
                   ]
              )
    <> blankLine
    <> flow "The following directories may now contain files, but won't be \
            \used by Stack:"
    <> line
    <> bulletedList [pretty tempDir, pretty destDir]
    <> blankLine
    <> fillSep
         [ flow "For more information consider rerunning with"
         , style Shell "--verbose"
         , "flag."
         ]
    <> line
  pretty (InvalidGhcAt compiler e) =
    "[S-2476]"
    <> line
    <> fillSep
         [ flow "Stack considers the compiler at"
         , pretty compiler
         , flow "to be invalid."
         ]
    <> blankLine
    <> flow "While assessing that compiler, Stack encountered the error:"
    <> blankLine
    <> ppException e
  pretty (ExecutableNotFound toTry) =
    "[S-4764]"
    <> line
    <> flow "Stack could not find any of the following executables:"
    <> line
    <> bulletedList (map pretty toTry)
  pretty (SandboxedCompilerNotFound names fps) =
    "[S-9953]"
    <> line
    <> fillSep
         ( ( flow "Stack could not find the sandboxed compiler. It looked for \
                   \one named one of:"
            : mkNarrativeList Nothing False
                ( map fromString names :: [StyleDoc] )
            )
         <> ( flow "However, it could not find any on one of the paths:"
            : mkNarrativeList Nothing False fps
            )
         )
    <> blankLine
    <> fillSep
         [ flow "Perhaps a previously-installed compiler was not completely \
                \uninstalled. For further information about uninstalling \
                \tools, see the output of"
         , style Shell (flow "stack uninstall") <> "."
         ]
  pretty (UnsupportedSetupCombo os arch) =
    "[S-1852]"
    <> line
    <> fillSep
         [ flow "Stack does not know how to install GHC for the combination of \
                \operating system"
         , fromString $ show os
         , "and architecture"
         , fromString $ show arch <> "."
         , flow "Please install manually."
         ]
  pretty (MissingDependencies tools) =
    "[S-2126]"
    <> line
    <> fillSep
         ( flow "The following executables are missing and must be installed:"
         : mkNarrativeList Nothing False (map fromString tools :: [StyleDoc])
         )
  pretty (UnknownCompilerVersion oskeys wanted known) =
    "[S-9443]"
    <> line
    <> fillSep
         (  ( flow "No setup information found for"
            : style Current wanted'
            : flow "on your platform. This probably means a GHC binary \
                   \distribution has not yet been added for OS key"
            : mkNarrativeList (Just Shell) False
                (map (fromString . T.unpack) (sort $ Set.toList oskeys) :: [StyleDoc])
            )
         <> ( flow "Supported versions:"
            : mkNarrativeList Nothing False
                ( map
                    (fromString . T.unpack . compilerVersionText)
                    (sort $ Set.toList known)
                    :: [StyleDoc]
                )
            )
         )
   where
    wanted' = fromString . T.unpack . utf8BuilderToText $ display wanted
  pretty (UnknownOSKey oskey) =
    "[S-6810]"
    <> line
    <> fillSep
         [ flow "Unable to find installation URLs for OS key:"
         , fromString $ T.unpack oskey <> "."
         ]
  pretty (GHCSanityCheckCompileFailed e ghc) =
    "[S-5159]"
    <> line
    <> fillSep
         [ flow "The GHC located at"
         , pretty ghc
         , flow "failed to compile a sanity check. Please see:"
         , style Url "http://docs.haskellstack.org/en/stable/install_and_upgrade/"
         , flow "for more information. Stack encountered the following \
                \error:"
         ]
    <> blankLine
    <> string (displayException e)
  pretty RequireCustomGHCVariant =
    "[S-8948]"
    <> line
    <> fillSep
         [ flow "A custom"
         , style Shell "--ghc-variant"
         , flow "must be specified to use"
         , style Shell "--ghc-bindist" <> "."
         ]
  pretty (ProblemWhileDecompressing archive) =
    "[S-2905]"
    <> line
    <> fillSep
         [ flow "Problem while decompressing"
         , pretty archive <> "."
         ]
  pretty SetupInfoMissingSevenz =
    "[S-9561]"
    <> line
    <> flow "SetupInfo missing Sevenz EXE/DLL."
  pretty UnsupportedSetupConfiguration =
    "[S-7748]"
    <> line
    <> flow "Stack does not know how to install GHC on your system \
            \configuration. Please install manually."
  pretty (MSYS2NotFound osKey) =
    "[S-5308]"
    <> line
    <> fillSep
         [ flow "MSYS2 not found for"
         , fromString $ T.unpack osKey <> "."
         ]
  pretty UnwantedCompilerVersion =
    "[S-5127]"
    <> line
    <> flow "Not the compiler version we want."
  pretty UnwantedArchitecture =
    "[S-1540]"
    <> line
    <> flow "Not the architecture we want."
  pretty (GHCInfoNotValidUTF8 e) =
    "[S-8668]"
    <> line
    <> flow "GHC info is not valid UTF-8. Stack encountered the following \
            \error:"
    <> blankLine
    <> string (displayException e)
  pretty GHCInfoNotListOfPairs =
    "[S-4878]"
    <> line
    <> flow "GHC info does not parse as a list of pairs."
  pretty GHCInfoMissingGlobalPackageDB =
    "[S-2965]"
    <> line
    <> flow "Key 'Global Package DB' not found in GHC info."
  pretty GHCInfoMissingTargetPlatform =
    "[S-5219]"
    <> line
    <> flow "Key 'Target platform' not found in GHC info."
  pretty (GHCInfoTargetPlatformInvalid targetPlatform) =
    "[S-8299]"
    <> line
    <> fillSep
         [ flow "Invalid target platform in GHC info:"
         , fromString targetPlatform <> "."
         ]
  pretty (CabalNotFound compiler) =
    "[S-2574]"
    <> line
    <> fillSep
         [ flow "Cabal library not found in global package database for"
         , pretty compiler <> "."
         ]
  pretty GhcBootScriptNotFound =
    "[S-8488]"
    <> line
    <> flow "No GHC boot script found."
  pretty HadrianScriptNotFound =
    "[S-1128]"
    <> line
    <> flow "No Hadrian build script found."
  pretty (URLInvalid url) =
    "[S-1906]"
    <> line
    <> fillSep
         [ flow "`url` must be either an HTTP URL or a file path:"
         , fromString url <> "."
         ]
  pretty (UnknownArchiveExtension url) =
    "[S-1648]"
    <> line
    <> fillSep
         [ flow "Unknown extension for url:"
         , style Url (fromString url) <> "."
         ]
  pretty Unsupported7z =
    "[S-4509]"
    <> line
    <> fillSep
         [ flow "Stack does not know how to deal with"
         , style File ".7z"
         , flow "files on non-Windows operating systems."
         ]
  pretty (TarballInvalid name) =
    "[S-3158]"
    <> line
    <> fillSep
         [ style File (fromString name)
         , flow "must be a tarball file."
         ]
  pretty (TarballFileInvalid name archiveFile) =
    "[S-5252]"
    <> line
    <> fillSep
         [ "Invalid"
         , style File (fromString name)
         , "filename:"
         , pretty archiveFile <> "."
         ]
  pretty (UnknownArchiveStructure archiveFile) =
    "[S-1827]"
    <> line
    <> fillSep
         [ flow "Expected a single directory within unpacked"
         , pretty archiveFile <> "."
         ]
  pretty (StackReleaseInfoNotFound url) =
    "[S-9476]"
    <> line
    <> fillSep
         [ flow "Could not get release information for Stack from:"
         , style Url (fromString url) <> "."
         ]
  pretty (StackBinaryArchiveNotFound platforms) =
    "[S-4461]"
    <> line
    <> fillSep
         ( flow "Unable to find binary Stack archive for platforms:"
         : mkNarrativeList Nothing False
             (map fromString platforms :: [StyleDoc])
         )
  pretty HadrianBindistNotFound =
    "[S-6617]"
    <> line
    <> flow "Can't find Hadrian-generated binary distribution."
  pretty DownloadAndInstallCompilerError =
    "[S-7227]"
    <> line
    <> flow "'downloadAndInstallCompiler' should not be reached with ghc-git."
  pretty (StackBinaryArchiveUnsupported archiveURL) =
    "[S-6636]"
    <> line
    <> fillSep
         [ flow "Unknown archive format for Stack archive:"
         , style Url (fromString $ T.unpack archiveURL) <> "."
         ]
  pretty (StackBinaryNotInArchive exeName url) =
    "[S-7871]"
    <> line
    <> fillSep
         [ flow "Stack executable"
         , style File (fromString exeName)
         , flow "not found in archive from"
         , style Url (fromString $ T.unpack url) <> "."
         ]
  pretty (FileTypeInArchiveInvalid e url) =
    "[S-5046]"
    <> line
    <> fillSep
         [ flow "Invalid file type for tar entry named"
         , fromString (Tar.entryPath e)
         , flow "downloaded from"
         , style Url (fromString $ T.unpack url) <> "."
         ]
  pretty (BinaryUpgradeOnOSUnsupported os) =
    "[S-4132]"
    <> line
    <> fillSep
         [ flow "Binary upgrade not yet supported on OS:"
         , fromString (show os) <> "."
         ]
  pretty (BinaryUpgradeOnArchUnsupported arch) =
    "[S-3249]"
    <> line
    <> fillSep
         [ flow "Binary upgrade not yet supported on architecture:"
         , fromString (show arch) <> "."
         ]
  pretty (ExistingMSYS2NotDeleted destDir e) =
    "[S-4230]"
    <> line
    <> fillSep
         [ flow "Could not delete existing MSYS2 directory:"
         , pretty destDir <> "."
         , flow "Stack encountered the following error:"
         ]
    <> blankLine
    <> string (displayException e)

instance Exception SetupPrettyException

-- | Type representing exceptions thrown by 'performPathChecking'
data PerformPathCheckingException
  = ProcessExited ExitCode String [String]
  deriving (Show, Typeable)

instance Exception PerformPathCheckingException where
  displayException (ProcessExited ec cmd args) = concat
    [ "Error: [S-1991]\n"
    , "Process exited with "
    , displayException ec
    , ": "
    , unwords (cmd:args)
    ]

-- | Default location of the stack-setup.yaml file
defaultSetupInfoYaml :: String
defaultSetupInfoYaml =
  "https://raw.githubusercontent.com/commercialhaskell/stackage-content/master/stack/stack-setup-2.yaml"

data SetupOpts = SetupOpts
  { soptsInstallIfMissing :: !Bool
  , soptsUseSystem :: !Bool
    -- ^ Should we use a system compiler installation, if available?
  , soptsWantedCompiler :: !WantedCompiler
  , soptsCompilerCheck :: !VersionCheck
  , soptsStackYaml :: !(Maybe (Path Abs File))
    -- ^ If we got the desired GHC version from that file
  , soptsForceReinstall :: !Bool
  , soptsSanityCheck :: !Bool
    -- ^ Run a sanity check on the selected GHC
  , soptsSkipGhcCheck :: !Bool
    -- ^ Don't check for a compatible GHC version/architecture
  , soptsSkipMsys :: !Bool
    -- ^ Do not use a custom msys installation on Windows
  , soptsResolveMissingGHC :: !(Maybe Text)
    -- ^ Message shown to user for how to resolve the missing GHC
  , soptsGHCBindistURL :: !(Maybe String)
    -- ^ Alternate GHC binary distribution (requires custom GHCVariant)
  }
  deriving Show

-- | 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 boptsCLI mResolveMissingGHC = do
  config <- view configL
  bc <- view buildConfigL
  let stackYaml = bcStackYaml bc
  platform <- view platformL
  wcVersion <- view wantedCompilerVersionL
  wanted <- view wantedCompilerVersionL
  actual <- either throwIO pure $ wantedToActual wanted
  let wc = actual^.whichCompilerL
  let sopts = SetupOpts
        { soptsInstallIfMissing = configInstallGHC config
        , soptsUseSystem = configSystemGHC config
        , soptsWantedCompiler = wcVersion
        , soptsCompilerCheck = configCompilerCheck config
        , soptsStackYaml = Just stackYaml
        , soptsForceReinstall = False
        , soptsSanityCheck = False
        , soptsSkipGhcCheck = configSkipGHCCheck config
        , soptsSkipMsys = configSkipMsys config
        , soptsResolveMissingGHC = mResolveMissingGHC
        , soptsGHCBindistURL = Nothing
        }

  (compilerPaths, ghcBin) <- ensureCompilerAndMsys sopts
  let compilerVer = cpCompilerVersion compilerPaths

  -- Modify the initial environment to include the GHC path, if a local GHC
  -- is being used
  menv0 <- view processContextL
  env <- either throwM (pure . removeHaskellEnvVars)
           $ augmentPathMap
               (map toFilePath $ edBins ghcBin)
               (view envVarsL menv0)
  menv <- mkProcessContext env

  logDebug "Resolving package entries"

  (sourceMap, sourceMapHash) <- runWithGHC menv compilerPaths $ do
    smActual <- actualFromGhc (bcSMWanted bc) compilerVer
    let actualPkgs = Map.keysSet (smaDeps smActual) <>
                     Map.keysSet (smaProject smActual)
        prunedActual = smActual
          { smaGlobal = pruneGlobals (smaGlobal smActual) actualPkgs }
        haddockDeps = shouldHaddockDeps (configBuild config)
    targets <- parseTargets needTargets haddockDeps boptsCLI prunedActual
    sourceMap <- loadSourceMap targets boptsCLI smActual
    sourceMapHash <- hashSourceMapData boptsCLI sourceMap
    pure (sourceMap, sourceMapHash)

  fileDigestCache <- newFileDigestCache

  let envConfig0 = EnvConfig
        { envConfigBuildConfig = bc
        , envConfigBuildOptsCLI = boptsCLI
        , envConfigFileDigestCache = fileDigestCache
        , envConfigSourceMap = sourceMap
        , envConfigSourceMapHash = sourceMapHash
        , envConfigCompilerPaths = compilerPaths
        }

  -- extra installation bin directories
  mkDirs <- runRIO envConfig0 extraBinDirs
  let mpath = Map.lookup "PATH" env
  depsPath <-
    either throwM pure $ augmentPath (toFilePath <$> mkDirs False) mpath
  localsPath <-
    either throwM pure $ augmentPath (toFilePath <$> mkDirs True) mpath

  deps <- runRIO envConfig0 packageDatabaseDeps
  runWithGHC menv compilerPaths $ createDatabase (cpPkg compilerPaths) deps
  localdb <- runRIO envConfig0 packageDatabaseLocal
  runWithGHC menv compilerPaths $ createDatabase (cpPkg compilerPaths) localdb
  extras <- runReaderT packageDatabaseExtra envConfig0
  let mkGPP locals =
        mkGhcPackagePath locals localdb deps extras $ cpGlobalDB compilerPaths

  distDir <- runReaderT distRelativeDir envConfig0 >>= canonicalizePath

  executablePath <- liftIO getExecutablePath

  utf8EnvVars <- withProcessContext menv $ getUtf8EnvVars compilerVer

  mGhcRtsEnvVar <- liftIO $ lookupEnv "GHCRTS"

  envRef <- liftIO $ newIORef Map.empty
  let getProcessContext' es = do
        m <- readIORef envRef
        case Map.lookup es m of
          Just eo -> pure eo
          Nothing -> do
            eo <- mkProcessContext
              $ Map.insert
                  "PATH"
                  (if esIncludeLocals es then localsPath else depsPath)
              $ (if esIncludeGhcPackagePath es
                   then
                     Map.insert
                       (ghcPkgPathEnvVar wc)
                       (mkGPP (esIncludeLocals es))
                   else id)

              $ (if esStackExe es
                   then Map.insert "STACK_EXE" (T.pack executablePath)
                   else id)

              $ (if esLocaleUtf8 es
                   then Map.union utf8EnvVars
                   else id)

              $ case (soptsSkipMsys sopts, platform) of
                  (False, Platform Cabal.I386   Cabal.Windows) ->
                    Map.insert "MSYSTEM" "MINGW32"
                  (False, Platform Cabal.X86_64 Cabal.Windows) ->
                    Map.insert "MSYSTEM" "MINGW64"
                  _ -> id

              -- See https://github.com/commercialhaskell/stack/issues/3444
              $ case (esKeepGhcRts es, mGhcRtsEnvVar) of
                  (True, Just ghcRts) -> Map.insert "GHCRTS" (T.pack ghcRts)
                  _ -> id

              -- For reasoning and duplication, see:
              -- https://github.com/commercialhaskell/stack/issues/70
              $ Map.insert
                  "HASKELL_PACKAGE_SANDBOX"
                  (T.pack $ toFilePathNoTrailingSep deps)
              $ Map.insert "HASKELL_PACKAGE_SANDBOXES"
                  (T.pack $ if esIncludeLocals es
                    then intercalate [searchPathSeparator]
                           [ toFilePathNoTrailingSep localdb
                           , toFilePathNoTrailingSep deps
                           , ""
                           ]
                    else intercalate [searchPathSeparator]
                           [ toFilePathNoTrailingSep deps
                           , ""
                           ])
              $ Map.insert
                  "HASKELL_DIST_DIR"
                  (T.pack $ toFilePathNoTrailingSep 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
              $ (case cpCompilerVersion compilerPaths of
                  ACGhc version | version >= mkVersion [8, 4, 4] ->
                    Map.insert "GHC_ENVIRONMENT" "-"
                  _ -> id)

                env

            () <- atomicModifyIORef envRef $ \m' ->
                (Map.insert es eo m', ())
            pure eo

  envOverride <- liftIO $ getProcessContext' minimalEnvSettings
  pure EnvConfig
    { envConfigBuildConfig = bc
        { bcConfig = addIncludeLib ghcBin
                   $ set processContextL envOverride
                     (view configL bc)
            { configProcessContextSettings = getProcessContext'
            }
        }
    , envConfigBuildOptsCLI = boptsCLI
    , envConfigFileDigestCache = fileDigestCache
    , envConfigSourceMap = sourceMap
    , envConfigSourceMapHash = sourceMapHash
    , envConfigCompilerPaths = 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 = lens (\(WithGHC _ x) -> x) (\(WithGHC cp _) -> WithGHC cp)

instance HasLogFunc env => HasLogFunc (WithGHC env) where
  logFuncL = insideL.logFuncL

instance HasRunner env => HasRunner (WithGHC env) where
  runnerL = insideL.runnerL

instance HasProcessContext env => HasProcessContext (WithGHC env) where
  processContextL = insideL.processContextL

instance HasStylesUpdate env => HasStylesUpdate (WithGHC env) where
  stylesUpdateL = insideL.stylesUpdateL

instance HasTerm env => HasTerm (WithGHC env) where
  useColorL = insideL.useColorL
  termWidthL = insideL.termWidthL

instance HasPantryConfig env => HasPantryConfig (WithGHC env) where
  pantryConfigL = insideL.pantryConfigL

instance HasConfig env => HasPlatform (WithGHC env) where
  platformL = configL.platformL
  {-# INLINE platformL #-}
  platformVariantL = configL.platformVariantL
  {-# INLINE platformVariantL #-}

instance HasConfig env => HasGHCVariant (WithGHC env) where
  ghcVariantL = configL.ghcVariantL
  {-# INLINE ghcVariantL #-}

instance HasConfig env => HasConfig (WithGHC env) where
  configL = insideL.configL

instance HasBuildConfig env => HasBuildConfig (WithGHC env) where
  buildConfigL = insideL.buildConfigL

instance HasCompiler (WithGHC env) where
  compilerPathsL = to (\(WithGHC cp _) -> 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 pc cp inner = do
  env <- ask
  let envg
        = WithGHC cp $
          set envOverrideSettingsL (\_ -> pure pc) $
          set processContextL pc env
  runRIO envg inner

-- | A modified environment which we know has MSYS2 on the PATH.
newtype WithMSYS env = WithMSYS env

insideMSYSL :: Lens' (WithMSYS env) env
insideMSYSL = lens (\(WithMSYS x) -> x) (\(WithMSYS _) -> WithMSYS)

instance HasLogFunc env => HasLogFunc (WithMSYS env) where
  logFuncL = insideMSYSL.logFuncL

instance HasRunner env => HasRunner (WithMSYS env) where
  runnerL = insideMSYSL.runnerL

instance HasProcessContext env => HasProcessContext (WithMSYS env) where
  processContextL = insideMSYSL.processContextL

instance HasStylesUpdate env => HasStylesUpdate (WithMSYS env) where
  stylesUpdateL = insideMSYSL.stylesUpdateL

instance HasTerm env => HasTerm (WithMSYS env) where
  useColorL = insideMSYSL.useColorL
  termWidthL = insideMSYSL.termWidthL

instance HasPantryConfig env => HasPantryConfig (WithMSYS env) where
  pantryConfigL = insideMSYSL.pantryConfigL

instance HasConfig env => HasPlatform (WithMSYS env) where
  platformL = configL.platformL
  {-# INLINE platformL #-}
  platformVariantL = configL.platformVariantL
  {-# INLINE platformVariantL #-}

instance HasConfig env => HasGHCVariant (WithMSYS env) where
  ghcVariantL = configL.ghcVariantL
  {-# INLINE ghcVariantL #-}

instance HasConfig env => HasConfig (WithMSYS env) where
  configL = insideMSYSL.configL

instance HasBuildConfig env => HasBuildConfig (WithMSYS env) where
  buildConfigL = insideMSYSL.buildConfigL

-- | Set up a modified environment which includes the modified PATH that MSYS2
-- can be found on.
runWithMSYS ::
     HasConfig env
  => Maybe ExtraDirs
  -> RIO (WithMSYS env) a
  -> RIO env a
runWithMSYS mmsysPaths inner = do
  env <- ask
  pc0 <- view processContextL
  pc <- case mmsysPaths of
    Nothing -> pure pc0
    Just msysPaths -> do
      envars <- either throwM pure $
        augmentPathMap
          (map toFilePath $ edBins msysPaths)
          (view envVarsL pc0)
      mkProcessContext envars
  let envMsys
        = WithMSYS $
          set envOverrideSettingsL (\_ -> pure pc) $
          set processContextL pc env
  runRIO envMsys 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 envConfig needTargets haddockDeps boptsCLI = do
  let bc = envConfigBuildConfig envConfig
      cp = envConfigCompilerPaths envConfig
      compilerVer = smCompiler $ envConfigSourceMap envConfig
  runRIO (WithGHC cp bc) $ do
    smActual <- actualFromGhc (bcSMWanted bc) compilerVer
    let actualPkgs =
          Map.keysSet (smaDeps smActual) <> Map.keysSet (smaProject smActual)
        prunedActual = smActual
          { smaGlobal = pruneGlobals (smaGlobal smActual) actualPkgs }
    targets <- parseTargets needTargets haddockDeps boptsCLI prunedActual
    sourceMap <- loadSourceMap targets boptsCLI smActual
    pure $ envConfig
      { envConfigSourceMap = sourceMap
      , envConfigBuildOptsCLI = 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 targets f = do
  envConfig <- view envConfigL
  haddockDeps <- view $ configL.to configBuild.to shouldHaddockDeps
  let boptsCLI = envConfigBuildOptsCLI envConfig
  envConfig' <- rebuildEnv envConfig NeedTargets haddockDeps $
                boptsCLI {boptsCLITargets = targets}
  local (set envConfigL envConfig') f

-- | Add the include and lib paths to the given Config
addIncludeLib :: ExtraDirs -> Config -> Config
addIncludeLib (ExtraDirs _bins includes libs) config = config
  { configExtraIncludeDirs =
      configExtraIncludeDirs config ++
      map toFilePathNoTrailingSep includes
  , configExtraLibDirs =
      configExtraLibDirs config ++
      map toFilePathNoTrailingSep 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 sopts = do
  getSetupInfo' <- memoizeRef getSetupInfo
  mmsys2Tool <- ensureMsys sopts getSetupInfo'
  mmsysPaths <- maybe (pure Nothing) (fmap Just . extraDirs) mmsys2Tool
  actual <- either throwIO pure $ wantedToActual $ soptsWantedCompiler sopts
  didWarn <- warnUnsupportedCompiler $ getGhcVersion actual
  -- Modify the initial environment to include the MSYS2 path, if MSYS2 is being
  -- used
  (cp, ghcPaths) <- runWithMSYS mmsysPaths $ ensureCompiler sopts getSetupInfo'

  warnUnsupportedCompilerCabal cp didWarn

  let paths = maybe ghcPaths (ghcPaths <>) mmsysPaths
  pure (cp, paths)

-- | See <https://github.com/commercialhaskell/stack/issues/4246>
warnUnsupportedCompiler :: HasTerm env => Version -> RIO env Bool
warnUnsupportedCompiler ghcVersion =
  if
    | ghcVersion < mkVersion [7, 8] -> do
        prettyWarnL
          [ flow "Stack will almost certainly fail with GHC below version 7.8, \
                 \requested"
          , fromString (versionString ghcVersion) <> "."
          , flow "Valiantly attempting to run anyway, but I know this is \
                 \doomed."
          , flow "For more information, see:"
          , style Url "https://github.com/commercialhaskell/stack/issues/648" <> "."
          ]
        pure True
    | ghcVersion >= mkVersion [9, 7] -> do
        prettyWarnL
          [ flow "Stack has not been tested with GHC versions 9.8 and above, and \
                 \using"
          , fromString (versionString ghcVersion) <> ","
          , flow "this may fail."
          ]
        pure True
    | otherwise -> do
        logDebug "Asking for a supported GHC version"
        pure False

-- | See <https://github.com/commercialhaskell/stack/issues/4246>
warnUnsupportedCompilerCabal ::
     HasTerm env
  => CompilerPaths
  -> Bool -- ^ already warned about GHC?
  -> RIO env ()
warnUnsupportedCompilerCabal cp didWarn = do
  unless didWarn $
    void $ warnUnsupportedCompiler $ getGhcVersion $ cpCompilerVersion cp
  let cabalVersion = cpCabalVersion cp

  if
    | cabalVersion < mkVersion [1, 24, 0] -> do
        prettyWarnL
          [ flow "Stack no longer supports Cabal versions below 1.24.0.0, but \
                 \version"
          , fromString (versionString cabalVersion)
          , flow "was found. This invocation will most likely fail. To fix \
                 \this, either use an older version of Stack or a newer \
                 \resolver. Acceptable resolvers: lts-7.0/nightly-2016-05-26 \
                 \or later."
          ]
    | cabalVersion >= mkVersion [3, 11] ->
        prettyWarnL
          [ flow "Stack has not been tested with Cabal versions 3.12 and above, \
                 \but version"
          , fromString (versionString cabalVersion)
          , flow "was found, this may fail."
          ]
    | otherwise -> 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 sopts getSetupInfo' = do
  platform <- view platformL
  localPrograms <- view $ configL.to configLocalPrograms
  installed <- listInstalled localPrograms

  case platform of
    Platform _ Cabal.Windows | not (soptsSkipMsys sopts) ->
      case getInstalledTool installed (mkPackageName "msys2") (const True) of
        Just tool -> pure (Just tool)
        Nothing
          | soptsInstallIfMissing sopts -> do
              si <- runMemoized getSetupInfo'
              osKey <- getOSKey platform
              config <- view configL
              VersionedDownloadInfo version info <-
                case Map.lookup osKey $ siMsys2 si of
                  Just x -> pure x
                  Nothing -> prettyThrowIO $ MSYS2NotFound osKey
              let tool = Tool (PackageIdentifier (mkPackageName "msys2") version)
              Just <$> downloadAndInstallTool
                         (configLocalPrograms config)
                         info
                         tool
                         (installMsys2Windows si)
          | otherwise -> do
              prettyWarnS "Continuing despite missing tool: msys2"
              pure Nothing
    _ -> pure Nothing

installGhcBindist ::
     HasBuildConfig env
  => SetupOpts
  -> Memoized SetupInfo
  -> [Tool]
  -> RIO env (Tool, CompilerBuild)
installGhcBindist sopts getSetupInfo' installed = do
  Platform expectedArch _ <- view platformL
  let wanted = soptsWantedCompiler sopts
      isWanted =
        isWantedCompiler (soptsCompilerCheck sopts) (soptsWantedCompiler sopts)
  config <- view configL
  ghcVariant <- view ghcVariantL
  wc <- either throwIO (pure . whichCompiler) $ wantedToActual wanted
  possibleCompilers <-
    case wc of
      Ghc -> do
        ghcBuilds <- getGhcBuilds
        forM ghcBuilds $ \ghcBuild -> do
          ghcPkgName <- parsePackageNameThrowing
            (  "ghc"
            ++ ghcVariantSuffix ghcVariant
            ++ compilerBuildSuffix ghcBuild
            )
          pure (getInstalledTool installed ghcPkgName (isWanted . ACGhc), ghcBuild)
  let existingCompilers = concatMap
        (\(installedCompiler, compilerBuild) ->
          case (installedCompiler, soptsForceReinstall sopts) of
            (Just tool, False) -> [(tool, compilerBuild)]
            _ -> [])
        possibleCompilers
  logDebug $
       "Found already installed GHC builds: "
    <> mconcat (intersperse ", " (map (fromString . compilerBuildName . snd) existingCompilers))
  case existingCompilers of
    (tool, build_):_ -> pure (tool, build_)
    []
      | soptsInstallIfMissing sopts -> do
          si <- runMemoized getSetupInfo'
          downloadAndInstallPossibleCompilers
            (map snd possibleCompilers)
            si
            (soptsWantedCompiler sopts)
            (soptsCompilerCheck sopts)
            (soptsGHCBindistURL sopts)
      | otherwise -> do
          let suggestion = fromMaybe
                (mconcat
                  [ "To install the correct GHC into "
                  , T.pack (toFilePath (configLocalPrograms config))
                  , ", try running 'stack setup' or use the '--install-ghc' flag."
                  , " To use your system GHC installation, run \
                    \'stack config set system-ghc --global true', \
                    \or use the '--system-ghc' flag."
                  ])
                (soptsResolveMissingGHC sopts)
          throwM $ CompilerVersionMismatch
            Nothing -- FIXME ((\(x, y, _) -> (x, y)) <$> msystem)
            (soptsWantedCompiler sopts, expectedArch)
            ghcVariant
            (case possibleCompilers of
              [] -> CompilerBuildStandard
              (_, compilerBuild):_ -> compilerBuild)
            (soptsCompilerCheck sopts)
            (soptsStackYaml sopts)
            suggestion

-- | Ensure compiler is installed.
ensureCompiler ::
     forall env. (HasConfig env, HasBuildConfig env, HasGHCVariant env)
  => SetupOpts
  -> Memoized SetupInfo
  -> RIO (WithMSYS env) (CompilerPaths, ExtraDirs)
ensureCompiler sopts getSetupInfo' = do
  let wanted = soptsWantedCompiler sopts
  wc <- either throwIO (pure . whichCompiler) $ wantedToActual wanted

  hook <- ghcInstallHook
  hookIsExecutable <- handleIO (\_ -> pure False) $ if osIsWindows
    then doesFileExist hook  -- can't really detect executable on windows, only
                             -- file extension
    else executable <$> getPermissions hook

  Platform expectedArch _ <- view platformL

  let canUseCompiler cp
        | soptsSkipGhcCheck sopts = pure cp
        | not $ isWanted $ cpCompilerVersion cp =
            prettyThrowIO UnwantedCompilerVersion
        | cpArch cp /= expectedArch = prettyThrowIO UnwantedArchitecture
        | otherwise = pure cp
      isWanted =
        isWantedCompiler (soptsCompilerCheck sopts) (soptsWantedCompiler sopts)

  let checkCompiler :: Path Abs File -> RIO (WithMSYS env) (Maybe CompilerPaths)
      checkCompiler compiler = do
        eres <- tryAny $
          pathsFromCompiler wc CompilerBuildStandard False compiler >>= canUseCompiler
        case eres of
          Left e -> do
            logDebug $
                 "Not using compiler at "
              <> displayShow (toFilePath compiler)
              <> ": "
              <> displayShow e
            pure Nothing
          Right cp -> pure $ Just cp

  mcp <-
    if | soptsUseSystem sopts -> do
          logDebug "Getting system compiler version"
          runConduit $
            sourceSystemCompilers wanted .|
            concatMapMC checkCompiler .|
            await
       | hookIsExecutable -> do
        -- if the hook fails, we fall through to stacks sandboxed installation
          hookGHC <- runGHCInstallHook sopts hook
          maybe (pure Nothing) checkCompiler hookGHC
       | otherwise -> pure Nothing
  case mcp of
    Nothing -> ensureSandboxedCompiler sopts getSetupInfo'
    Just cp -> do
      let paths = ExtraDirs
            { edBins = [parent $ cpCompiler cp]
            , edInclude = [], edLib = []
            }
      pure (cp, 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 sopts hook = do
  logDebug "Getting hook installed compiler version"
  let wanted = soptsWantedCompiler sopts
  menv0 <- view processContextL
  menv <- mkProcessContext (Map.union (wantedCompilerToEnv wanted) $
    removeHaskellEnvVars (view envVarsL menv0))
  (exit, out) <- withProcessContext menv $ proc "sh" [toFilePath hook] readProcessStdout
  case exit of
    ExitSuccess -> do
      let ghcPath = stripNewline . TL.unpack . TL.decodeUtf8With T.lenientDecode $ out
      case parseAbsFile ghcPath of
        Just compiler -> do
          when (soptsSanityCheck sopts) $ sanityCheck compiler
          logDebug ("Using GHC compiler at: " <> fromString (toFilePath compiler))
          pure (Just compiler)
        Nothing -> do
          prettyWarnL
            [ flow "Path to GHC binary is not a valid path:"
            , style Dir (fromString ghcPath) <> "."
            ]
          pure Nothing
    ExitFailure i -> do
      prettyWarnL
        [ flow "GHC install hook exited with code:"
        , style Error (fromString $ show i) <> "."
        ]
      pure Nothing
 where
  wantedCompilerToEnv :: WantedCompiler -> EnvVars
  wantedCompilerToEnv (WCGhc ver) =
    Map.fromList [ ("HOOK_GHC_TYPE", "bindist")
                 , ("HOOK_GHC_VERSION", T.pack (versionString ver))
                 ]
  wantedCompilerToEnv (WCGhcGit commit flavor) =
    Map.fromList [ ("HOOK_GHC_TYPE", "git")
                 , ("HOOK_GHC_COMMIT", commit)
                 , ("HOOK_GHC_FLAVOR", flavor)
                 , ("HOOK_GHC_FLAVOUR", flavor)
                 ]
  wantedCompilerToEnv (WCGhcjs ghcjs_ver ghc_ver) =
    Map.fromList [ ("HOOK_GHC_TYPE", "ghcjs")
                 , ("HOOK_GHC_VERSION", T.pack (versionString ghc_ver))
                 , ("HOOK_GHCJS_VERSION", T.pack (versionString ghcjs_ver))
                 ]
  newlines :: [Char]
  newlines = ['\n', '\r']

  stripNewline :: String -> String
  stripNewline = filter (`notElem` newlines)

ensureSandboxedCompiler ::
     HasBuildConfig env
  => SetupOpts
  -> Memoized SetupInfo
  -> RIO (WithMSYS env) (CompilerPaths, ExtraDirs)
ensureSandboxedCompiler sopts getSetupInfo' = do
  let wanted = soptsWantedCompiler sopts
  -- List installed tools
  config <- view configL
  let localPrograms = configLocalPrograms config
  installed <- listInstalled localPrograms
  logDebug $
       "Installed tools: \n - "
    <> mconcat (intersperse "\n - " (map (fromString . toolString) installed))
  (compilerTool, compilerBuild) <-
    case soptsWantedCompiler sopts of
     -- shall we build GHC from source?
     WCGhcGit commitId flavour ->
       buildGhcFromSource
         getSetupInfo'
         installed
         (configCompilerRepository config)
         commitId
         flavour
     _ -> installGhcBindist sopts getSetupInfo' installed
  paths <- extraDirs compilerTool

  wc <- either throwIO (pure . whichCompiler) $ wantedToActual wanted
  menv0 <- view processContextL
  m <- either throwM pure
     $ augmentPathMap (toFilePath <$> edBins paths) (view envVarsL menv0)
  menv <- mkProcessContext (removeHaskellEnvVars m)

  names <-
    case wanted of
      WCGhc version -> pure ["ghc-" ++ versionString version, "ghc"]
      WCGhcGit{} -> pure ["ghc"]
      WCGhcjs{} -> throwIO 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 [] = prettyThrowIO $ SandboxedCompilerNotFound names (edBins paths)
      loop (x:xs) = do
        res <- liftIO $
          D.findExecutablesInDirectories (map toFilePath (edBins paths)) x
        case res of
          [] -> loop xs
          compiler:rest -> do
            unless (null rest) $ do
              prettyWarn $
                   flow "Found multiple candidate compilers:"
                <> line
                <> bulletedList (map fromString res)
                <> blankLine
                <> fillSep
                     [ flow "This usually indicates a failed installation. \
                        \Trying anyway with"
                     , fromString compiler
                     ]
            parseAbsFile compiler
  compiler <- withProcessContext menv $ do
    compiler <- loop 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.
    when (soptsSanityCheck sopts) $ sanityCheck compiler

    pure compiler

  cp <- pathsFromCompiler wc compilerBuild True compiler
  pure (cp, paths)

pathsFromCompiler ::
     forall env. HasConfig env
  => WhichCompiler
  -> CompilerBuild
  -> Bool
  -> Path Abs File -- ^ executable filepath
  -> RIO env CompilerPaths
pathsFromCompiler wc compilerBuild isSandboxed compiler =
  withCache $ handleAny onErr $ do
    let dir = toFilePath $ parent compiler

        suffixNoVersion
          | osIsWindows = ".exe"
          | otherwise = ""
        msuffixWithVersion = do
          let prefix =
                case wc of
                  Ghc -> "ghc-"
          fmap ("-" ++) $ stripPrefix prefix $ toFilePath $ filename compiler
        suffixes = maybe id (:) msuffixWithVersion [suffixNoVersion]
        findHelper :: (WhichCompiler -> [String]) -> RIO env (Path Abs File)
        findHelper getNames = do
          toTry <- mapM
                     parseAbsFile
                     [ dir ++ name ++ suffix
                     | suffix <- suffixes, name <- getNames wc
                     ]
          let loop [] = throwIO $ PrettyException $ ExecutableNotFound toTry
              loop (guessedPath:rest) = do
                exists <- doesFileExist guessedPath
                if exists
                  then pure guessedPath
                  else loop rest
          prettyDebug $
               flow "Looking for executable(s):"
            <> line
            <> bulletedList (map pretty toTry)
          loop toTry
    pkg <- fmap GhcPkgExe $ findHelper $ \case
                               Ghc -> ["ghc-pkg"]

    menv0 <- view processContextL
    menv <- mkProcessContext (removeHaskellEnvVars (view envVarsL menv0))

    interpreter <- findHelper $
                   \case
                      Ghc -> ["runghc"]
    haddock <- findHelper $
               \case
                  Ghc -> ["haddock", "haddock-ghc"]
    infobs <- proc (toFilePath compiler) ["--info"]
            $ fmap (toStrictBytes . fst) . readProcess_
    infotext <-
      case decodeUtf8' infobs of
        Left e -> prettyThrowIO $ GHCInfoNotValidUTF8 e
        Right info -> pure info
    infoPairs :: [(String, String)] <-
      case readMaybe $ T.unpack infotext of
        Nothing -> prettyThrowIO GHCInfoNotListOfPairs
        Just infoPairs -> pure infoPairs
    let infoMap = Map.fromList infoPairs

    eglobaldb <- tryAny $
      case Map.lookup "Global Package DB" infoMap of
        Nothing -> prettyThrowIO GHCInfoMissingGlobalPackageDB
        Just db -> parseAbsDir db

    arch <-
      case Map.lookup "Target platform" infoMap of
        Nothing -> prettyThrowIO GHCInfoMissingTargetPlatform
        Just targetPlatform ->
          case simpleParse $ takeWhile (/= '-') targetPlatform of
            Nothing ->
              prettyThrowIO $ GHCInfoTargetPlatformInvalid targetPlatform
            Just arch -> pure arch
    compilerVer <-
      case wc of
        Ghc ->
          case Map.lookup "Project version" infoMap of
            Nothing -> do
              prettyWarnS "Key 'Project version' not found in GHC info."
              getCompilerVersion wc compiler
            Just versionString' -> ACGhc <$> parseVersionThrowing versionString'
    globaldb <-
      case eglobaldb of
        Left e -> do
          prettyWarn $
               flow "Stack failed to parse the global DB from GHC info."
            <> blankLine
            <> flow "While parsing, Stack encountered the error:"
            <> blankLine
            <> string (show e)
            <> blankLine
            <> flow "Asking ghc-pkg directly."
          withProcessContext menv $ getGlobalDB pkg
        Right x -> pure x

    globalDump <- withProcessContext menv $ globalsFromDump pkg
    cabalPkgVer <-
      case Map.lookup cabalPackageName globalDump of
        Nothing -> prettyThrowIO $ CabalNotFound compiler
        Just dp -> pure $ pkgVersion $ dpPackageIdent dp

    pure CompilerPaths
      { cpBuild = compilerBuild
      , cpArch = arch
      , cpSandboxed = isSandboxed
      , cpCompilerVersion = compilerVer
      , cpCompiler = compiler
      , cpPkg = pkg
      , cpInterpreter = interpreter
      , cpHaddock = haddock
      , cpCabalVersion = cabalPkgVer
      , cpGlobalDB = globaldb
      , cpGhcInfo = infobs
      , cpGlobalDump = globalDump
      }
 where
  onErr = throwIO . PrettyException . InvalidGhcAt compiler

  withCache inner = do
    eres <- tryAny $ loadCompilerPaths compiler compilerBuild isSandboxed
    mres <-
      case eres of
        Left e -> do
          prettyWarn $
               flow "Trouble loading CompilerPaths cache:"
            <> blankLine
            <> string (displayException e)
          pure Nothing
        Right x -> pure x
    case mres of
      Just cp -> cp <$ logDebug "Loaded compiler information from cache"
      Nothing -> do
        cp <- inner
        saveCompilerPaths cp `catchAny` \e ->
          prettyWarn $
               flow "Unable to save CompilerPaths cache:"
            <> blankLine
            <> string (displayException e)
        pure cp

buildGhcFromSource ::
     forall env. ( HasTerm env, HasProcessContext env, HasBuildConfig env)
  => Memoized SetupInfo
  -> [Tool]
  -> CompilerRepository
  -> Text
     -- ^ Commit ID.
  -> Text
     -- ^ Hadrain flavour.
  -> RIO (WithMSYS env) (Tool, CompilerBuild)
buildGhcFromSource getSetupInfo' installed (CompilerRepository url) commitId flavour = do
  config <- view configL
  let compilerTool = ToolGhcGit commitId flavour
  -- detect when the correct GHC is already installed
  if compilerTool `elem` installed
    then pure (compilerTool, CompilerBuildStandard)
    else
      -- clone the repository and execute the given commands
      withRepo (SimpleRepo url commitId RepoGit) $ do
        -- withRepo is guaranteed to set workingDirL, so let's get it
        mcwd <- traverse parseAbsDir =<< view workingDirL
        cwd <- maybe (throwIO WorkingDirectoryInvalidBug) pure mcwd
        let threads = configJobs config
            relFileHadrianStackDotYaml' = toFilePath relFileHadrianStackDotYaml
            ghcBootScriptPath = cwd </> ghcBootScript
            boot = if osIsWindows
              then proc "python3" ["boot"] runProcess_
              else
                proc (toFilePath ghcBootScriptPath) [] runProcess_
            stack args = proc "stack" args'' runProcess_
             where
              args'' = "--stack-yaml=" <> relFileHadrianStackDotYaml' : args'
              -- If a resolver is specified on the command line, Stack will
              -- apply it. This allows the resolver specified in Hadrian's
              -- stack.yaml file to be overridden.
              args' = maybe args addResolver (configResolver config)
              addResolver resolver = "--resolver=" <> show resolver : args
            happy = stack ["install", "happy"]
            alex = stack ["install", "alex"]
            -- Executed in the Stack environment, because GHC is required.
            configure = stack ("exec" : "--" : ghcConfigure)
            ghcConfigure
              | osIsWindows = ghcConfigureWindows
              | osIsMacOS = ghcConfigureMacOS
              | otherwise   = ghcConfigurePosix
            hadrianScripts
              | osIsWindows = hadrianScriptsWindows
              | otherwise   = hadrianScriptsPosix
            hadrianArgs = fmap T.unpack
              [ "-j" <> tshow threads   -- parallel build
              , "--flavour=" <> flavour -- selected flavour
              , "binary-dist"
              ]
        foundHadrianPaths <-
          filterM doesFileExist $ (cwd </>) <$> hadrianScripts
        hadrianPath <- maybe (prettyThrowIO HadrianScriptNotFound) pure $
          listToMaybe foundHadrianPaths
        exists <- doesFileExist ghcBootScriptPath
        unless exists $ prettyThrowIO GhcBootScriptNotFound
        ensureConfigureScript cwd
        logInfo "Running GHC boot script..."
        boot
        doesExecutableExist "happy" >>= \case
          True -> logInfo "happy executable installed on the PATH."
          False -> do
            logInfo "Installing happy executable..."
            happy
        doesExecutableExist "alex" >>= \case
          True -> logInfo "alex executable installed on the PATH."
          False -> do
            logInfo "Installing alex executable..."
            alex
        logInfo "Running GHC configure script..."
        configure
        logSticky $
             "Building GHC from source with `"
          <> display flavour
          <> "` 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.
        proc (toFilePath hadrianPath) hadrianArgs runProcess_

        -- find the bindist and install it
        bindistPath <- parseRelDir "_build/bindist"
        (_,files) <- listDir (cwd </> bindistPath)
        let isBindist p = do
              extension <- fileExtension (filename p)

              pure $
                   "ghc-" `isPrefixOf` toFilePath (filename p)
                && extension == ".xz"

        mbindist <- filterM isBindist files
        case mbindist of
          [bindist] -> do
            let bindist' = T.pack (toFilePath bindist)
                dlinfo = DownloadInfo
                          { downloadInfoUrl           = bindist'
                            -- we can specify a filepath instead of a URL
                          , downloadInfoContentLength = Nothing
                          , downloadInfoSha1          = Nothing
                          , downloadInfoSha256        = Nothing
                          }
                ghcdlinfo = GHCDownloadInfo mempty mempty dlinfo
                installer
                   | osIsWindows = installGHCWindows
                   | otherwise   = installGHCPosix ghcdlinfo
            si <- runMemoized getSetupInfo'
            _ <- downloadAndInstallTool
              (configLocalPrograms config)
              dlinfo
              compilerTool
              (installer si)
            pure (compilerTool, CompilerBuildStandard)
          _ -> do
            forM_ files (logDebug . fromString . (" - " ++) . toFilePath)
            prettyThrowIO HadrianBindistNotFound

-- | Determine which GHC builds to use depending on which shared libraries are
-- available on the system.
getGhcBuilds :: HasConfig env => RIO env [CompilerBuild]
getGhcBuilds = do
  config <- view configL
  case configGHCBuild config of
    Just ghcBuild -> pure [ghcBuild]
    Nothing -> determineGhcBuild
 where
  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 <- view platformL
    case platform of
      Platform _ 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 m = Map.insert
              "PATH"
              ("/sbin:/usr/sbin" <> maybe "" (":" <>) (Map.lookup "PATH" m))
              m
        eldconfigOut <- withModifyEnvVars sbinEnv
          $ proc "ldconfig" ["-p"]
          $ tryAny . fmap fst . readProcess_
        let firstWords = case eldconfigOut of
              Right ldconfigOut -> mapMaybe (listToMaybe . T.words) $
                T.lines $ T.decodeUtf8With T.lenientDecode
                        $ LBS.toStrict ldconfigOut
              Left _ -> []
            checkLib lib
              | libT `elem` firstWords = do
                  logDebug $
                       "Found shared library "
                    <> libD
                    <> " in 'ldconfig -p' output"
                  pure True
              | osIsWindows =
                  -- Cannot parse /usr/lib on Windows
                  pure False
              | otherwise = hasMatches lib usrLibDirs
              -- 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.
             where
              libD = fromString (toFilePath lib)
              libT = T.pack (toFilePath lib)
            hasMatches lib dirs = do
              matches <- filterM (doesFileExist .(</> lib)) dirs
              case matches of
                [] ->
                     logDebug
                       (  "Did not find shared library "
                       <> libD
                       )
                  >> pure False
                (path:_) ->
                     logDebug
                       (  "Found shared library "
                       <> libD
                       <> " in "
                       <> fromString (Path.toFilePath path)
                       )
                  >> pure True
             where
              libD = fromString (toFilePath lib)
            getLibc6Version = do
              elddOut <-
                -- On Alpine Linux, 'ldd --version' will send output to stderr,
                -- which we wish to smother.
                proc "ldd" ["--version"] $ tryAny . readProcess_
              pure $ case elddOut of
                Right (lddOut, _) ->
                  let lddOut' =
                        decodeUtf8Lenient (LBS.toStrict lddOut)
                  in  case P.parse lddVersion lddOut' of
                        P.Done _ result -> Just result
                        _ -> Nothing
                Left _ -> Nothing
            -- Assumes the first line of ldd has the format:
            --
            -- ldd (...) nn.nn
            --
            -- where nn.nn corresponds to the version of libc6.
            lddVersion :: P.Parser Version
            lddVersion = do
              P.skipWhile (/= ')')
              P.skip (== ')')
              P.skipSpace
              lddMajorVersion <- P.decimal
              P.skip (== '.')
              lddMinorVersion <- P.decimal
              P.skip (not . isDigit)
              pure $ mkVersion [ lddMajorVersion, lddMinorVersion ]
        hasMusl <- hasMatches relFileLibcMuslx86_64So1 libDirs
        mLibc6Version <- getLibc6Version
        case mLibc6Version of
          Just libc6Version -> logDebug $
               "Found shared library libc6 in version: "
            <> fromString (versionString libc6Version)
          Nothing -> logDebug
            "Did not find a version of shared library libc6."
        let hasLibc6_2_32 =
              maybe False (>= mkVersion [2 , 32]) mLibc6Version
        hastinfo5 <- checkLib relFileLibtinfoSo5
        hastinfo6 <- checkLib relFileLibtinfoSo6
        hasncurses6 <- checkLib relFileLibncurseswSo6
        hasgmp5 <- checkLib relFileLibgmpSo10
        hasgmp4 <- checkLib relFileLibgmpSo3
        let libComponents = if hasMusl
              then
                [ ["musl"] ]
              else
                concat
                  [ if hastinfo6 && hasgmp5
                      then
                        if hasLibc6_2_32
                          then [["tinfo6"]]
                          else [["tinfo6-libc6-pre232"]]
                      else [[]]
                  , [ [] | hastinfo5 && hasgmp5 ]
                  , [ ["ncurses6"] | hasncurses6 && hasgmp5 ]
                  , [ ["gmp4"] | hasgmp4 ]
                  ]
        useBuilds $ map
          (\c -> case c of
            [] -> CompilerBuildStandard
            _ -> CompilerBuildSpecialized (intercalate "-" c))
          libComponents
      Platform _ Cabal.FreeBSD -> do
        let getMajorVer = readMaybe <=< headMaybe . splitOn "."
        majorVer <- getMajorVer <$> sysRelease
        if majorVer >= Just (12 :: Int)
          then
            useBuilds [CompilerBuildSpecialized "ino64"]
          else
            useBuilds [CompilerBuildStandard]
      Platform _ Cabal.OpenBSD -> do
        releaseStr <- mungeRelease <$> sysRelease
        useBuilds [CompilerBuildSpecialized releaseStr]
      _ -> useBuilds [CompilerBuildStandard]
  useBuilds builds = do
    logDebug $
         "Potential GHC builds: "
      <> mconcat (intersperse ", " (map (fromString . compilerBuildName) builds))
    pure 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 = intercalate "-" . prefixMaj . splitOn "."
 where
  prefixFst pfx k (rev : revs) = (pfx ++ rev) : k revs
  prefixFst _ _ [] = []
  prefixMaj = prefixFst "maj" prefixMin
  prefixMin = prefixFst "min" (map ('r':))

sysRelease :: HasTerm env => RIO env String
sysRelease =
  handleIO
    ( \e -> do
        prettyWarn $
             flow "Could not query OS version:"
          <> blankLine
          <> string (displayException e)
        pure ""
    )
    (liftIO getRelease)

-- | Ensure Docker container-compatible 'stack' executable is downloaded
ensureDockerStackExe :: HasConfig env => Platform -> RIO env (Path Abs File)
ensureDockerStackExe containerPlatform = do
  config <- view configL
  containerPlatformDir <-
    runReaderT platformOnlyRelDir (containerPlatform,PlatformVariantNone)
  let programsPath = configLocalProgramsBase config </> containerPlatformDir
      tool = Tool (PackageIdentifier (mkPackageName "stack") stackVersion)
  stackExeDir <- installDir programsPath tool
  let stackExePath = stackExeDir </> relFileStack
  stackExeExists <- doesFileExist stackExePath
  unless stackExeExists $ do
    prettyInfoL
      [ flow "Downloading Docker-compatible"
      , fromString stackProgName
      , "executable."
      ]
    sri <-
      downloadStackReleaseInfo
        Nothing
        Nothing
        (Just (versionString stackMinorVersion))
    platforms <-
      runReaderT preferredPlatforms (containerPlatform, PlatformVariantNone)
    downloadStackExe platforms sri stackExeDir False (const $ pure ())
  pure stackExePath

-- | Get all executables on the path that might match the wanted compiler
sourceSystemCompilers ::
     (HasLogFunc env, HasProcessContext env)
  => WantedCompiler
  -> ConduitT i (Path Abs File) (RIO env) ()
sourceSystemCompilers wanted = do
  searchPath <- view exeSearchPathL
  names <-
    case wanted of
      WCGhc version -> pure
        [ "ghc-" ++ versionString version
        , "ghc"
        ]
      WCGhcjs{} -> throwIO GhcjsNotSupported
      WCGhcGit{} -> pure [] -- only use sandboxed versions
  for_ names $ \name -> for_ searchPath $ \dir -> do
    fp <- resolveFile' $ addExe $ dir FP.</> name
    exists <- doesFileExist fp
    when exists $ yield fp
 where
  addExe
    | osIsWindows = (++ ".exe")
    | otherwise = id

-- | Download the most recent SetupInfo
getSetupInfo :: HasConfig env => RIO env SetupInfo
getSetupInfo = do
  config <- view configL
  let inlineSetupInfo = configSetupInfoInline config
      locations' = configSetupInfoLocations config
      locations = if null locations' then [defaultSetupInfoYaml] else locations'

  resolvedSetupInfos <- mapM loadSetupInfo locations
  pure (inlineSetupInfo <> mconcat resolvedSetupInfos)
 where
  loadSetupInfo urlOrFile = do
    bs <- case parseUrlThrow urlOrFile of
            Just req -> LBS.toStrict . getResponseBody <$> httpLbs req
            Nothing -> liftIO $ S.readFile urlOrFile
    WithJSONWarnings si warnings <- either throwM pure (Yaml.decodeEither' bs)
    when (urlOrFile /= defaultSetupInfoYaml) $
      logJSONWarnings urlOrFile warnings
    pure si

getInstalledTool ::
     [Tool]            -- ^ already installed
  -> PackageName       -- ^ package to find
  -> (Version -> Bool) -- ^ which versions are acceptable
  -> Maybe Tool
getInstalledTool installed name goodVersion = Tool <$>
  maximumByMaybe (comparing pkgVersion) (filterTools name goodVersion 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 programsDir downloadInfo tool installer = do
  ensureDir programsDir
  (file, at) <- downloadFromInfo programsDir downloadInfo tool
  dir <- installDir programsDir tool
  tempDir <- tempInstallDir programsDir tool
  liftIO $ ignoringAbsence (removeDirRecur tempDir)
  ensureDir tempDir
  unmarkInstalled programsDir tool
  installer file at tempDir dir
  markInstalled programsDir tool
  liftIO $ ignoringAbsence (removeDirRecur tempDir)
  pure tool

-- Exceptions thrown by this function are caught by
-- 'downloadAndInstallPossibleCompilers'.
downloadAndInstallCompiler ::
     (HasBuildConfig env, HasGHCVariant env)
  => CompilerBuild
  -> SetupInfo
  -> WantedCompiler
  -> VersionCheck
  -> Maybe String
  -> RIO env Tool
downloadAndInstallCompiler ghcBuild si wanted@(WCGhc version) versionCheck mbindistURL = do
  ghcVariant <- view ghcVariantL
  (selectedVersion, downloadInfo) <- case mbindistURL of
    Just bindistURL -> do
      case ghcVariant of
        GHCCustom _ -> pure ()
        _ -> throwM RequireCustomGHCVariant
      pure
        ( version
        , GHCDownloadInfo mempty mempty DownloadInfo
            { downloadInfoUrl = T.pack bindistURL
            , downloadInfoContentLength = Nothing
            , downloadInfoSha1 = Nothing
            , downloadInfoSha256 = Nothing
            }
        )
    _ -> do
      ghcKey <- getGhcKey ghcBuild
      case Map.lookup ghcKey $ siGHCs si of
        Nothing -> throwM $ UnknownOSKey ghcKey
        Just pairs_ ->
          getWantedCompilerInfo ghcKey versionCheck wanted ACGhc pairs_
  config <- view configL
  let installer =
        case configPlatform config of
          Platform _ Cabal.Windows -> installGHCWindows
          _ -> installGHCPosix downloadInfo
  prettyInfo $
    fillSep $
         flow "Preparing to install GHC"
      :  case ghcVariant of
           GHCStandard -> []
           v -> ["(" <> fromString (ghcVariantName v) <> ")"]
      <> case ghcBuild of
           CompilerBuildStandard -> []
           b -> ["(" <> fromString (compilerBuildName b) <> ")"]
      <> [ flow "to an isolated location. This will not interfere with any \
                \system-level installation."
         ]
  ghcPkgName <- parsePackageNameThrowing
    ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild)
  let tool = Tool $ PackageIdentifier ghcPkgName selectedVersion
  downloadAndInstallTool
    (configLocalPrograms config)
    (gdiDownloadInfo downloadInfo)
    tool
    (installer si)

downloadAndInstallCompiler _ _ WCGhcjs{} _ _ = throwIO GhcjsNotSupported

downloadAndInstallCompiler _ _ WCGhcGit{} _ _ =
  throwIO DownloadAndInstallCompilerError

-- Exceptions thrown by this function are caught by
-- 'downloadAndInstallPossibleCompilers'.
getWantedCompilerInfo ::
     (Ord k, MonadThrow m)
  => Text
  -> VersionCheck
  -> WantedCompiler
  -> (k -> ActualCompiler)
  -> Map k a
  -> m (k, a)
getWantedCompilerInfo key versionCheck wanted toCV pairs_ =
  case mpair of
    Just pair -> pure pair
    Nothing -> throwM $
      UnknownCompilerVersion
        (Set.singleton key)
        wanted
        (Set.fromList $ map toCV (Map.keys pairs_))
 where
  mpair =
    listToMaybe $
    sortOn (Down . fst) $
    filter
      (isWantedCompiler versionCheck wanted . toCV . fst)
      (Map.toList 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 possibleCompilers si wanted versionCheck mbindistURL =
  go possibleCompilers 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 [] Nothing = prettyThrowM UnsupportedSetupConfiguration
  go [] (Just e) = prettyThrowM e
  go (b:bs) e = do
    logDebug $ "Trying to setup GHC build: " <> fromString (compilerBuildName b)
    er <- try $ downloadAndInstallCompiler b si wanted versionCheck mbindistURL
    case er of
      Left e'@(UnknownCompilerVersion ks' w' vs') ->
        case e of
          Nothing -> go bs (Just e')
          Just (UnknownOSKey k) ->
            go bs $ Just $ UnknownCompilerVersion (Set.insert k ks') w' vs'
          Just (UnknownCompilerVersion ks _ vs) ->
            go bs $ Just $
              UnknownCompilerVersion (Set.union ks' ks) w' (Set.union vs' vs)
          Just x -> prettyThrowM x
      Left e'@(UnknownOSKey k') ->
        case e of
          Nothing -> go bs (Just e')
          Just (UnknownOSKey _) -> go bs e
          Just (UnknownCompilerVersion ks w vs) ->
            go bs $ Just $ UnknownCompilerVersion (Set.insert k' ks) w vs
          Just x -> prettyThrowM x
      Left e' -> prettyThrowM e'
      Right r -> pure (r, b)

getGhcKey ::
     (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m)
  => CompilerBuild
  -> m Text
getGhcKey ghcBuild = do
  ghcVariant <- view ghcVariantL
  platform <- view platformL
  osKey <- getOSKey platform
  pure $
       osKey
    <> T.pack (ghcVariantSuffix ghcVariant)
    <> T.pack (compilerBuildSuffix ghcBuild)

getOSKey :: (MonadThrow m) => Platform -> m Text
getOSKey platform =
  case platform of
    Platform I386                  Cabal.Linux   -> pure "linux32"
    Platform X86_64                Cabal.Linux   -> pure "linux64"
    Platform I386                  Cabal.OSX     -> pure "macosx"
    Platform X86_64                Cabal.OSX     -> pure "macosx"
    Platform I386                  Cabal.FreeBSD -> pure "freebsd32"
    Platform X86_64                Cabal.FreeBSD -> pure "freebsd64"
    Platform I386                  Cabal.OpenBSD -> pure "openbsd32"
    Platform X86_64                Cabal.OpenBSD -> pure "openbsd64"
    Platform I386                  Cabal.Windows -> pure "windows32"
    Platform X86_64                Cabal.Windows -> pure "windows64"
    Platform Arm                   Cabal.Linux   -> pure "linux-armv7"
    Platform AArch64               Cabal.Linux   -> pure "linux-aarch64"
    Platform Sparc                 Cabal.Linux   -> pure "linux-sparc"
    Platform AArch64               Cabal.OSX     -> pure "macosx-aarch64"
    Platform AArch64               Cabal.FreeBSD -> pure "freebsd-aarch64"
    Platform arch os -> prettyThrowM $ UnsupportedSetupCombo os arch

downloadOrUseLocal ::
     (HasTerm env, HasBuildConfig env)
  => Text
  -> DownloadInfo
  -> Path Abs File
  -> RIO env (Path Abs File)
downloadOrUseLocal downloadLabel downloadInfo destination =
  case url of
    (parseUrlThrow -> Just _) -> do
      ensureDir (parent destination)
      chattyDownload downloadLabel downloadInfo destination
      pure destination
    (parseAbsFile -> Just path) -> do
      warnOnIgnoredChecks
      pure path
    (parseRelFile -> Just path) -> do
      warnOnIgnoredChecks
      root <- view projectRootL
      pure (root </> path)
    _ -> prettyThrowIO $ URLInvalid url
 where
  url = T.unpack $ downloadInfoUrl downloadInfo
  warnOnIgnoredChecks = do
    let DownloadInfo
          { downloadInfoContentLength = contentLength
          , downloadInfoSha1 = sha1
          , downloadInfoSha256 = sha256
          } = downloadInfo
    when (isJust contentLength) $
      prettyWarnS
        "`content-length` is not checked and should not be specified when \
        \`url` is a file path."
    when (isJust sha1) $
      prettyWarnS
        "`sha1` is not checked and should not be specified when `url` is a \
        \file path."
    when (isJust sha256) $
      prettyWarn
        "`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 programsDir downloadInfo tool = do
  archiveType <-
    case extension of
      ".tar.xz" -> pure TarXz
      ".tar.bz2" -> pure TarBz2
      ".tar.gz" -> pure TarGz
      ".7z.exe" -> pure SevenZ
      _ -> prettyThrowIO $ UnknownArchiveExtension url

  relativeFile <- parseRelFile $ toolString tool ++ extension
  let destinationPath = programsDir </> relativeFile
  localPath <-
    downloadOrUseLocal (T.pack (toolString tool)) downloadInfo destinationPath
  pure (localPath, archiveType)

 where
  url = T.unpack $ downloadInfoUrl downloadInfo
  extension = loop url
   where
    loop fp
      | ext `elem` [".tar", ".bz2", ".xz", ".exe", ".7z", ".gz"] = loop fp' ++ ext
      | otherwise = ""
     where
      (fp', ext) = FP.splitExtension 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 downloadInfo _ archiveFile archiveType tempDir destDir = do
  platform <- view platformL
  menv0 <- view processContextL
  menv <- mkProcessContext (removeHaskellEnvVars (view envVarsL menv0))
  logDebug $ "menv = " <> displayShow (view envVarsL menv)
  (zipTool', compOpt) <-
    case archiveType of
      TarXz -> pure ("xz", 'J')
      TarBz2 -> pure ("bzip2", 'j')
      TarGz -> pure ("gzip", 'z')
      SevenZ -> prettyThrowIO Unsupported7z
  -- Slight hack: OpenBSD's tar doesn't support xz.
  -- https://github.com/commercialhaskell/stack/issues/2283#issuecomment-237980986
  let tarDep =
        case (platform, archiveType) of
          (Platform _ Cabal.OpenBSD, TarXz) -> checkDependency "gtar"
          _ -> checkDependency "tar"
  (zipTool, makeTool, tarTool) <- checkDependencies $ (,,)
    <$> checkDependency zipTool'
    <*> (checkDependency "gmake" <|> checkDependency "make")
    <*> tarDep

  logDebug $ "ziptool: " <> fromString zipTool
  logDebug $ "make: " <> fromString makeTool
  logDebug $ "tar: " <> fromString tarTool

  let runStep step wd env cmd args = do
        menv' <- modifyEnvVars menv (Map.union env)
        let logLines lvl = CB.lines .| CL.mapM_ (lvl . displayBytesUtf8)
            logStdout = logLines logDebug
            logStderr = logLines logError
        void $ withWorkingDir (toFilePath wd) $
          withProcessContext menv' $
          sinkProcessStderrStdout cmd args logStderr logStdout
          `catchAny` \ex ->
            prettyThrowIO (GHCInstallFailed ex step cmd args wd tempDir destDir)

  logSticky $
       "Unpacking GHC into "
    <> fromString (toFilePath tempDir)
    <> " ..."
  logDebug $ "Unpacking " <> fromString (toFilePath archiveFile)
  runStep "unpacking" tempDir
    mempty
    tarTool
    [compOpt : "xf", toFilePath archiveFile]

  dir <- expectSingleUnpackedDir archiveFile tempDir

  mOverrideGccPath <- view $ configL.to configOverrideGccPath

  -- The make application uses the CC environment variable to configure the
  -- program for compiling C programs
  let mGccEnv = let gccEnvFromPath p =
                      Map.singleton "CC" $ T.pack (toFilePath p)
                in  gccEnvFromPath <$> mOverrideGccPath

  -- Data.Map.union provides a left-biased union, so mGccEnv will prevail
  let ghcConfigureEnv =
        fromMaybe Map.empty mGccEnv `Map.union` gdiConfigureEnv downloadInfo

  logSticky "Configuring GHC ..."
  runStep "configuring" dir
    ghcConfigureEnv
    (toFilePath $ dir </> relFileConfigure)
    ( ("--prefix=" ++ toFilePath destDir)
    : map T.unpack (gdiConfigureOpts downloadInfo)
    )

  logSticky "Installing GHC ..."
  runStep "installing" dir mempty makeTool ["install"]

  logStickyDone "Installed GHC."
  logDebug $ "GHC installed to " <> fromString (toFilePath destDir)

-- | Check if given processes appear to be present, throwing an exception if
-- missing.
checkDependencies :: CheckDependency env a -> RIO env a
checkDependencies (CheckDependency f) =
  f >>= either (prettyThrowIO . MissingDependencies) pure

checkDependency :: HasProcessContext env => String -> CheckDependency env String
checkDependency tool = CheckDependency $ do
  exists <- doesExecutableExist tool
  pure $ if exists then Right tool else Left [tool]

newtype CheckDependency env a
  = CheckDependency (RIO env (Either [String] a))
  deriving Functor

instance Applicative (CheckDependency env) where
  pure x = CheckDependency $ pure (Right x)
  CheckDependency f <*> CheckDependency x = CheckDependency $ do
    f' <- f
    x' <- x
    pure $
      case (f', x') of
        (Left e1, Left e2) -> Left $ e1 ++ e2
        (Left e, Right _) -> Left e
        (Right _, Left e) -> Left e
        (Right f'', Right x'') -> Right $ f'' x''

instance Alternative (CheckDependency env) where
  empty = CheckDependency $ pure $ Left []
  CheckDependency x <|> CheckDependency y = CheckDependency $ do
    res1 <- x
    case res1 of
      Left _ -> y
      Right x' -> pure $ Right x'

installGHCWindows ::
     HasBuildConfig env
  => SetupInfo
  -> Path Abs File
  -> ArchiveType
  -> Path Abs Dir
  -> Path Abs Dir
  -> RIO env ()
installGHCWindows si archiveFile archiveType _tempDir destDir = do
  withUnpackedTarball7z "GHC" si archiveFile archiveType destDir
  prettyInfoL
    [ flow "GHC installed to"
    , pretty destDir <> "."
    ]

installMsys2Windows ::
     HasBuildConfig env
  => SetupInfo
  -> Path Abs File
  -> ArchiveType
  -> Path Abs Dir
  -> Path Abs Dir
  -> RIO env ()
installMsys2Windows si archiveFile archiveType _tempDir destDir = do
  exists <- liftIO $ D.doesDirectoryExist $ toFilePath destDir
  when exists $
    liftIO (D.removeDirectoryRecursive $ toFilePath destDir) `catchIO` \e ->
      prettyThrowM $ ExistingMSYS2NotDeleted destDir e

  withUnpackedTarball7z "MSYS2" si archiveFile archiveType 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.
  menv0 <- view processContextL
  newEnv0 <- modifyEnvVars menv0 $ Map.insert "MSYSTEM" "MSYS"
  newEnv <- either throwM pure $ augmentPathMap
              [toFilePath $ destDir </> relDirUsr </> relDirBin]
              (view envVarsL newEnv0)
  menv <- mkProcessContext newEnv
  withWorkingDir (toFilePath destDir) $ withProcessContext menv
    $ proc "sh" ["--login", "-c", "true"] 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 name si archiveFile archiveType destDir = do
  suffix <-
    case archiveType of
      TarXz -> pure ".xz"
      TarBz2 -> pure ".bz2"
      TarGz -> pure ".gz"
      _ -> prettyThrowIO $ TarballInvalid name
  tarFile <-
    case T.stripSuffix suffix $ T.pack $ toFilePath (filename archiveFile) of
      Nothing -> prettyThrowIO $ TarballFileInvalid name archiveFile
      Just x -> parseRelFile $ T.unpack x
  run7z <- setup7z si
  -- We use a short name for the temporary directory to reduce the risk of a
  -- filepath length of more than 260 characters, which can be problematic for
  -- 7-Zip even if Long Filepaths are enabled on Windows.
  let tmpName = "stack-tmp"
      destDrive = fromJust $ parseAbsDir $ takeDrive $ fromAbsDir destDir
  ensureDir (parent destDir)
  withRunInIO $ \run ->
  -- We use a temporary directory in the same drive as that of 'destDir' to
  -- reduce the risk of a filepath length of more than 260 characters, which can
  -- be problematic for 7-Zip even if Long Filepaths are enabled on Windows. We
  -- do not use the system temporary directory as it may be on a different
  -- drive.
    withTempDir destDrive tmpName $ \tmpDir ->
      run $ do
        liftIO $ ignoringAbsence (removeDirRecur destDir)
        run7z tmpDir archiveFile
        run7z tmpDir (tmpDir </> tarFile)
        absSrcDir <- expectSingleUnpackedDir archiveFile tmpDir
        -- On Windows, 'renameDir' does not work across drives. However, we have
        -- ensured that 'tmpDir' has the same drive as 'destDir'.
        renameDir absSrcDir destDir

expectSingleUnpackedDir ::
     (MonadIO m, MonadThrow m)
  => Path Abs File
  -> Path Abs Dir
  -> m (Path Abs Dir)
expectSingleUnpackedDir archiveFile unpackDir = do
  contents <- listDir unpackDir
  case contents of
    ([dir], _ ) -> pure dir
    _ -> prettyThrowIO $ UnknownArchiveStructure 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 si = do
  dir <- view $ configL.to configLocalPrograms
  ensureDir dir
  let exeDestination = dir </> relFile7zexe
      dllDestination = dir </> relFile7zdll
  case (siSevenzDll si, siSevenzExe si) of
    (Just sevenzDll, Just sevenzExe) -> do
      _ <- downloadOrUseLocal "7z.dll" sevenzDll dllDestination
      exePath <- downloadOrUseLocal "7z.exe" sevenzExe exeDestination
      withRunInIO $ \run -> pure $ \outdir archive -> liftIO $ run $ do
        let cmd = toFilePath exePath
            args =
              [ "x"
              , "-o" ++ toFilePath outdir
              , "-y"
              , archiveFP
              ]
            archiveFP = toFilePath archive
            archiveFileName = filename archive
            archiveDisplay = fromString $ toFilePath archiveFileName
            isExtract = FP.takeExtension archiveFP == ".tar"
        prettyInfoL
          [ if isExtract then "Extracting" else "Decompressing"
          , pretty archiveFileName <> "..."
          ]
        ec <-
          proc cmd args $ \pc ->
          if isExtract
            then withProcessWait (setStdout createSource pc) $ \p -> do
              total <- runConduit
                 $ getStdout p
                .| filterCE (== 10) -- newline characters
                .| foldMC
                     (\count bs -> do
                         let count' = count + S.length bs
                         logSticky $ "Extracted " <> display count' <> " files"
                         pure count'
                     )
                     0
              logStickyDone $
                   "Extracted total of "
                <> display total
                <> " files from "
                <> archiveDisplay
              waitExitCode p
            else runProcess pc
        when (ec /= ExitSuccess) $
          liftIO $ prettyThrowM (ProblemWhileDecompressing archive)
    _ -> prettyThrowM SetupInfoMissingSevenz

chattyDownload ::
     HasTerm env
  => Text          -- ^ label
  -> DownloadInfo  -- ^ URL, content-length, sha1, and sha256
  -> Path Abs File -- ^ destination
  -> RIO env ()
chattyDownload label downloadInfo path = do
  let url = downloadInfoUrl downloadInfo
  req <- parseUrlThrow $ T.unpack url
  logSticky $
       "Preparing to download "
    <> display label
    <> " ..."
  logDebug $
       "Downloading from "
    <> display url
    <> " to "
    <> fromString (toFilePath path)
    <> " ..."
  hashChecks <- fmap catMaybes $ forM
    [ ("sha1",   HashCheck SHA1,   downloadInfoSha1)
    , ("sha256", HashCheck SHA256, downloadInfoSha256)
    ]
    $ \(name, constr, getter) ->
      case getter downloadInfo of
        Just bs -> do
          logDebug $
               "Will check against "
            <> name
            <> " hash: "
            <> displayBytesUtf8 bs
          pure $ Just $ constr $ CheckHexDigestByteString bs
        Nothing -> pure Nothing
  when (null hashChecks) $
    prettyWarnS
      "No sha1 or sha256 found in metadata, download hash won't be checked."
  let dReq = setHashChecks hashChecks $
             setLengthCheck mtotalSize $
             mkDownloadRequest req
  x <- verifiedDownloadWithProgress dReq path label mtotalSize
  if x
    then logStickyDone ("Downloaded " <> display label <> ".")
    else logStickyDone ("Already downloaded " <> display label <> ".")
 where
  mtotalSize = downloadInfoContentLength downloadInfo

-- | Perform a basic sanity check of GHC
sanityCheck ::
     (HasLogFunc env, HasProcessContext env)
  => Path Abs File
  -> RIO env ()
sanityCheck ghc = withSystemTempDir "stack-sanity-check" $ \dir -> do
  let fp = toFilePath $ dir </> relFileMainHs
  liftIO $ S.writeFile fp $ T.encodeUtf8 $ T.pack $ unlines
    [ "import Distribution.Simple" -- ensure Cabal library is present
    , "main = putStrLn \"Hello World\""
    ]
  logDebug $ "Performing a sanity check on: " <> fromString (toFilePath ghc)
  eres <- withWorkingDir (toFilePath dir) $ proc (toFilePath ghc)
    [ fp
    , "-no-user-package-db"
    -- Required to stop GHC looking for a package environment in default
    -- locations.
    , "-hide-all-packages"
    -- Required because GHC flag -hide-all-packages is passed.
    , "-package base"
    , "-package Cabal" -- required for "import Distribution.Simple"
    ] $ try . readProcess_
  case eres of
    Left e -> prettyThrowIO $ GHCSanityCheckCompileFailed e ghc
    Right _ -> pure () -- 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.delete "GHC_PACKAGE_PATH" .
  Map.delete "GHC_ENVIRONMENT" .
  Map.delete "HASKELL_PACKAGE_SANDBOX" .
  Map.delete "HASKELL_PACKAGE_SANDBOXES" .
  Map.delete "HASKELL_DIST_DIR" .
  -- https://github.com/commercialhaskell/stack/issues/1460
  Map.delete "DESTDIR" .
  -- https://github.com/commercialhaskell/stack/issues/3444
  Map.delete "GHCRTS"

-- | Get map of environment variables to set to change the GHC's encoding to
-- UTF-8.
getUtf8EnvVars ::
     (HasPlatform env, HasProcessContext env, HasTerm env)
  => ActualCompiler
  -> RIO env (Map Text Text)
getUtf8EnvVars compilerVer =
  if getGhcVersion compilerVer >= mkVersion [7, 10, 3]
    -- GHC_CHARENC supported by GHC >=7.10.3
    then pure $ Map.singleton "GHC_CHARENC" "UTF-8"
    else legacyLocale
 where
  legacyLocale = do
    menv <- view processContextL
    Platform _ os <- view platformL
    if os == Cabal.Windows
      then
        -- On Windows, locale is controlled by the code page, so we don't set
        -- any environment variables.
        pure Map.empty
      else do
        let checkedVars = map checkVar (Map.toList $ view envVarsL menv)
            -- List of environment variables that will need to be updated to set
            -- UTF-8 (because they currently do not specify UTF-8).
            needChangeVars = concatMap fst checkedVars
            -- Set of locale-related environment variables that have already
            -- have a value.
            existingVarNames = Set.unions (map snd checkedVars)
            -- True if a locale is already specified by one of the "global"
            -- locale variables.
            hasAnyExisting =
              any (`Set.member` existingVarNames) ["LANG", "LANGUAGE", "LC_ALL"]
        if null needChangeVars && hasAnyExisting
          then
            -- If no variables need changes and at least one "global" variable
            -- is set, no changes to environment need to be made.
            pure Map.empty
          else do
            -- Get a list of known locales by running @locale -a@.
            elocales <- tryAny (fst <$> proc "locale" ["-a"] readProcess_)
            let
                -- Filter the list to only include locales with UTF-8 encoding.
                utf8Locales =
                  case elocales of
                    Left _ -> []
                    Right locales ->
                      filter
                        isUtf8Locale
                        ( T.lines $
                          T.decodeUtf8With
                            T.lenientDecode $
                            LBS.toStrict locales
                        )
                mfallback = getFallbackLocale utf8Locales
            when
              (isNothing mfallback)
              ( prettyWarnS
                  "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.unions $
                  map
                    (adjustedVarValue menv utf8Locales mfallback)
                    needChangeVars
                -- Get the values of variables to add.
                adds
                  | hasAnyExisting =
                      -- If we already have a "global" variable, then nothing
                      -- needs to be added.
                      Map.empty
                  | otherwise =
                      -- If we don't already have a "global" variable, then set
                      -- LANG to the fallback.
                      case mfallback of
                        Nothing -> Map.empty
                        Just fallback ->
                          Map.singleton "LANG" fallback
            pure (Map.union changes 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 (k,v) =
    if k `elem` ["LANG", "LANGUAGE"] || "LC_" `T.isPrefixOf` k
      then if isUtf8Locale v
             then ([], Set.singleton k)
             else ([k], Set.singleton k)
      else ([], 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 menv utf8Locales mfallback k =
    case Map.lookup k (view envVarsL menv) of
      Nothing -> Map.empty
      Just v ->
        case concatMap
               (matchingLocales utf8Locales)
               [ T.takeWhile (/= '.') v <> "."
               , T.takeWhile (/= '_') v <> "_"] of
          (v':_) -> Map.singleton k v'
          [] -> case mfallback of
                  Just fallback -> Map.singleton k fallback
                  Nothing -> 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 utf8Locales =
    case concatMap (matchingLocales utf8Locales) fallbackPrefixes of
      (v:_) -> Just v
      [] -> case utf8Locales of
              [] -> Nothing
              (v:_) -> Just v
  -- Filter the list of locales for any with the given prefixes
  -- (case-insensitive).
  matchingLocales :: [Text] -> Text -> [Text]
  matchingLocales utf8Locales prefix =
    filter (\v -> T.toLower prefix `T.isPrefixOf` T.toLower v) utf8Locales
  -- Does the locale have one of the encodings in @utf8Suffixes@
  -- (case-insensitive)?
  isUtf8Locale locale =
    any (\ v -> T.toLower v `T.isSuffixOf` T.toLower locale) utf8Suffixes
  -- Prefixes of fallback locales (case-insensitive)
  fallbackPrefixes = ["C.", "en_US.", "en_"]
  -- Suffixes of UTF-8 locales (case-insensitive)
  utf8Suffixes = [".UTF-8", ".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
  { hsoUrl :: !Text
  , hsoVersion :: !Version
  }
  deriving Show

downloadStackReleaseInfo ::
     (HasLogFunc env, HasPlatform env)
  => Maybe String -- GitHub org
  -> Maybe String -- GitHub repo
  -> Maybe String -- ^ optional version
  -> RIO env StackReleaseInfo
downloadStackReleaseInfo Nothing Nothing Nothing = do
  platform <- view platformL
  -- Fallback list of URLs to try for upgrading.
  let urls0 =
        case platform of
          Platform X86_64 Cabal.Linux ->
            [ "https://get.haskellstack.org/upgrade/linux-x86_64-static.tar.gz"
            , "https://get.haskellstack.org/upgrade/linux-x86_64.tar.gz"
            ]
          Platform X86_64 Cabal.OSX ->
            [ "https://get.haskellstack.org/upgrade/osx-x86_64.tar.gz"
            ]
          Platform X86_64 Cabal.Windows ->
            [ "https://get.haskellstack.org/upgrade/windows-x86_64.tar.gz"
            ]
          _ -> []
      -- Helper function: extract the version from a GitHub releases URL.
  let extractVersion loc = do
        version0 <-
          case reverse $ splitOn "/" $ T.unpack loc of
            _final:version0:_ -> Right version0
            _ -> Left $ "Insufficient pieces in location: " ++ show loc
        version1 <-
          maybe (Left "no leading v on version") Right $ stripPrefix "v" version0
        maybe (Left $ "Invalid version: " ++ show version1) Right $ parseVersion version1

      -- Try out different URLs. If we've exhausted all of them, fall back to GitHub.
      loop [] = do
        logDebug "Could not get binary from haskellstack.org, trying GitHub"
        downloadStackReleaseInfoGitHub Nothing Nothing Nothing

      -- Try the next URL
      loop (url:urls) = do
        -- Make a HEAD request without any redirects
        req <- setRequestMethod "HEAD" <$> parseRequest (T.unpack url)
        res <- httpLbs req { redirectCount = 0 }

        -- Look for a redirect. We're looking for a standard GitHub releases
        -- URL where we can extract version information from.
        case getResponseHeader "location" res of
          [] -> logDebug "No location header found, continuing" *> loop urls
          -- Exactly one location header.
          [locBS] ->
            case decodeUtf8' locBS of
              Left e ->
                   logDebug
                     (   "Invalid UTF8: "
                     <> displayShow (locBS, e)
                     )
                *> loop urls
              Right loc ->
                case extractVersion loc of
                  Left s ->
                       logDebug
                         (   "No version found: "
                         <> displayShow (url, loc, s)
                         )
                    *> loop (loc:urls)
                  -- We found a valid URL, let's use it!
                  Right version -> do
                    let hso = HaskellStackOrg
                                { hsoUrl = loc
                                , hsoVersion = version
                                }
                    logDebug $
                         "Downloading from haskellstack.org: "
                      <> displayShow hso
                    pure $ SRIHaskellStackOrg hso
          locs ->
               logDebug
                 (  "Multiple location headers found: "
                 <> displayShow locs
                 )
            *> loop urls
  loop urls0
downloadStackReleaseInfo morg mrepo mver =
  downloadStackReleaseInfoGitHub morg mrepo 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 morg mrepo mver = liftIO $ do
  let org = fromMaybe "commercialhaskell" morg
      repo = fromMaybe "stack" mrepo
  let url = concat
        [ "https://api.github.com/repos/"
        , org
        , "/"
        , repo
        , "/releases/"
        , case mver of
            Nothing -> "latest"
            Just ver -> "tags/v" ++ ver
        ]
  req <- parseRequest url
  res <- httpJSON $ setGitHubHeaders req
  let code = getResponseStatusCode res
  if code >= 200 && code < 300
    then pure $ SRIGitHub $ getResponseBody res
    else prettyThrowIO $ StackReleaseInfoNotFound url

preferredPlatforms ::
     (MonadReader env m, HasPlatform env, MonadThrow m)
  => m [(Bool, String)]
preferredPlatforms = do
  Platform arch' os' <- view platformL
  (isWindows, os) <-
    case os' of
      Cabal.Linux -> pure (False, "linux")
      Cabal.Windows -> pure (True, "windows")
      Cabal.OSX -> pure (False, "osx")
      Cabal.FreeBSD -> pure (False, "freebsd")
      _ -> prettyThrowM $ BinaryUpgradeOnOSUnsupported os'
  arch <-
    case arch' of
      I386 -> pure "i386"
      X86_64 -> pure "x86_64"
      Arm -> pure "arm"
      AArch64 -> pure "aarch64"
      _ -> prettyThrowM $ BinaryUpgradeOnArchUnsupported arch'
  let hasgmp4 = False -- FIXME import relevant code from Stack.Setup?
                      -- checkLib $(mkRelFile "libgmp.so.3")
      suffixes
          -- 'gmp4' ceased to be relevant after Stack 1.9.3 (December 2018).
        | hasgmp4 = ["-static", "-gmp4", ""]
          -- 'static' will cease to be relevant after Stack 2.11.1 (May 2023).
        | otherwise = ["-static", ""]
  pure $ map (\suffix -> (isWindows, concat [os, "-", arch, suffix])) 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 platforms0 archiveInfo destDir checkPath testExe = do
  (isWindows, archiveURL) <-
    let loop [] =
          prettyThrowIO $ StackBinaryArchiveNotFound (map snd platforms0)
        loop ((isWindows, p'):ps) = do
          let p = T.pack p'
          prettyInfoL
            [ flow "Querying for archive location for platform:"
            , style Current (fromString p') <> "."
            ]
          case findArchive archiveInfo p of
            Just x -> pure (isWindows, x)
            Nothing -> loop ps
    in  loop platforms0

  let (destFile, tmpFile)
        | isWindows =
            ( destDir </> relFileStackDotExe
            , destDir </> relFileStackDotTmpDotExe
            )
        | otherwise =
            ( destDir </> relFileStack
            , destDir </> relFileStackDotTmp
            )

  prettyInfoL
    [ flow "Downloading from:"
    , style Url (fromString $ T.unpack archiveURL) <> "."
    ]

  liftIO $
    if | ".tar.gz" `T.isSuffixOf` archiveURL ->
           handleTarball tmpFile isWindows archiveURL
       | ".zip" `T.isSuffixOf` archiveURL ->
            throwIO StackBinaryArchiveZipUnsupportedBug
       | otherwise -> prettyThrowIO $ StackBinaryArchiveUnsupported archiveURL

  prettyInfoS "Download complete, testing executable."

  -- We need to call getExecutablePath before we overwrite the
  -- currently running binary: after that, Linux will append
  -- (deleted) to the filename.
  currExe <- liftIO getExecutablePath >>= parseAbsFile

  liftIO $ do
    setFileExecutable (toFilePath tmpFile)
    testExe tmpFile

  relocateStackExeFile currExe tmpFile destFile

  prettyInfoL
    [ flow "New Stack executable available at:"
    , pretty destFile <> "."
    ]

  destDir' <- liftIO . D.canonicalizePath . toFilePath $ destDir
  warnInstallSearchPathIssues destDir' ["stack"]

  when checkPath $ performPathChecking destFile currExe
    `catchAny` (logError . displayShow)
 where

  findArchive (SRIGitHub val) platformPattern = do
    Object top <- pure val
    Array assets <- KeyMap.lookup "assets" top
    getFirst $ foldMap (First . findMatch pattern') assets
   where
    pattern' = mconcat ["-", platformPattern, "."]

    findMatch pattern'' (Object o) = do
        String name <- KeyMap.lookup "name" o
        guard $ not $ ".asc" `T.isSuffixOf` name
        guard $ pattern'' `T.isInfixOf` name
        String url <- KeyMap.lookup "browser_download_url" o
        Just url
    findMatch _ _ = Nothing
  findArchive (SRIHaskellStackOrg hso) _ = pure $ hsoUrl hso

  handleTarball :: Path Abs File -> Bool -> T.Text -> IO ()
  handleTarball tmpFile isWindows url = do
    req <- fmap setGitHubHeaders $ parseUrlThrow $ T.unpack url
    withResponse req $ \res -> do
      entries <- fmap (Tar.read . LBS.fromChunks)
        $ lazyConsume
        $ getResponseBody res .| ungzip
      let loop Tar.Done = prettyThrowIO $ StackBinaryNotInArchive exeName url
          loop (Tar.Fail e) = throwM e
          loop (Tar.Next e es) =
            case FP.splitPath (Tar.entryPath e) of
              -- Ignore the first component, see:
              -- https://github.com/commercialhaskell/stack/issues/5288
              [_ignored, name] | name == exeName -> do
                case Tar.entryContent e of
                  Tar.NormalFile lbs _ -> do
                    ensureDir destDir
                    LBS.writeFile (toFilePath tmpFile) lbs
                  _ -> prettyThrowIO $ FileTypeInArchiveInvalid e url
              _ -> loop es
      loop entries
   where
    exeName
      | isWindows = "stack.exe"
      | otherwise = "stack"

relocateStackExeFile ::
     HasTerm env
  => Path Abs File
     -- ^ Path to the currently running executable
  -> Path Abs File
     -- ^ Path to the executable file to be relocated
  -> Path Abs File
     -- ^ Path to the new location for the excutable file
  -> RIO env ()
relocateStackExeFile currExeFile newExeFile destExeFile = do
  when (osIsWindows && destExeFile == currExeFile) $ do
    -- Windows allows a running executable's file to be renamed, but not to be
    -- overwritten.
    old <- addExtension ".old" currExeFile
    prettyInfoL
      [ flow "Renaming existing:"
      , pretty currExeFile
      , "as:"
      , pretty old <> "."
      ]
    renameFile currExeFile old
  renameFile newExeFile destExeFile

-- | 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
     -- ^ Path to the newly downloaded file
  -> Path Abs File
     -- ^ Path to the currently running executable
  -> RIO env ()
performPathChecking newExeFile currExeFile = do
  unless (newExeFile == currExeFile) $ do
    prettyInfoL
      [ flow "Also copying Stack executable to:"
      , pretty currExeFile <> "."
      ]
    tmpFile <- toFilePath <$> addExtension ".tmp" currExeFile
    eres <- tryIO $
      relocateStackExeFile currExeFile newExeFile currExeFile
    case eres of
      Right () -> prettyInfoS "Stack executable copied successfully!"
      Left e
        | isPermissionError e -> if osIsWindows
            then do
              prettyWarn $
                   flow "Permission error when trying to copy:"
                <> blankLine
                <> string (displayException e)
            else do
              prettyWarn $
                   flow "Permission error when trying to copy:"
                <> blankLine
                <> string (displayException e)
                <> blankLine
                <> fillSep
                     [ flow "Should I try to perform the file copy using"
                     , style Shell "sudo" <> "?"
                     , flow "This may fail."
                     ]
              toSudo <- promptBool "Try using sudo? (y/n) "
              when toSudo $ do
                let run cmd args = do
                      ec <- proc cmd args runProcess
                      when (ec /= ExitSuccess) $
                        throwIO $ ProcessExited ec cmd args
                    commands =
                      [ ("sudo",
                          [ "cp"
                          , toFilePath newExeFile
                          , tmpFile
                          ])
                      , ("sudo",
                          [ "mv"
                          , tmpFile
                          , toFilePath currExeFile
                          ])
                      ]
                prettyInfo $
                     flow "Going to run the following commands:"
                  <> blankLine
                  <> bulletedList
                       ( map
                         ( \(cmd, args) ->
                             style Shell $ fillSep
                               $ fromString cmd
                               : map fromString args
                         )
                         commands
                       )
                mapM_ (uncurry run) commands
                prettyInfo $
                     line
                  <> flow "sudo file copy worked!"
        | otherwise -> throwM e

getDownloadVersion :: StackReleaseInfo -> Maybe Version
getDownloadVersion (SRIGitHub val) = do
  Object o <- Just val
  String rawName <- KeyMap.lookup "name" o
  -- drop the "v" at the beginning of the name
  parseVersion $ T.unpack (T.drop 1 rawName)
getDownloadVersion (SRIHaskellStackOrg hso) = Just $ hsoVersion hso