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

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

  -- * Stack binary download

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

import qualified Codec.Archive.Tar as Tar
import           Conduit
                   ( ConduitT, await, concatMapMC, filterCE, foldMC, yield )
import           Control.Applicative ( empty )
import           Crypto.Hash ( SHA1 (..), SHA256 (..) )
import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Conduit.Binary as CB
import           Data.Conduit.Lazy ( lazyConsume )
import qualified Data.Conduit.List as CL
import           Data.Conduit.Process.Typed ( createSource )
import           Data.Conduit.Zlib ( ungzip )
import           Data.List.Split ( splitOn )
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Text.Encoding.Error as T
import qualified Data.Yaml as Yaml
import           Distribution.System ( 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
                   , verifiedDownloadWithProgress, withResponse
                   , setRequestMethod
                   )
import           Network.HTTP.Simple ( getResponseHeader )
import           Pantry.Internal.AesonExtended
                   ( Value (..), WithJSONWarnings (..), logJSONWarnings )
import           Path
                   ( (</>), dirname, filename, parent, parseAbsDir, parseAbsFile
                   , parseRelDir, parseRelFile, toFilePath
                   )
import           Path.CheckInstall ( warnInstallSearchPathIssues )
import           Path.Extended ( fileExtension )
import           Path.Extra ( toFilePathNoTrailingSep )
import           Path.IO hiding ( findExecutable, withSystemTempDir )
import           RIO.List
                   ( headMaybe, intercalate, intersperse, isPrefixOf
                   , maximumByMaybe, sort, sortBy, 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.Constants
import           Stack.Constants.Config ( distRelativeDir )
import           Stack.GhcPkg
                   ( createDatabase, getGlobalDB, ghcPkgPathEnvVar
                   , mkGhcPackagePath )
import           Stack.Prelude
import           Stack.SourceMap
import           Stack.Setup.Installed
                   ( Tool (..), extraDirs, filterTools, getCompilerVersion
                   , installDir, listInstalled, markInstalled, tempInstallDir
                   , toolString, unmarkInstalled
                   )
import           Stack.Storage.User ( loadCompilerPaths, saveCompilerPaths )
import           Stack.Types.Build
import           Stack.Types.Compiler
import           Stack.Types.CompilerBuild
import           Stack.Types.Config
import           Stack.Types.Docker
import           Stack.Types.SourceMap
import           Stack.Types.Version
import qualified System.Directory as D
import           System.Environment ( getExecutablePath, lookupEnv )
import           System.IO.Error ( isPermissionError )
import           System.FilePath ( searchPathSeparator )
import qualified System.FilePath as FP
import           System.Permissions ( setFileExecutable )
import           System.Uname ( getRelease )

-- | Type representing exceptions thrown by functions exported by the

-- "Stack.Setup" module

data SetupException
    = UnsupportedSetupCombo OS Arch
    | MissingDependencies [String]
    | UnknownCompilerVersion (Set.Set Text) WantedCompiler (Set.Set ActualCompiler)
    | UnknownOSKey Text
    | GHCSanityCheckCompileFailed SomeException (Path Abs File)
    | WantedMustBeGHC
    | RequireCustomGHCVariant
    | ProblemWhileDecompressing (Path Abs File)
    | SetupInfoMissingSevenz
    | DockerStackExeNotFound Version Text
    | UnsupportedSetupConfiguration
    | InvalidGhcAt (Path Abs File) SomeException
    | MSYS2NotFound Text
    | UnwantedCompilerVersion
    | UnwantedArchitecture
    | SandboxedCompilerNotFound
    | CompilerNotFound [String]
    | GHCInfoNotValidUTF8 UnicodeException
    | GHCInfoNotListOfPairs
    | GHCInfoMissingGlobalPackageDB
    | GHCInfoMissingTargetPlatform
    | GHCInfoTargetPlatformInvalid String
    | CabalNotFound (Path Abs File)
    | HadrianScriptNotFound
    | URLInvalid String
    | UnknownArchiveExtension String
    | Unsupported7z
    | TarballInvalid String
    | TarballFileInvalid String (Path Abs File)
    | UnknownArchiveStructure (Path Abs File)
    | StackReleaseInfoNotFound String
    | StackBinaryArchiveNotFound [String]
    | WorkingDirectoryInvalidBug
    | HadrianBindistNotFound
    | DownloadAndInstallCompilerError
    | StackBinaryArchiveZipUnsupportedBug
    | StackBinaryArchiveUnsupported Text
    | StackBinaryNotInArchive String Text
    | FileTypeInArchiveInvalid Tar.Entry Text
    | BinaryUpgradeOnOSUnsupported Cabal.OS
    | BinaryUpgradeOnArchUnsupported Cabal.Arch
    | ExistingMSYS2NotDeleted (Path Abs Dir) IOException
    deriving (Int -> SetupException -> ShowS
[SetupException] -> ShowS
SetupException -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SetupException] -> ShowS
$cshowList :: [SetupException] -> ShowS
show :: SetupException -> [Char]
$cshow :: SetupException -> [Char]
showsPrec :: Int -> SetupException -> ShowS
$cshowsPrec :: Int -> SetupException -> ShowS
Show, Typeable)

instance Exception SetupException where
    displayException :: SetupException -> [Char]
displayException (UnsupportedSetupCombo OS
os Arch
arch) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-1852]\n"
        , [Char]
"I don't know how to install GHC for "
        , forall a. Show a => a -> [Char]
show (OS
os, Arch
arch)
        , [Char]
", please install manually"
        ]
    displayException (MissingDependencies [[Char]]
tools) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-2126]\n"
        , [Char]
"The following executables are missing and must be installed: "
        , forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " [[Char]]
tools
        ]
    displayException (UnknownCompilerVersion Set Text
oskeys WantedCompiler
wanted Set ActualCompiler
known) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-9443]\n"
        , [Char]
"No setup information found for "
        , Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Text
utf8BuilderToText forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Utf8Builder
display WantedCompiler
wanted
        , [Char]
" on your platform.\nThis probably means a GHC bindist has not yet been added for OS key '"
        , Text -> [Char]
T.unpack (Text -> [Text] -> Text
T.intercalate Text
"', '" (forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set Text
oskeys))
        , [Char]
"'.\nSupported versions: "
        , Text -> [Char]
T.unpack (Text -> [Text] -> Text
T.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map ActualCompiler -> Text
compilerVersionText (forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set ActualCompiler
known)))
        ]
    displayException (UnknownOSKey Text
oskey) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-6810]\n"
        , [Char]
"Unable to find installation URLs for OS key: "
        , Text -> [Char]
T.unpack Text
oskey
        ]
    displayException (GHCSanityCheckCompileFailed SomeException
e Path Abs File
ghc) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-5159]\n"
        , [Char]
"The GHC located at "
        , forall b t. Path b t -> [Char]
toFilePath Path Abs File
ghc
        , [Char]
" failed to compile a sanity check. Please see:\n\n"
        , [Char]
"    http://docs.haskellstack.org/en/stable/install_and_upgrade/\n\n"
        , [Char]
"for more information. Exception was:\n"
        , forall e. Exception e => e -> [Char]
displayException SomeException
e
        ]
    displayException SetupException
WantedMustBeGHC =
        [Char]
"Error: [S-9030]\n"
        forall a. [a] -> [a] -> [a]
++ [Char]
"The wanted compiler must be GHC."
    displayException SetupException
RequireCustomGHCVariant =
        [Char]
"Error: [S-8948]\n"
        forall a. [a] -> [a] -> [a]
++ [Char]
"A custom '--ghc-variant' must be specified to use '--ghc-bindist'."
    displayException (ProblemWhileDecompressing Path Abs File
archive) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-2905]\n"
        , [Char]
"Problem while decompressing "
        , forall b t. Path b t -> [Char]
toFilePath Path Abs File
archive
        ]
    displayException SetupException
SetupInfoMissingSevenz =
        [Char]
"Error: [S-9561]\n"
        forall a. [a] -> [a] -> [a]
++ [Char]
"SetupInfo missing Sevenz EXE/DLL."
    displayException (DockerStackExeNotFound Version
stackVersion' Text
osKey) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-1457]\n"
        , [Char]
stackProgName
        , [Char]
"-"
        , Version -> [Char]
versionString Version
stackVersion'
        , [Char]
" executable not found for "
        , Text -> [Char]
T.unpack Text
osKey
        , [Char]
"\nUse the '"
        , Text -> [Char]
T.unpack Text
dockerStackExeArgName
        , [Char]
"' option to specify a location."]
    displayException SetupException
UnsupportedSetupConfiguration =
        [Char]
"Error: [S-7748]\n"
        forall a. [a] -> [a] -> [a]
++ [Char]
"Stack does not know how to install GHC on your system \
           \configuration, please install manually."
    displayException (InvalidGhcAt Path Abs File
compiler SomeException
e) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-2476]\n"
        , [Char]
"Found an invalid compiler at "
        , forall a. Show a => a -> [Char]
show (forall b t. Path b t -> [Char]
toFilePath Path Abs File
compiler)
        , [Char]
": "
        , forall e. Exception e => e -> [Char]
displayException SomeException
e
        ]
    displayException (MSYS2NotFound Text
osKey) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-5308]\n"
        , [Char]
"MSYS2 not found for "
        , Text -> [Char]
T.unpack Text
osKey
        ]
    displayException SetupException
UnwantedCompilerVersion =
        [Char]
"Error: [S-5127]\n"
        forall a. [a] -> [a] -> [a]
++ [Char]
"Not the compiler version we want."
    displayException SetupException
UnwantedArchitecture =
        [Char]
"Error: [S-1540]\n"
        forall a. [a] -> [a] -> [a]
++ [Char]
"Not the architecture we want."
    displayException SetupException
SandboxedCompilerNotFound =
        [Char]
"Error: [S-9953]\n"
        forall a. [a] -> [a] -> [a]
++ [Char]
"Could not find sandboxed compiler."
    displayException (CompilerNotFound [[Char]]
toTry) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-4764]\n"
        , [Char]
"Could not find any of: "
        , forall a. Show a => a -> [Char]
show [[Char]]
toTry
        ]
    displayException (GHCInfoNotValidUTF8 UnicodeException
e) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-8668]\n"
        , [Char]
"GHC info is not valid UTF-8: "
        , forall e. Exception e => e -> [Char]
displayException UnicodeException
e
        ]
    displayException SetupException
GHCInfoNotListOfPairs =
        [Char]
"Error: [S-4878]\n"
        forall a. [a] -> [a] -> [a]
++ [Char]
"GHC info does not parse as a list of pairs."
    displayException SetupException
GHCInfoMissingGlobalPackageDB =
        [Char]
"Error: [S-2965]\n"
        forall a. [a] -> [a] -> [a]
++ [Char]
"Key 'Global Package DB' not found in GHC info."
    displayException SetupException
GHCInfoMissingTargetPlatform =
        [Char]
"Error: [S-5219]\n"
        forall a. [a] -> [a] -> [a]
++ [Char]
"Key 'Target platform' not found in GHC info."
    displayException (GHCInfoTargetPlatformInvalid [Char]
targetPlatform) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-8299]\n"
        , [Char]
"Invalid target platform in GHC info: "
        , [Char]
targetPlatform
        ]
    displayException (CabalNotFound Path Abs File
compiler) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-2574]\n"
        , [Char]
"Cabal library not found in global package database for "
        , forall b t. Path b t -> [Char]
toFilePath Path Abs File
compiler
        ]
    displayException SetupException
HadrianScriptNotFound =
        [Char]
"Error: [S-1128]\n"
        forall a. [a] -> [a] -> [a]
++ [Char]
"No Hadrian build script found."
    displayException (URLInvalid [Char]
url) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
         [ [Char]
"Error: [S-1906]\n"
         , [Char]
"`url` must be either an HTTP URL or a file path: "
         , [Char]
url
         ]
    displayException (UnknownArchiveExtension [Char]
url) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
         [ [Char]
"Error: [S-1648]\n"
         , [Char]
"Unknown extension for url: "
         , [Char]
url
         ]
    displayException SetupException
Unsupported7z =
        [Char]
"Error: [S-4509]\n"
        forall a. [a] -> [a] -> [a]
++ [Char]
"Don't know how to deal with .7z files on non-Windows."
    displayException (TarballInvalid [Char]
name) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-3158]\n"
        , [Char]
name
        , [Char]
" must be a tarball file."
        ]
    displayException (TarballFileInvalid [Char]
name Path Abs File
archiveFile) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-5252]\n"
        , [Char]
"Invalid "
        , [Char]
name
        , [Char]
" filename: "
        , forall a. Show a => a -> [Char]
show Path Abs File
archiveFile
        ]
    displayException (UnknownArchiveStructure Path Abs File
archiveFile) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-1827]\n"
        , [Char]
"Expected a single directory within unpacked "
        , forall b t. Path b t -> [Char]
toFilePath Path Abs File
archiveFile
        ]
    displayException (StackReleaseInfoNotFound [Char]
url) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-9476]\n"
        , [Char]
"Could not get release information for Stack from: "
        , [Char]
url
        ]
    displayException (StackBinaryArchiveNotFound [[Char]]
platforms) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-4461]\n"
        , [Char]
"Unable to find binary Stack archive for platforms: "
        , [[Char]] -> [Char]
unwords [[Char]]
platforms
        ]
    displayException SetupException
WorkingDirectoryInvalidBug = [Char] -> ShowS
bugReport [Char]
"[S-2076]"
        [Char]
"Invalid working directory."
    displayException SetupException
HadrianBindistNotFound =
        [Char]
"Error: [S-6617]\n"
        forall a. [a] -> [a] -> [a]
++ [Char]
"Can't find Hadrian-generated binary distribution."
    displayException SetupException
DownloadAndInstallCompilerError =
        [Char]
"Error: [S-7227]\n"
        forall a. [a] -> [a] -> [a]
++ [Char]
"'downloadAndInstallCompiler' should not be reached with ghc-git."
    displayException SetupException
StackBinaryArchiveZipUnsupportedBug = [Char] -> ShowS
bugReport [Char]
"[S-3967]"
        [Char]
"FIXME: Handle zip files."
    displayException (StackBinaryArchiveUnsupported Text
archiveURL) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-6636]\n"
        , [Char]
"Unknown archive format for Stack archive: "
        , Text -> [Char]
T.unpack Text
archiveURL
        ]
    displayException (StackBinaryNotInArchive [Char]
exeName Text
url) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-7871]\n"
        , [Char]
"Stack executable "
        , [Char]
exeName
        , [Char]
" not found in archive from "
        , Text -> [Char]
T.unpack Text
url
        ]
    displayException (FileTypeInArchiveInvalid Entry
e Text
url) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-5046]\n"
        , [Char]
"Invalid file type for tar entry named "
        , Entry -> [Char]
Tar.entryPath Entry
e
        , [Char]
" downloaded from "
        , Text -> [Char]
T.unpack Text
url
        ]
    displayException (BinaryUpgradeOnOSUnsupported OS
os) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-4132]\n"
        , [Char]
"Binary upgrade not yet supported on OS: "
        , forall a. Show a => a -> [Char]
show OS
os
        ]
    displayException (BinaryUpgradeOnArchUnsupported Arch
arch) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-3249]\n"
        , [Char]
"Binary upgrade not yet supported on arch: "
        , forall a. Show a => a -> [Char]
show Arch
arch
        ]
    displayException (ExistingMSYS2NotDeleted Path Abs Dir
destDir IOException
e) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-4230]\n"
        , [Char]
"Could not delete existing MSYS2 directory: "
        , forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
destDir
        , [Char]
"\n"
        , forall e. Exception e => e -> [Char]
displayException IOException
e
        ]

-- | 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)
    deriving (Int -> SetupPrettyException -> ShowS
[SetupPrettyException] -> ShowS
SetupPrettyException -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SetupPrettyException] -> ShowS
$cshowList :: [SetupPrettyException] -> ShowS
show :: SetupPrettyException -> [Char]
$cshow :: SetupPrettyException -> [Char]
showsPrec :: Int -> SetupPrettyException -> ShowS
$cshowsPrec :: Int -> SetupPrettyException -> ShowS
Show, Typeable)

instance Pretty SetupPrettyException where
    pretty :: SetupPrettyException -> StyleDoc
pretty (GHCInstallFailed SomeException
ex [Char]
step [Char]
cmd [[Char]]
args Path Abs Dir
wd Path Abs Dir
tempDir Path Abs Dir
destDir) =
         StyleDoc
"[S-7441]"
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
string (forall e. Exception e => e -> [Char]
displayException SomeException
ex)
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
hang Int
2 (  [Char] -> StyleDoc
flow [Char]
"Error encountered while" StyleDoc -> StyleDoc -> StyleDoc
<+> forall a. IsString a => [Char] -> a
fromString [Char]
step StyleDoc -> StyleDoc -> StyleDoc
<+> [Char] -> StyleDoc
flow [Char]
"GHC with"
                forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
                forall a. Semigroup a => a -> a -> a
<> Style -> StyleDoc -> StyleDoc
style Style
Shell (forall a. IsString a => [Char] -> a
fromString ([[Char]] -> [Char]
unwords ([Char]
cmd forall a. a -> [a] -> [a]
: [[Char]]
args)))
                forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
                -- TODO: Figure out how to insert \ in the appropriate spots

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

                forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
"run in" StyleDoc -> StyleDoc -> StyleDoc
<+> forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
wd
                )
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
      forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
"The following directories may now contain files, but won't be \
              \used by Stack:"
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
"  -" StyleDoc -> StyleDoc -> StyleDoc
<+> forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
tempDir
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
"  -" StyleDoc -> StyleDoc -> StyleDoc
<+> forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
destDir
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
      forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
"For more information consider rerunning with --verbose flag"
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
line

instance Exception SetupPrettyException

-- | Type representing exceptions thrown by 'performPathChecking'

data PerformPathCheckingException
    = ProcessExited ExitCode String [String]
    deriving (Int -> PerformPathCheckingException -> ShowS
[PerformPathCheckingException] -> ShowS
PerformPathCheckingException -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PerformPathCheckingException] -> ShowS
$cshowList :: [PerformPathCheckingException] -> ShowS
show :: PerformPathCheckingException -> [Char]
$cshow :: PerformPathCheckingException -> [Char]
showsPrec :: Int -> PerformPathCheckingException -> ShowS
$cshowsPrec :: Int -> PerformPathCheckingException -> ShowS
Show, Typeable)

instance Exception PerformPathCheckingException where
    displayException :: PerformPathCheckingException -> [Char]
displayException (ProcessExited ExitCode
ec [Char]
cmd [[Char]]
args) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-1991]\n"
        , [Char]
"Process exited with "
        , forall e. Exception e => e -> [Char]
displayException ExitCode
ec
        , [Char]
": "
        , [[Char]] -> [Char]
unwords ([Char]
cmdforall a. a -> [a] -> [a]
:[[Char]]
args)
        ]

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

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

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

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

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

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

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

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

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

    }
    deriving Int -> SetupOpts -> ShowS
[SetupOpts] -> ShowS
SetupOpts -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SetupOpts] -> ShowS
$cshowList :: [SetupOpts] -> ShowS
show :: SetupOpts -> [Char]
$cshow :: SetupOpts -> [Char]
showsPrec :: Int -> SetupOpts -> ShowS
$cshowsPrec :: Int -> SetupOpts -> ShowS
Show
-- | Modify the environment variables (like PATH) appropriately, possibly doing installation too

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

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

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

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

    -- is being used

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

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

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

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

    -- extra installation bin directories

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

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

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

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

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

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

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

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

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

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

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

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

                        -- For reasoning and duplication, see:

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

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

                          -- Make sure that any .ghc.environment files

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

                          -- own package databases. See

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

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

                          Map Text Text
env

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

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

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

data WithGHC env = WithGHC !CompilerPaths !env

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

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

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

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

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

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

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

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

-- get changed and EnvConfig will become inconsistent

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

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

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

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

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

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

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

-- provide the PATHs to add if necessary

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

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

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

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

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

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

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

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

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

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

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

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

-- provide the PATHs to add if necessary

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

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

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

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

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

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

    Path Abs File
hook <- forall env. HasConfig env => RIO env (Path Abs File)
ghcInstallHook
    Bool
hookIsExecutable <- forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) forall a b. (a -> b) -> a -> b
$ if Bool
osIsWindows
      then forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
hook  -- can't really detect executable on windows, only file extension

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

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

    let canUseCompiler :: CompilerPaths -> RIO env CompilerPaths
canUseCompiler CompilerPaths
cp
            | SetupOpts -> Bool
soptsSkipGhcCheck SetupOpts
sopts = forall (f :: * -> *) a. Applicative f => a -> f a
pure CompilerPaths
cp
            | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ ActualCompiler -> Bool
isWanted forall a b. (a -> b) -> a -> b
$ CompilerPaths -> ActualCompiler
cpCompilerVersion CompilerPaths
cp = forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SetupException
UnwantedCompilerVersion
            | CompilerPaths -> Arch
cpArch CompilerPaths
cp forall a. Eq a => a -> a -> Bool
/= Arch
expectedArch = forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SetupException
UnwantedArchitecture
            | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure CompilerPaths
cp
        isWanted :: ActualCompiler -> Bool
isWanted = VersionCheck -> WantedCompiler -> ActualCompiler -> Bool
isWantedCompiler (SetupOpts -> VersionCheck
soptsCompilerCheck SetupOpts
sopts) (SetupOpts -> WantedCompiler
soptsWantedCompiler SetupOpts
sopts)

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

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

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


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

--

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

-- binary and returns it.

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

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


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

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

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

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

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

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

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

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

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

    -- on the paths specified only.

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

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

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

      -- checks.

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

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

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

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

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

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

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

    Either SomeException (Path Abs Dir)
eglobaldb <- forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny forall a b. (a -> b) -> a -> b
$
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
"Global Package DB" Map [Char] [Char]
infoMap of
        Maybe [Char]
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SetupException
GHCInfoMissingGlobalPackageDB
        Just [Char]
db -> forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs Dir)
parseAbsDir [Char]
db

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

    Map PackageName DumpedGlobalPackage
globalDump <- forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv forall a b. (a -> b) -> a -> b
$ forall env.
(HasLogFunc env, HasProcessContext env) =>
GhcPkgExe -> RIO env (Map PackageName DumpedGlobalPackage)
globalsFromDump GhcPkgExe
pkg
    Version
cabalPkgVer <-
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
cabalPackageName Map PackageName DumpedGlobalPackage
globalDump of
        Maybe DumpedGlobalPackage
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Path Abs File -> SetupException
CabalNotFound Path Abs File
compiler
        Just DumpedGlobalPackage
dp -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> Version
pkgVersion forall a b. (a -> b) -> a -> b
$ DumpedGlobalPackage -> PackageIdentifier
dpPackageIdent DumpedGlobalPackage
dp

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

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

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

   -- detect when the correct GHC is already installed

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

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

         Maybe (Path Abs Dir)
mcwd <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs Dir)
parseAbsDir forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasProcessContext env => Lens' env (Maybe [Char])
workingDirL
         Path Abs Dir
cwd <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SetupException
WorkingDirectoryInvalidBug) forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs Dir)
mcwd
         Int
threads <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> Int
configJobs
         let
           hadrianArgs :: [[Char]]
hadrianArgs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> [Char]
T.unpack
               [ Text
"-c"                    -- run ./boot and ./configure

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

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

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

         [Path Abs File]
foundHadrianPaths <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist forall a b. (a -> b) -> a -> b
$ (Path Abs Dir
cwd forall b t. Path b Dir -> Path Rel t -> Path b t
</>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Path Rel File]
hadrianScripts
         Path Abs File
hadrianPath <-
           forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SetupException
HadrianScriptNotFound) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
listToMaybe [Path Abs File]
foundHadrianPaths

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

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

         -- the process package only sets working directory _after_

         -- discovering the executable

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

         -- find the bindist and install it

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

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

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

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

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

-- on the system.

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

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

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

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

        -- something like this:

        --

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

        -- if cached, then use that as suffix

        -- otherwise:

        --     download setup-info

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

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

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

        --         try running it

        --         if successful, then choose that

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

        --

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


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

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

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

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

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

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

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

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

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

-- with "r".

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

-- as recognized by parsePackageNameFromString.

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

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

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

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

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

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

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

-- | Download the most recent SetupInfo

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

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

getInstalledTool :: [Tool]            -- ^ already installed

                 -> PackageName       -- ^ package to find

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    -- are unioned).

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

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

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

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

downloadFromInfo
    :: (HasTerm env, HasBuildConfig env)
    => Path Abs Dir -> DownloadInfo -> Tool -> RIO env (Path Abs File, ArchiveType)
downloadFromInfo :: forall env.
(HasTerm env, HasBuildConfig env) =>
Path Abs Dir
-> DownloadInfo -> Tool -> RIO env (Path Abs File, ArchiveType)
downloadFromInfo Path Abs Dir
programsDir DownloadInfo
downloadInfo Tool
tool = do
    ArchiveType
archiveType <-
        case [Char]
extension of
            [Char]
".tar.xz" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ArchiveType
TarXz
            [Char]
".tar.bz2" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ArchiveType
TarBz2
            [Char]
".tar.gz" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ArchiveType
TarGz
            [Char]
".7z.exe" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ArchiveType
SevenZ
            [Char]
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ [Char] -> SetupException
UnknownArchiveExtension [Char]
url

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

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


data ArchiveType
    = TarBz2
    | TarXz
    | TarGz
    | SevenZ

installGHCPosix :: HasConfig env
                => GHCDownloadInfo
                -> SetupInfo
                -> Path Abs File
                -> ArchiveType
                -> Path Abs Dir
                -> Path Abs Dir
                -> RIO env ()
installGHCPosix :: forall env.
HasConfig env =>
GHCDownloadInfo
-> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
installGHCPosix GHCDownloadInfo
downloadInfo SetupInfo
_ Path Abs File
archiveFile ArchiveType
archiveType Path Abs Dir
tempDir Path Abs Dir
destDir = do
    Platform
platform <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL
    ProcessContext
menv0 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasProcessContext env => Lens' env ProcessContext
processContextL
    ProcessContext
menv <- forall (m :: * -> *).
MonadIO m =>
Map Text Text -> m ProcessContext
mkProcessContext (Map Text Text -> Map Text Text
removeHaskellEnvVars (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env.
HasProcessContext env =>
SimpleGetter env (Map Text Text)
envVarsL ProcessContext
menv0))
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"menv = " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env.
HasProcessContext env =>
SimpleGetter env (Map Text Text)
envVarsL ProcessContext
menv)
    ([Char]
zipTool', Char
compOpt) <-
        case ArchiveType
archiveType of
            ArchiveType
TarXz -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"xz", Char
'J')
            ArchiveType
TarBz2 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"bzip2", Char
'j')
            ArchiveType
TarGz -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"gzip", Char
'z')
            ArchiveType
SevenZ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SetupException
Unsupported7z
    -- Slight hack: OpenBSD's tar doesn't support xz.

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

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

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

    let runStep :: [Char]
-> Path Abs Dir
-> Map Text Text
-> [Char]
-> [[Char]]
-> RIO env ()
runStep [Char]
step Path Abs Dir
wd Map Text Text
env [Char]
cmd [[Char]]
args = do
          ProcessContext
menv' <- forall (m :: * -> *).
MonadIO m =>
ProcessContext
-> (Map Text Text -> Map Text Text) -> m ProcessContext
modifyEnvVars ProcessContext
menv (forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Text Text
env)
          let logLines :: (Utf8Builder -> m ()) -> ConduitT ByteString c m ()
logLines Utf8Builder -> m ()
lvl = forall (m :: * -> *).
Monad m =>
ConduitT ByteString ByteString m ()
CB.lines forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ (Utf8Builder -> m ()
lvl forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Utf8Builder
displayBytesUtf8)
              logStdout :: ConduitT ByteString c (RIO env) ()
logStdout = forall {m :: * -> *} {c}.
Monad m =>
(Utf8Builder -> m ()) -> ConduitT ByteString c m ()
logLines forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug
              logStderr :: ConduitT ByteString c (RIO env) ()
logStderr = forall {m :: * -> *} {c}.
Monad m =>
(Utf8Builder -> m ()) -> ConduitT ByteString c m ()
logLines forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError
          forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
[Char] -> m a -> m a
withWorkingDir (forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
wd) forall a b. (a -> b) -> a -> b
$
                forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv' forall a b. (a -> b) -> a -> b
$
                forall e o env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
[Char]
-> [[Char]]
-> ConduitM ByteString Void (RIO env) e
-> ConduitM ByteString Void (RIO env) o
-> RIO env (e, o)
sinkProcessStderrStdout [Char]
cmd [[Char]]
args forall {c}. ConduitT ByteString c (RIO env) ()
logStderr forall {c}. ConduitT ByteString c (RIO env) ()
logStdout
                forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
ex ->
                    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException
                      (SomeException
-> [Char]
-> [Char]
-> [[Char]]
-> Path Abs Dir
-> Path Abs Dir
-> Path Abs Dir
-> SetupPrettyException
GHCInstallFailed SomeException
ex [Char]
step [Char]
cmd [[Char]]
args Path Abs Dir
wd Path Abs Dir
tempDir Path Abs Dir
destDir)

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

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

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

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

    -- program for compiling C programs

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

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

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

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

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

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

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

-- missing.

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

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

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

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

installMsys2Windows :: HasBuildConfig env
                  => SetupInfo
                  -> Path Abs File
                  -> ArchiveType
                  -> Path Abs Dir
                  -> Path Abs Dir
                  -> RIO env ()
installMsys2Windows :: forall env.
HasBuildConfig env =>
SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
installMsys2Windows SetupInfo
si Path Abs File
archiveFile ArchiveType
archiveType Path Abs Dir
_tempDir Path Abs Dir
destDir = do
    Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
D.doesDirectoryExist forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
destDir
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ()
D.removeDirectoryRecursive forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
destDir) forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (IOException -> m a) -> m a
`catchIO` \IOException
e -> do
        forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> IOException -> SetupException
ExistingMSYS2NotDeleted Path Abs Dir
destDir IOException
e

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


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

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

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

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

    -- No longer installing git, it's unreliable

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

    -- MSYS2-installed version has bad CRLF defaults.

    --

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

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


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

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

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

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

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

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

expectSingleUnpackedDir :: (MonadIO m, MonadThrow m) => Path Abs File -> Path Abs Dir -> m (Path Abs Dir)
expectSingleUnpackedDir :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs File -> Path Abs Dir -> m (Path Abs Dir)
expectSingleUnpackedDir Path Abs File
archiveFile Path Abs Dir
destDir = do
    ([Path Abs Dir], [Path Abs File])
contents <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
destDir
    case ([Path Abs Dir], [Path Abs File])
contents of
        ([Path Abs Dir
dir], [Path Abs File]
_ ) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
dir
        ([Path Abs Dir], [Path Abs File])
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Path Abs File -> SetupException
UnknownArchiveStructure Path Abs File
archiveFile

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

--

-- Returned function takes an unpack directory and archive.

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

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

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

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

               -> Path Abs File -- ^ destination

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

-- | Perform a basic sanity check of GHC

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

        , [Char]
"main = putStrLn \"Hello World\""
        ]
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Performing a sanity check on: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs File
ghc)
    Either SomeException (ByteString, ByteString)
eres <- forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
[Char] -> m a -> m a
withWorkingDir (forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
dir) forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc (forall b t. Path b t -> [Char]
toFilePath Path Abs File
ghc)
        [ [Char]
fp
        , [Char]
"-no-user-package-db"
        ] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_
    case Either SomeException (ByteString, ByteString)
eres of
        Left SomeException
e -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ SomeException -> Path Abs File -> SetupException
GHCSanityCheckCompileFailed SomeException
e Path Abs File
ghc
        Right (ByteString, ByteString)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
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 Text Text -> Map Text Text
removeHaskellEnvVars =
    forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"GHC_PACKAGE_PATH" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"GHC_ENVIRONMENT" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"HASKELL_PACKAGE_SANDBOX" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"HASKELL_PACKAGE_SANDBOXES" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"HASKELL_DIST_DIR" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    -- https://github.com/commercialhaskell/stack/issues/1460

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

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

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

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

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

                 -- variables.

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

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

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

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

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

                         -- changes to environment need to be made.

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

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

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

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

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

                                  -- to be added.

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

                                  -- fallback.

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

    -- be adjusted.

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

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

    -- returned by @locale -a@.

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

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

    -- -a@.

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

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

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

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

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

-- Binary Stack upgrades


-- | Information on a binary release of Stack

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

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


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

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

  -> Maybe String -- GitHub repo

  -> Maybe String -- ^ optional version

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

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

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

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

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

        -- Try the next URL

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

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

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

          -- URL where we can extract version information from.

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

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

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

-- | Same as above, but always uses GitHub

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

  -> Maybe String -- GitHub repo

  -> Maybe String -- ^ optional version

  -> m StackReleaseInfo
downloadStackReleaseInfoGitHub :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Maybe [Char] -> Maybe [Char] -> Maybe [Char] -> m StackReleaseInfo
downloadStackReleaseInfoGitHub Maybe [Char]
morg Maybe [Char]
mrepo Maybe [Char]
mver = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    let org :: [Char]
org = forall a. a -> Maybe a -> a
fromMaybe [Char]
"commercialhaskell" Maybe [Char]
morg
        repo :: [Char]
repo = forall a. a -> Maybe a -> a
fromMaybe [Char]
"stack" Maybe [Char]
mrepo
    let url :: [Char]
url = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [Char]
"https://api.github.com/repos/"
            , [Char]
org
            , [Char]
"/"
            , [Char]
repo
            , [Char]
"/releases/"
            , case Maybe [Char]
mver of
                Maybe [Char]
Nothing -> [Char]
"latest"
                Just [Char]
ver -> [Char]
"tags/v" forall a. [a] -> [a] -> [a]
++ [Char]
ver
            ]
    Request
req <- forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseRequest [Char]
url
    Response Value
res <- forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON forall a b. (a -> b) -> a -> b
$ Request -> Request
setGitHubHeaders Request
req
    let code :: Int
code = forall a. Response a -> Int
getResponseStatusCode Response Value
res
    if Int
code forall a. Ord a => a -> a -> Bool
>= Int
200 Bool -> Bool -> Bool
&& Int
code forall a. Ord a => a -> a -> Bool
< Int
300
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Value -> StackReleaseInfo
SRIGitHub forall a b. (a -> b) -> a -> b
$ forall a. Response a -> a
getResponseBody Response Value
res
        else forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ [Char] -> SetupException
StackReleaseInfoNotFound [Char]
url

preferredPlatforms :: (MonadReader env m, HasPlatform env, MonadThrow m)
                   => m [(Bool, String)]
preferredPlatforms :: forall env (m :: * -> *).
(MonadReader env m, HasPlatform env, MonadThrow m) =>
m [(Bool, [Char])]
preferredPlatforms = do
    Platform Arch
arch' OS
os' <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL
    (Bool
isWindows, [Char]
os) <-
      case OS
os' of
        OS
Cabal.Linux -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, [Char]
"linux")
        OS
Cabal.Windows -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
True, [Char]
"windows")
        OS
Cabal.OSX -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, [Char]
"osx")
        OS
Cabal.FreeBSD -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, [Char]
"freebsd")
        OS
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ OS -> SetupException
BinaryUpgradeOnOSUnsupported OS
os'
    [Char]
arch <-
      case Arch
arch' of
        Arch
I386 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"i386"
        Arch
X86_64 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"x86_64"
        Arch
Arm -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"arm"
        Arch
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Arch -> SetupException
BinaryUpgradeOnArchUnsupported Arch
arch'
    Bool
hasgmp4 <- forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False -- FIXME import relevant code from Stack.Setup? checkLib $(mkRelFile "libgmp.so.3")

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

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

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

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

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

    -> RIO env ()
downloadStackExe :: forall env.
HasConfig env =>
[(Bool, [Char])]
-> StackReleaseInfo
-> Path Abs Dir
-> Bool
-> (Path Abs File -> IO ())
-> RIO env ()
downloadStackExe [(Bool, [Char])]
platforms0 StackReleaseInfo
archiveInfo Path Abs Dir
destDir Bool
checkPath Path Abs File -> IO ()
testExe = do
    (Bool
isWindows, Text
archiveURL) <-
      let loop :: [(Bool, [Char])] -> RIO env (Bool, Text)
loop [] = forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ [[Char]] -> SetupException
StackBinaryArchiveNotFound (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Bool, [Char])]
platforms0)
          loop ((Bool
isWindows, [Char]
p'):[(Bool, [Char])]
ps) = do
            let p :: Text
p = [Char] -> Text
T.pack [Char]
p'
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Querying for archive location for platform: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
p'
            case StackReleaseInfo -> Text -> Maybe Text
findArchive StackReleaseInfo
archiveInfo Text
p of
              Just Text
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
isWindows, Text
x)
              Maybe Text
Nothing -> [(Bool, [Char])] -> RIO env (Bool, Text)
loop [(Bool, [Char])]
ps
       in [(Bool, [Char])] -> RIO env (Bool, Text)
loop [(Bool, [Char])]
platforms0

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

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

    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
      case () of
        ()
          | Text
".tar.gz" Text -> Text -> Bool
`T.isSuffixOf` Text
archiveURL ->
              Path Abs File -> Bool -> Text -> IO ()
handleTarball Path Abs File
tmpFile Bool
isWindows Text
archiveURL
          | Text
".zip" Text -> Text -> Bool
`T.isSuffixOf` Text
archiveURL ->
              forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SetupException
StackBinaryArchiveZipUnsupportedBug
          | Bool
otherwise -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> SetupException
StackBinaryArchiveUnsupported Text
archiveURL

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

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

    -- We need to call getExecutablePath before we overwrite the

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

    -- (deleted) to the filename.

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

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

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

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

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

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

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

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

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

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

                        [[Char]
_ignored, [Char]
name] | [Char]
name forall a. Eq a => a -> a -> Bool
== [Char]
exeName -> do
                            case Entry -> EntryContent
Tar.entryContent Entry
e of
                                Tar.NormalFile ByteString
lbs FileSize
_ -> do
                                  forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
destDir
                                  [Char] -> ByteString -> IO ()
LBS.writeFile (forall b t. Path b t -> [Char]
toFilePath Path Abs File
tmpFile) ByteString
lbs
                                EntryContent
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Entry -> Text -> SetupException
FileTypeInArchiveInvalid Entry
e Text
url
                        [[Char]]
_ -> Entries FormatError -> IO ()
loop Entries FormatError
es
            Entries FormatError -> IO ()
loop Entries FormatError
entries
      where
        exeName :: [Char]
exeName
          | Bool
isWindows = [Char]
"stack.exe"
          | Bool
otherwise = [Char]
"stack"

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

-- as the currently running executable. See:

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

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

    -> String -- ^ currently running executable

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

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

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