{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE MultiWayIf          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE ViewPatterns        #-}

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

  -- * Stack binary download

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

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

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

-- "Stack.Setup" module

data SetupException
  = WorkingDirectoryInvalidBug
  | StackBinaryArchiveZipUnsupportedBug
  deriving (Int -> SetupException -> ShowS
[SetupException] -> ShowS
SetupException -> [Char]
(Int -> SetupException -> ShowS)
-> (SetupException -> [Char])
-> ([SetupException] -> ShowS)
-> Show SetupException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SetupException -> ShowS
showsPrec :: Int -> SetupException -> ShowS
$cshow :: SetupException -> [Char]
show :: SetupException -> [Char]
$cshowList :: [SetupException] -> ShowS
showList :: [SetupException] -> ShowS
Show, Typeable)

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

-- | Type representing \'pretty\' exceptions thrown by functions exported by the

-- "Stack.Setup" module

data SetupPrettyException
  = GHCInstallFailed
      !SomeException
      !String
      !String
      ![String]
      !(Path Abs Dir)
      !(Path Abs Dir)
      !(Path Abs Dir)
  | InvalidGhcAt !(Path Abs File) !SomeException
  | ExecutableNotFound ![Path Abs File]
  | SandboxedCompilerNotFound ![String] ![Path Abs Dir]
  | UnsupportedSetupCombo !OS !Arch
  | MissingDependencies ![String]
  | UnknownCompilerVersion
      !(Set.Set Text)
      !WantedCompiler
      !(Set.Set ActualCompiler)
  | UnknownOSKey !Text
  | GHCSanityCheckCompileFailed !SomeException !(Path Abs File)
  | RequireCustomGHCVariant
  | ProblemWhileDecompressing !(Path Abs File)
  | SetupInfoMissingSevenz
  | UnsupportedSetupConfiguration
  | MSYS2NotFound !Text
  | UnwantedCompilerVersion
  | UnwantedArchitecture
  | GHCInfoNotValidUTF8 !UnicodeException
  | GHCInfoNotListOfPairs
  | GHCInfoMissingGlobalPackageDB
  | GHCInfoMissingTargetPlatform
  | GHCInfoTargetPlatformInvalid !String
  | CabalNotFound !(Path Abs File)
  | GhcBootScriptNotFound
  | HadrianScriptNotFound
  | URLInvalid !String
  | UnknownArchiveExtension !String
  | Unsupported7z
  | TarballInvalid !String
  | TarballFileInvalid !String !(Path Abs File)
  | UnknownArchiveStructure !(Path Abs File)
  | StackReleaseInfoNotFound !String
  | StackBinaryArchiveNotFound ![String]
  | HadrianBindistNotFound
  | DownloadAndInstallCompilerError
  | StackBinaryArchiveUnsupported !Text
  | StackBinaryNotInArchive !String !Text
  | FileTypeInArchiveInvalid !Tar.Entry !Text
  | BinaryUpgradeOnOSUnsupported !Cabal.OS
  | BinaryUpgradeOnArchUnsupported !Cabal.Arch
  | ExistingMSYS2NotDeleted !(Path Abs Dir) !IOException
  deriving (Int -> SetupPrettyException -> ShowS
[SetupPrettyException] -> ShowS
SetupPrettyException -> [Char]
(Int -> SetupPrettyException -> ShowS)
-> (SetupPrettyException -> [Char])
-> ([SetupPrettyException] -> ShowS)
-> Show SetupPrettyException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SetupPrettyException -> ShowS
showsPrec :: Int -> SetupPrettyException -> ShowS
$cshow :: SetupPrettyException -> [Char]
show :: SetupPrettyException -> [Char]
$cshowList :: [SetupPrettyException] -> ShowS
showList :: [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]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
string (SomeException -> [Char]
forall e. Exception e => e -> [Char]
displayException SomeException
ex)
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
hang Int
2 (  [StyleDoc] -> StyleDoc
fillSep
                   [ [Char] -> StyleDoc
flow [Char]
"Error encountered while"
                   , [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
step
                   , [Char] -> StyleDoc
flow [Char]
"GHC with"
                   ]
              StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
              StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> Style -> StyleDoc -> StyleDoc
style Style
Shell ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString ([[Char]] -> [Char]
unwords ([Char]
cmd [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
args)))
              StyleDoc -> StyleDoc -> StyleDoc
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 <>

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

instance Exception SetupPrettyException

-- | Type representing exceptions thrown by 'performPathChecking'

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

instance Exception PerformPathCheckingException where
  displayException :: PerformPathCheckingException -> [Char]
displayException (ProcessExited ExitCode
ec [Char]
cmd [[Char]]
args) = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Char]
"Error: [S-1991]\n"
    , [Char]
"Process exited with "
    , ExitCode -> [Char]
forall e. Exception e => e -> [Char]
displayException ExitCode
ec
    , [Char]
": "
    , [[Char]] -> [Char]
unwords ([Char]
cmd[Char] -> [[Char]] -> [[Char]]
forall 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]
(Int -> SetupOpts -> ShowS)
-> (SetupOpts -> [Char])
-> ([SetupOpts] -> ShowS)
-> Show SetupOpts
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SetupOpts -> ShowS
showsPrec :: Int -> SetupOpts -> ShowS
$cshow :: SetupOpts -> [Char]
show :: SetupOpts -> [Char]
$cshowList :: [SetupOpts] -> ShowS
showList :: [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 <- Getting Config BuildConfig Config -> RIO BuildConfig Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config BuildConfig Config
forall env. HasConfig env => Lens' env Config
Lens' BuildConfig Config
configL
  BuildConfig
bc <- Getting BuildConfig BuildConfig BuildConfig
-> RIO BuildConfig BuildConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BuildConfig BuildConfig BuildConfig
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' BuildConfig BuildConfig
buildConfigL
  let stackYaml :: Path Abs File
stackYaml = BuildConfig -> Path Abs File
bcStackYaml BuildConfig
bc
  Platform
platform <- Getting Platform BuildConfig Platform -> RIO BuildConfig Platform
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Platform BuildConfig Platform
forall env. HasPlatform env => Lens' env Platform
Lens' BuildConfig Platform
platformL
  WantedCompiler
wcVersion <- Getting WantedCompiler BuildConfig WantedCompiler
-> RIO BuildConfig WantedCompiler
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting WantedCompiler BuildConfig WantedCompiler
forall s r. HasBuildConfig s => Getting r s WantedCompiler
wantedCompilerVersionL
  WantedCompiler
wanted <- Getting WantedCompiler BuildConfig WantedCompiler
-> RIO BuildConfig WantedCompiler
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting WantedCompiler BuildConfig WantedCompiler
forall s r. HasBuildConfig s => Getting r s WantedCompiler
wantedCompilerVersionL
  ActualCompiler
actual <- (CompilerException -> RIO BuildConfig ActualCompiler)
-> (ActualCompiler -> RIO BuildConfig ActualCompiler)
-> Either CompilerException ActualCompiler
-> RIO BuildConfig ActualCompiler
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either CompilerException -> RIO BuildConfig ActualCompiler
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ActualCompiler -> RIO BuildConfig ActualCompiler
forall a. a -> RIO BuildConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CompilerException ActualCompiler
 -> RIO BuildConfig ActualCompiler)
-> Either CompilerException ActualCompiler
-> RIO BuildConfig ActualCompiler
forall a b. (a -> b) -> a -> b
$ WantedCompiler -> Either CompilerException ActualCompiler
wantedToActual WantedCompiler
wanted
  let wc :: WhichCompiler
wc = ActualCompiler
actualActualCompiler
-> Getting WhichCompiler ActualCompiler WhichCompiler
-> WhichCompiler
forall s a. s -> Getting a s a -> a
^.Getting WhichCompiler ActualCompiler WhichCompiler
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 = Path Abs File -> Maybe (Path Abs File)
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 = Maybe [Char]
forall a. Maybe a
Nothing
        }

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

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

  (SourceMap
sourceMap, SourceMapHash
sourceMapHash) <- ProcessContext
-> CompilerPaths
-> RIO (WithGHC BuildConfig) (SourceMap, SourceMapHash)
-> RIO BuildConfig (SourceMap, SourceMapHash)
forall env a.
HasConfig env =>
ProcessContext -> CompilerPaths -> RIO (WithGHC env) a -> RIO env a
runWithGHC ProcessContext
menv CompilerPaths
compilerPaths (RIO (WithGHC BuildConfig) (SourceMap, SourceMapHash)
 -> RIO BuildConfig (SourceMap, SourceMapHash))
-> RIO (WithGHC BuildConfig) (SourceMap, SourceMapHash)
-> RIO BuildConfig (SourceMap, SourceMapHash)
forall a b. (a -> b) -> a -> b
$ do
    SMActual DumpedGlobalPackage
smActual <- SMWanted
-> ActualCompiler
-> RIO (WithGHC BuildConfig) (SMActual DumpedGlobalPackage)
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 = Map PackageName DepPackage -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet (SMActual DumpedGlobalPackage -> Map PackageName DepPackage
forall global. SMActual global -> Map PackageName DepPackage
smaDeps SMActual DumpedGlobalPackage
smActual) Set PackageName -> Set PackageName -> Set PackageName
forall a. Semigroup a => a -> a -> a
<>
                     Map PackageName ProjectPackage -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet (SMActual DumpedGlobalPackage -> Map PackageName ProjectPackage
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 (SMActual DumpedGlobalPackage -> Map PackageName DumpedGlobalPackage
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 <- NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO (WithGHC BuildConfig) SMTargets
forall env.
HasBuildConfig env =>
NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
parseTargets NeedTargets
needTargets Bool
haddockDeps BuildOptsCLI
boptsCLI SMActual GlobalPackage
prunedActual
    SourceMap
sourceMap <- SMTargets
-> BuildOptsCLI
-> SMActual DumpedGlobalPackage
-> RIO (WithGHC BuildConfig) SourceMap
forall env.
HasBuildConfig env =>
SMTargets
-> BuildOptsCLI
-> SMActual DumpedGlobalPackage
-> RIO env SourceMap
loadSourceMap SMTargets
targets BuildOptsCLI
boptsCLI SMActual DumpedGlobalPackage
smActual
    SourceMapHash
sourceMapHash <- BuildOptsCLI
-> SourceMap -> RIO (WithGHC BuildConfig) SourceMapHash
forall env.
(HasBuildConfig env, HasCompiler env) =>
BuildOptsCLI -> SourceMap -> RIO env SourceMapHash
hashSourceMapData BuildOptsCLI
boptsCLI SourceMap
sourceMap
    (SourceMap, SourceMapHash)
-> RIO (WithGHC BuildConfig) (SourceMap, SourceMapHash)
forall a. a -> RIO (WithGHC BuildConfig) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SourceMap
sourceMap, SourceMapHash
sourceMapHash)

  FileDigestCache
fileDigestCache <- RIO BuildConfig FileDigestCache
forall (m :: * -> *). MonadIO m => m FileDigestCache
newFileDigestCache

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

  -- extra installation bin directories

  Bool -> [Path Abs Dir]
mkDirs <- EnvConfig
-> RIO EnvConfig (Bool -> [Path Abs Dir])
-> RIO BuildConfig (Bool -> [Path Abs Dir])
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO EnvConfig
envConfig0 RIO EnvConfig (Bool -> [Path Abs Dir])
forall env. HasEnvConfig env => RIO env (Bool -> [Path Abs Dir])
extraBinDirs
  let mpath :: Maybe Text
mpath = Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"PATH" Map Text Text
env
  Text
depsPath <-
    (ProcessException -> RIO BuildConfig Text)
-> (Text -> RIO BuildConfig Text)
-> Either ProcessException Text
-> RIO BuildConfig Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ProcessException -> RIO BuildConfig Text
forall e a. Exception e => e -> RIO BuildConfig a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM Text -> RIO BuildConfig Text
forall a. a -> RIO BuildConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ProcessException Text -> RIO BuildConfig Text)
-> Either ProcessException Text -> RIO BuildConfig Text
forall a b. (a -> b) -> a -> b
$ [[Char]] -> Maybe Text -> Either ProcessException Text
augmentPath (Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath (Path Abs Dir -> [Char]) -> [Path Abs Dir] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> [Path Abs Dir]
mkDirs Bool
False) Maybe Text
mpath
  Text
localsPath <-
    (ProcessException -> RIO BuildConfig Text)
-> (Text -> RIO BuildConfig Text)
-> Either ProcessException Text
-> RIO BuildConfig Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ProcessException -> RIO BuildConfig Text
forall e a. Exception e => e -> RIO BuildConfig a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM Text -> RIO BuildConfig Text
forall a. a -> RIO BuildConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ProcessException Text -> RIO BuildConfig Text)
-> Either ProcessException Text -> RIO BuildConfig Text
forall a b. (a -> b) -> a -> b
$ [[Char]] -> Maybe Text -> Either ProcessException Text
augmentPath (Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath (Path Abs Dir -> [Char]) -> [Path Abs Dir] -> [[Char]]
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 <- EnvConfig
-> RIO EnvConfig (Path Abs Dir) -> RIO BuildConfig (Path Abs Dir)
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO EnvConfig
envConfig0 RIO EnvConfig (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
packageDatabaseDeps
  ProcessContext
-> CompilerPaths
-> RIO (WithGHC BuildConfig) ()
-> RIO BuildConfig ()
forall env a.
HasConfig env =>
ProcessContext -> CompilerPaths -> RIO (WithGHC env) a -> RIO env a
runWithGHC ProcessContext
menv CompilerPaths
compilerPaths (RIO (WithGHC BuildConfig) () -> RIO BuildConfig ())
-> RIO (WithGHC BuildConfig) () -> RIO BuildConfig ()
forall a b. (a -> b) -> a -> b
$ GhcPkgExe -> Path Abs Dir -> RIO (WithGHC BuildConfig) ()
forall env.
(HasProcessContext env, HasTerm env) =>
GhcPkgExe -> Path Abs Dir -> RIO env ()
createDatabase (CompilerPaths -> GhcPkgExe
cpPkg CompilerPaths
compilerPaths) Path Abs Dir
deps
  Path Abs Dir
localdb <- EnvConfig
-> RIO EnvConfig (Path Abs Dir) -> RIO BuildConfig (Path Abs Dir)
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO EnvConfig
envConfig0 RIO EnvConfig (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
packageDatabaseLocal
  ProcessContext
-> CompilerPaths
-> RIO (WithGHC BuildConfig) ()
-> RIO BuildConfig ()
forall env a.
HasConfig env =>
ProcessContext -> CompilerPaths -> RIO (WithGHC env) a -> RIO env a
runWithGHC ProcessContext
menv CompilerPaths
compilerPaths (RIO (WithGHC BuildConfig) () -> RIO BuildConfig ())
-> RIO (WithGHC BuildConfig) () -> RIO BuildConfig ()
forall a b. (a -> b) -> a -> b
$ GhcPkgExe -> Path Abs Dir -> RIO (WithGHC BuildConfig) ()
forall env.
(HasProcessContext env, HasTerm env) =>
GhcPkgExe -> Path Abs Dir -> RIO env ()
createDatabase (CompilerPaths -> GhcPkgExe
cpPkg CompilerPaths
compilerPaths) Path Abs Dir
localdb
  [Path Abs Dir]
extras <- ReaderT EnvConfig (RIO BuildConfig) [Path Abs Dir]
-> EnvConfig -> RIO BuildConfig [Path Abs Dir]
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT EnvConfig (RIO BuildConfig) [Path Abs Dir]
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m) =>
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 (Path Abs Dir -> Text) -> Path Abs Dir -> Text
forall a b. (a -> b) -> a -> b
$ CompilerPaths -> Path Abs Dir
cpGlobalDB CompilerPaths
compilerPaths

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

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

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

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

  IORef (Map EnvSettings ProcessContext)
envRef <- IO (IORef (Map EnvSettings ProcessContext))
-> RIO BuildConfig (IORef (Map EnvSettings ProcessContext))
forall a. IO a -> RIO BuildConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Map EnvSettings ProcessContext))
 -> RIO BuildConfig (IORef (Map EnvSettings ProcessContext)))
-> IO (IORef (Map EnvSettings ProcessContext))
-> RIO BuildConfig (IORef (Map EnvSettings ProcessContext))
forall a b. (a -> b) -> a -> b
$ Map EnvSettings ProcessContext
-> IO (IORef (Map EnvSettings ProcessContext))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Map EnvSettings ProcessContext
forall k a. Map k a
Map.empty
  let getProcessContext' :: EnvSettings -> IO ProcessContext
getProcessContext' EnvSettings
es = do
        Map EnvSettings ProcessContext
m <- IORef (Map EnvSettings ProcessContext)
-> IO (Map EnvSettings ProcessContext)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Map EnvSettings ProcessContext)
envRef
        case EnvSettings
-> Map EnvSettings ProcessContext -> Maybe ProcessContext
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup EnvSettings
es Map EnvSettings ProcessContext
m of
          Just ProcessContext
eo -> ProcessContext -> IO ProcessContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessContext
eo
          Maybe ProcessContext
Nothing -> do
            ProcessContext
eo <- Map Text Text -> IO ProcessContext
forall (m :: * -> *).
MonadIO m =>
Map Text Text -> m ProcessContext
mkProcessContext
              (Map Text Text -> IO ProcessContext)
-> Map Text Text -> IO ProcessContext
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Map Text Text -> Map Text Text
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)
              (Map Text Text -> Map Text Text) -> Map Text Text -> Map Text Text
forall a b. (a -> b) -> a -> b
$ (if EnvSettings -> Bool
esIncludeGhcPackagePath EnvSettings
es
                   then
                     Text -> Text -> Map Text Text -> Map Text Text
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 Map Text Text -> Map Text Text
forall a. a -> a
id)

              (Map Text Text -> Map Text Text) -> Map Text Text -> Map Text Text
forall a b. (a -> b) -> a -> b
$ (if EnvSettings -> Bool
esStackExe EnvSettings
es
                   then Text -> Text -> Map Text Text -> Map Text Text
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 Map Text Text -> Map Text Text
forall a. a -> a
id)

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

              (Map Text Text -> Map Text Text) -> Map Text Text -> Map Text Text
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) ->
                    Text -> Text -> Map Text Text -> Map Text Text
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) ->
                    Text -> Text -> Map Text Text -> Map Text Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"MSYSTEM" Text
"MINGW64"
                  (Bool, Platform)
_ -> Map Text Text -> Map Text Text
forall a. a -> a
id

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

              (Map Text Text -> Map Text Text) -> Map Text Text -> Map Text Text
forall a b. (a -> b) -> a -> b
$ case (EnvSettings -> Bool
esKeepGhcRts EnvSettings
es, Maybe [Char]
mGhcRtsEnvVar) of
                  (Bool
True, Just [Char]
ghcRts) -> Text -> Text -> Map Text Text -> Map Text Text
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])
_ -> Map Text Text -> Map Text Text
forall a. a -> a
id

              -- For reasoning and duplication, see:

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

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

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

                Map Text Text
env

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

  ProcessContext
envOverride <- IO ProcessContext -> RIO BuildConfig ProcessContext
forall a. IO a -> RIO BuildConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessContext -> RIO BuildConfig ProcessContext)
-> IO ProcessContext -> RIO BuildConfig ProcessContext
forall a b. (a -> b) -> a -> b
$ EnvSettings -> IO ProcessContext
getProcessContext' EnvSettings
minimalEnvSettings
  EnvConfig -> RIO BuildConfig EnvConfig
forall a. a -> RIO BuildConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EnvConfig
    { envConfigBuildConfig :: BuildConfig
envConfigBuildConfig = BuildConfig
bc
        { bcConfig :: Config
bcConfig = ExtraDirs -> Config -> Config
addIncludeLib ExtraDirs
ghcBin
                   (Config -> Config) -> Config -> Config
forall a b. (a -> b) -> a -> b
$ ASetter Config Config ProcessContext ProcessContext
-> ProcessContext -> Config -> Config
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Config Config ProcessContext ProcessContext
forall env. HasProcessContext env => Lens' env ProcessContext
Lens' Config ProcessContext
processContextL ProcessContext
envOverride
                     (Getting Config BuildConfig Config -> BuildConfig -> Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config BuildConfig Config
forall env. HasConfig env => Lens' env Config
Lens' BuildConfig Config
configL BuildConfig
bc)
            { configProcessContextSettings :: EnvSettings -> IO ProcessContext
configProcessContextSettings = EnvSettings -> IO ProcessContext
getProcessContext'
            }
        }
    , envConfigBuildOptsCLI :: BuildOptsCLI
envConfigBuildOptsCLI = BuildOptsCLI
boptsCLI
    , envConfigFileDigestCache :: FileDigestCache
envConfigFileDigestCache = FileDigestCache
fileDigestCache
    , 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 (f :: * -> *).
Functor f =>
(env -> f env) -> WithGHC env -> f (WithGHC env)
insideL = (WithGHC env -> env)
-> (WithGHC env -> env -> WithGHC env)
-> Lens (WithGHC env) (WithGHC env) env env
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
_) -> CompilerPaths -> env -> WithGHC env
forall env. CompilerPaths -> env -> WithGHC env
WithGHC CompilerPaths
cp)

instance HasLogFunc env => HasLogFunc (WithGHC env) where
  logFuncL :: Lens' (WithGHC env) LogFunc
logFuncL = (env -> f env) -> WithGHC env -> f (WithGHC env)
forall env (f :: * -> *).
Functor f =>
(env -> f env) -> WithGHC env -> f (WithGHC env)
insideL((env -> f env) -> WithGHC env -> f (WithGHC env))
-> ((LogFunc -> f LogFunc) -> env -> f env)
-> (LogFunc -> f LogFunc)
-> WithGHC env
-> f (WithGHC env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LogFunc -> f LogFunc) -> env -> f env
forall env. HasLogFunc env => Lens' env LogFunc
Lens' env LogFunc
logFuncL

instance HasRunner env => HasRunner (WithGHC env) where
  runnerL :: Lens' (WithGHC env) Runner
runnerL = (env -> f env) -> WithGHC env -> f (WithGHC env)
forall env (f :: * -> *).
Functor f =>
(env -> f env) -> WithGHC env -> f (WithGHC env)
insideL((env -> f env) -> WithGHC env -> f (WithGHC env))
-> ((Runner -> f Runner) -> env -> f env)
-> (Runner -> f Runner)
-> WithGHC env
-> f (WithGHC env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Runner -> f Runner) -> env -> f env
forall env. HasRunner env => Lens' env Runner
Lens' env Runner
runnerL

instance HasProcessContext env => HasProcessContext (WithGHC env) where
  processContextL :: Lens' (WithGHC env) ProcessContext
processContextL = (env -> f env) -> WithGHC env -> f (WithGHC env)
forall env (f :: * -> *).
Functor f =>
(env -> f env) -> WithGHC env -> f (WithGHC env)
insideL((env -> f env) -> WithGHC env -> f (WithGHC env))
-> ((ProcessContext -> f ProcessContext) -> env -> f env)
-> (ProcessContext -> f ProcessContext)
-> WithGHC env
-> f (WithGHC env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ProcessContext -> f ProcessContext) -> env -> f env
forall env. HasProcessContext env => Lens' env ProcessContext
Lens' env ProcessContext
processContextL

instance HasStylesUpdate env => HasStylesUpdate (WithGHC env) where
  stylesUpdateL :: Lens' (WithGHC env) StylesUpdate
stylesUpdateL = (env -> f env) -> WithGHC env -> f (WithGHC env)
forall env (f :: * -> *).
Functor f =>
(env -> f env) -> WithGHC env -> f (WithGHC env)
insideL((env -> f env) -> WithGHC env -> f (WithGHC env))
-> ((StylesUpdate -> f StylesUpdate) -> env -> f env)
-> (StylesUpdate -> f StylesUpdate)
-> WithGHC env
-> f (WithGHC env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(StylesUpdate -> f StylesUpdate) -> env -> f env
forall env. HasStylesUpdate env => Lens' env StylesUpdate
Lens' env StylesUpdate
stylesUpdateL

instance HasTerm env => HasTerm (WithGHC env) where
  useColorL :: Lens' (WithGHC env) Bool
useColorL = (env -> f env) -> WithGHC env -> f (WithGHC env)
forall env (f :: * -> *).
Functor f =>
(env -> f env) -> WithGHC env -> f (WithGHC env)
insideL((env -> f env) -> WithGHC env -> f (WithGHC env))
-> ((Bool -> f Bool) -> env -> f env)
-> (Bool -> f Bool)
-> WithGHC env
-> f (WithGHC env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Bool -> f Bool) -> env -> f env
forall env. HasTerm env => Lens' env Bool
Lens' env Bool
useColorL
  termWidthL :: Lens' (WithGHC env) Int
termWidthL = (env -> f env) -> WithGHC env -> f (WithGHC env)
forall env (f :: * -> *).
Functor f =>
(env -> f env) -> WithGHC env -> f (WithGHC env)
insideL((env -> f env) -> WithGHC env -> f (WithGHC env))
-> ((Int -> f Int) -> env -> f env)
-> (Int -> f Int)
-> WithGHC env
-> f (WithGHC env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> f Int) -> env -> f env
forall env. HasTerm env => Lens' env Int
Lens' env Int
termWidthL

instance HasPantryConfig env => HasPantryConfig (WithGHC env) where
  pantryConfigL :: Lens' (WithGHC env) PantryConfig
pantryConfigL = (env -> f env) -> WithGHC env -> f (WithGHC env)
forall env (f :: * -> *).
Functor f =>
(env -> f env) -> WithGHC env -> f (WithGHC env)
insideL((env -> f env) -> WithGHC env -> f (WithGHC env))
-> ((PantryConfig -> f PantryConfig) -> env -> f env)
-> (PantryConfig -> f PantryConfig)
-> WithGHC env
-> f (WithGHC env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig -> f PantryConfig) -> env -> f env
forall env. HasPantryConfig env => Lens' env PantryConfig
Lens' env PantryConfig
pantryConfigL

instance HasConfig env => HasPlatform (WithGHC env) where
  platformL :: Lens' (WithGHC env) Platform
platformL = (Config -> f Config) -> WithGHC env -> f (WithGHC env)
forall env. HasConfig env => Lens' env Config
Lens' (WithGHC env) Config
configL((Config -> f Config) -> WithGHC env -> f (WithGHC env))
-> ((Platform -> f Platform) -> Config -> f Config)
-> (Platform -> f Platform)
-> WithGHC env
-> f (WithGHC env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Platform -> f Platform) -> Config -> f Config
forall env. HasPlatform env => Lens' env Platform
Lens' Config Platform
platformL
  {-# INLINE platformL #-}
  platformVariantL :: Lens' (WithGHC env) PlatformVariant
platformVariantL = (Config -> f Config) -> WithGHC env -> f (WithGHC env)
forall env. HasConfig env => Lens' env Config
Lens' (WithGHC env) Config
configL((Config -> f Config) -> WithGHC env -> f (WithGHC env))
-> ((PlatformVariant -> f PlatformVariant) -> Config -> f Config)
-> (PlatformVariant -> f PlatformVariant)
-> WithGHC env
-> f (WithGHC env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PlatformVariant -> f PlatformVariant) -> Config -> f Config
forall env. HasPlatform env => Lens' env PlatformVariant
Lens' Config PlatformVariant
platformVariantL
  {-# INLINE platformVariantL #-}

instance HasConfig env => HasGHCVariant (WithGHC env) where
  ghcVariantL :: SimpleGetter (WithGHC env) GHCVariant
ghcVariantL = (Config -> Const r Config) -> WithGHC env -> Const r (WithGHC env)
forall env. HasConfig env => Lens' env Config
Lens' (WithGHC env) Config
configL((Config -> Const r Config)
 -> WithGHC env -> Const r (WithGHC env))
-> ((GHCVariant -> Const r GHCVariant) -> Config -> Const r Config)
-> (GHCVariant -> Const r GHCVariant)
-> WithGHC env
-> Const r (WithGHC env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(GHCVariant -> Const r GHCVariant) -> Config -> Const r Config
forall env. HasGHCVariant env => SimpleGetter env GHCVariant
SimpleGetter Config GHCVariant
ghcVariantL
  {-# INLINE ghcVariantL #-}

instance HasConfig env => HasConfig (WithGHC env) where
  configL :: Lens' (WithGHC env) Config
configL = (env -> f env) -> WithGHC env -> f (WithGHC env)
forall env (f :: * -> *).
Functor f =>
(env -> f env) -> WithGHC env -> f (WithGHC env)
insideL((env -> f env) -> WithGHC env -> f (WithGHC env))
-> ((Config -> f Config) -> env -> f env)
-> (Config -> f Config)
-> WithGHC env
-> f (WithGHC env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> f Config) -> env -> f env
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL

instance HasBuildConfig env => HasBuildConfig (WithGHC env) where
  buildConfigL :: Lens' (WithGHC env) BuildConfig
buildConfigL = (env -> f env) -> WithGHC env -> f (WithGHC env)
forall env (f :: * -> *).
Functor f =>
(env -> f env) -> WithGHC env -> f (WithGHC env)
insideL((env -> f env) -> WithGHC env -> f (WithGHC env))
-> ((BuildConfig -> f BuildConfig) -> env -> f env)
-> (BuildConfig -> f BuildConfig)
-> WithGHC env
-> f (WithGHC env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(BuildConfig -> f BuildConfig) -> env -> f env
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' env BuildConfig
buildConfigL

instance HasCompiler (WithGHC env) where
  compilerPathsL :: SimpleGetter (WithGHC env) CompilerPaths
compilerPathsL = (WithGHC env -> CompilerPaths)
-> SimpleGetter (WithGHC env) CompilerPaths
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 <- RIO env env
forall r (m :: * -> *). MonadReader r m => m r
ask
  let envg :: WithGHC env
envg
        = CompilerPaths -> env -> WithGHC env
forall env. CompilerPaths -> env -> WithGHC env
WithGHC CompilerPaths
cp (env -> WithGHC env) -> env -> WithGHC env
forall a b. (a -> b) -> a -> b
$
          ASetter
  env
  env
  (EnvSettings -> IO ProcessContext)
  (EnvSettings -> IO ProcessContext)
-> (EnvSettings -> IO ProcessContext) -> env -> env
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  env
  env
  (EnvSettings -> IO ProcessContext)
  (EnvSettings -> IO ProcessContext)
forall env.
HasConfig env =>
Lens' env (EnvSettings -> IO ProcessContext)
Lens' env (EnvSettings -> IO ProcessContext)
envOverrideSettingsL (\EnvSettings
_ -> ProcessContext -> IO ProcessContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessContext
pc) (env -> env) -> env -> env
forall a b. (a -> b) -> a -> b
$
          ASetter env env ProcessContext ProcessContext
-> ProcessContext -> env -> env
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter env env ProcessContext ProcessContext
forall env. HasProcessContext env => Lens' env ProcessContext
Lens' env ProcessContext
processContextL ProcessContext
pc env
env
  WithGHC env -> RIO (WithGHC env) a -> RIO env a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO WithGHC env
envg RIO (WithGHC env) a
inner

-- | A modified environment which we know has MSYS2 on the PATH.

newtype WithMSYS env = WithMSYS env

insideMSYSL :: Lens' (WithMSYS env) env
insideMSYSL :: forall env (f :: * -> *).
Functor f =>
(env -> f env) -> WithMSYS env -> f (WithMSYS env)
insideMSYSL = (WithMSYS env -> env)
-> (WithMSYS env -> env -> WithMSYS env)
-> Lens (WithMSYS env) (WithMSYS env) env env
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(WithMSYS env
x) -> env
x) (\(WithMSYS env
_) -> env -> WithMSYS env
forall env. env -> WithMSYS env
WithMSYS)

instance HasLogFunc env => HasLogFunc (WithMSYS env) where
  logFuncL :: Lens' (WithMSYS env) LogFunc
logFuncL = (env -> f env) -> WithMSYS env -> f (WithMSYS env)
forall env (f :: * -> *).
Functor f =>
(env -> f env) -> WithMSYS env -> f (WithMSYS env)
insideMSYSL((env -> f env) -> WithMSYS env -> f (WithMSYS env))
-> ((LogFunc -> f LogFunc) -> env -> f env)
-> (LogFunc -> f LogFunc)
-> WithMSYS env
-> f (WithMSYS env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LogFunc -> f LogFunc) -> env -> f env
forall env. HasLogFunc env => Lens' env LogFunc
Lens' env LogFunc
logFuncL

instance HasRunner env => HasRunner (WithMSYS env) where
  runnerL :: Lens' (WithMSYS env) Runner
runnerL = (env -> f env) -> WithMSYS env -> f (WithMSYS env)
forall env (f :: * -> *).
Functor f =>
(env -> f env) -> WithMSYS env -> f (WithMSYS env)
insideMSYSL((env -> f env) -> WithMSYS env -> f (WithMSYS env))
-> ((Runner -> f Runner) -> env -> f env)
-> (Runner -> f Runner)
-> WithMSYS env
-> f (WithMSYS env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Runner -> f Runner) -> env -> f env
forall env. HasRunner env => Lens' env Runner
Lens' env Runner
runnerL

instance HasProcessContext env => HasProcessContext (WithMSYS env) where
  processContextL :: Lens' (WithMSYS env) ProcessContext
processContextL = (env -> f env) -> WithMSYS env -> f (WithMSYS env)
forall env (f :: * -> *).
Functor f =>
(env -> f env) -> WithMSYS env -> f (WithMSYS env)
insideMSYSL((env -> f env) -> WithMSYS env -> f (WithMSYS env))
-> ((ProcessContext -> f ProcessContext) -> env -> f env)
-> (ProcessContext -> f ProcessContext)
-> WithMSYS env
-> f (WithMSYS env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ProcessContext -> f ProcessContext) -> env -> f env
forall env. HasProcessContext env => Lens' env ProcessContext
Lens' env ProcessContext
processContextL

instance HasStylesUpdate env => HasStylesUpdate (WithMSYS env) where
  stylesUpdateL :: Lens' (WithMSYS env) StylesUpdate
stylesUpdateL = (env -> f env) -> WithMSYS env -> f (WithMSYS env)
forall env (f :: * -> *).
Functor f =>
(env -> f env) -> WithMSYS env -> f (WithMSYS env)
insideMSYSL((env -> f env) -> WithMSYS env -> f (WithMSYS env))
-> ((StylesUpdate -> f StylesUpdate) -> env -> f env)
-> (StylesUpdate -> f StylesUpdate)
-> WithMSYS env
-> f (WithMSYS env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(StylesUpdate -> f StylesUpdate) -> env -> f env
forall env. HasStylesUpdate env => Lens' env StylesUpdate
Lens' env StylesUpdate
stylesUpdateL

instance HasTerm env => HasTerm (WithMSYS env) where
  useColorL :: Lens' (WithMSYS env) Bool
useColorL = (env -> f env) -> WithMSYS env -> f (WithMSYS env)
forall env (f :: * -> *).
Functor f =>
(env -> f env) -> WithMSYS env -> f (WithMSYS env)
insideMSYSL((env -> f env) -> WithMSYS env -> f (WithMSYS env))
-> ((Bool -> f Bool) -> env -> f env)
-> (Bool -> f Bool)
-> WithMSYS env
-> f (WithMSYS env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Bool -> f Bool) -> env -> f env
forall env. HasTerm env => Lens' env Bool
Lens' env Bool
useColorL
  termWidthL :: Lens' (WithMSYS env) Int
termWidthL = (env -> f env) -> WithMSYS env -> f (WithMSYS env)
forall env (f :: * -> *).
Functor f =>
(env -> f env) -> WithMSYS env -> f (WithMSYS env)
insideMSYSL((env -> f env) -> WithMSYS env -> f (WithMSYS env))
-> ((Int -> f Int) -> env -> f env)
-> (Int -> f Int)
-> WithMSYS env
-> f (WithMSYS env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> f Int) -> env -> f env
forall env. HasTerm env => Lens' env Int
Lens' env Int
termWidthL

instance HasPantryConfig env => HasPantryConfig (WithMSYS env) where
  pantryConfigL :: Lens' (WithMSYS env) PantryConfig
pantryConfigL = (env -> f env) -> WithMSYS env -> f (WithMSYS env)
forall env (f :: * -> *).
Functor f =>
(env -> f env) -> WithMSYS env -> f (WithMSYS env)
insideMSYSL((env -> f env) -> WithMSYS env -> f (WithMSYS env))
-> ((PantryConfig -> f PantryConfig) -> env -> f env)
-> (PantryConfig -> f PantryConfig)
-> WithMSYS env
-> f (WithMSYS env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig -> f PantryConfig) -> env -> f env
forall env. HasPantryConfig env => Lens' env PantryConfig
Lens' env PantryConfig
pantryConfigL

instance HasConfig env => HasPlatform (WithMSYS env) where
  platformL :: Lens' (WithMSYS env) Platform
platformL = (Config -> f Config) -> WithMSYS env -> f (WithMSYS env)
forall env. HasConfig env => Lens' env Config
Lens' (WithMSYS env) Config
configL((Config -> f Config) -> WithMSYS env -> f (WithMSYS env))
-> ((Platform -> f Platform) -> Config -> f Config)
-> (Platform -> f Platform)
-> WithMSYS env
-> f (WithMSYS env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Platform -> f Platform) -> Config -> f Config
forall env. HasPlatform env => Lens' env Platform
Lens' Config Platform
platformL
  {-# INLINE platformL #-}
  platformVariantL :: Lens' (WithMSYS env) PlatformVariant
platformVariantL = (Config -> f Config) -> WithMSYS env -> f (WithMSYS env)
forall env. HasConfig env => Lens' env Config
Lens' (WithMSYS env) Config
configL((Config -> f Config) -> WithMSYS env -> f (WithMSYS env))
-> ((PlatformVariant -> f PlatformVariant) -> Config -> f Config)
-> (PlatformVariant -> f PlatformVariant)
-> WithMSYS env
-> f (WithMSYS env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PlatformVariant -> f PlatformVariant) -> Config -> f Config
forall env. HasPlatform env => Lens' env PlatformVariant
Lens' Config PlatformVariant
platformVariantL
  {-# INLINE platformVariantL #-}

instance HasConfig env => HasGHCVariant (WithMSYS env) where
  ghcVariantL :: SimpleGetter (WithMSYS env) GHCVariant
ghcVariantL = (Config -> Const r Config)
-> WithMSYS env -> Const r (WithMSYS env)
forall env. HasConfig env => Lens' env Config
Lens' (WithMSYS env) Config
configL((Config -> Const r Config)
 -> WithMSYS env -> Const r (WithMSYS env))
-> ((GHCVariant -> Const r GHCVariant) -> Config -> Const r Config)
-> (GHCVariant -> Const r GHCVariant)
-> WithMSYS env
-> Const r (WithMSYS env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(GHCVariant -> Const r GHCVariant) -> Config -> Const r Config
forall env. HasGHCVariant env => SimpleGetter env GHCVariant
SimpleGetter Config GHCVariant
ghcVariantL
  {-# INLINE ghcVariantL #-}

instance HasConfig env => HasConfig (WithMSYS env) where
  configL :: Lens' (WithMSYS env) Config
configL = (env -> f env) -> WithMSYS env -> f (WithMSYS env)
forall env (f :: * -> *).
Functor f =>
(env -> f env) -> WithMSYS env -> f (WithMSYS env)
insideMSYSL((env -> f env) -> WithMSYS env -> f (WithMSYS env))
-> ((Config -> f Config) -> env -> f env)
-> (Config -> f Config)
-> WithMSYS env
-> f (WithMSYS env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> f Config) -> env -> f env
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL

instance HasBuildConfig env => HasBuildConfig (WithMSYS env) where
  buildConfigL :: Lens' (WithMSYS env) BuildConfig
buildConfigL = (env -> f env) -> WithMSYS env -> f (WithMSYS env)
forall env (f :: * -> *).
Functor f =>
(env -> f env) -> WithMSYS env -> f (WithMSYS env)
insideMSYSL((env -> f env) -> WithMSYS env -> f (WithMSYS env))
-> ((BuildConfig -> f BuildConfig) -> env -> f env)
-> (BuildConfig -> f BuildConfig)
-> WithMSYS env
-> f (WithMSYS env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(BuildConfig -> f BuildConfig) -> env -> f env
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' env BuildConfig
buildConfigL

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

-- can be found on.

runWithMSYS ::
     HasConfig env
  => Maybe ExtraDirs
  -> RIO (WithMSYS env) a
  -> RIO env a
runWithMSYS :: forall env a.
HasConfig env =>
Maybe ExtraDirs -> RIO (WithMSYS env) a -> RIO env a
runWithMSYS Maybe ExtraDirs
mmsysPaths RIO (WithMSYS env) a
inner = do
  env
env <- RIO env env
forall r (m :: * -> *). MonadReader r m => m r
ask
  ProcessContext
pc0 <- Getting ProcessContext env ProcessContext -> RIO env ProcessContext
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ProcessContext env ProcessContext
forall env. HasProcessContext env => Lens' env ProcessContext
Lens' env ProcessContext
processContextL
  ProcessContext
pc <- case Maybe ExtraDirs
mmsysPaths of
    Maybe ExtraDirs
Nothing -> ProcessContext -> RIO env ProcessContext
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessContext
pc0
    Just ExtraDirs
msysPaths -> do
      Map Text Text
envars <- (ProcessException -> RIO env (Map Text Text))
-> (Map Text Text -> RIO env (Map Text Text))
-> Either ProcessException (Map Text Text)
-> RIO env (Map Text Text)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ProcessException -> RIO env (Map Text Text)
forall e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM Map Text Text -> RIO env (Map Text Text)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ProcessException (Map Text Text)
 -> RIO env (Map Text Text))
-> Either ProcessException (Map Text Text)
-> RIO env (Map Text Text)
forall a b. (a -> b) -> a -> b
$
        [[Char]]
-> Map Text Text -> Either ProcessException (Map Text Text)
augmentPathMap
          ((Path Abs Dir -> [Char]) -> [Path Abs Dir] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath ([Path Abs Dir] -> [[Char]]) -> [Path Abs Dir] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ExtraDirs -> [Path Abs Dir]
edBins ExtraDirs
msysPaths)
          (Getting (Map Text Text) ProcessContext (Map Text Text)
-> ProcessContext -> Map Text Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Map Text Text) ProcessContext (Map Text Text)
forall env.
HasProcessContext env =>
SimpleGetter env (Map Text Text)
SimpleGetter ProcessContext (Map Text Text)
envVarsL ProcessContext
pc0)
      Map Text Text -> RIO env ProcessContext
forall (m :: * -> *).
MonadIO m =>
Map Text Text -> m ProcessContext
mkProcessContext Map Text Text
envars
  let envMsys :: WithMSYS env
envMsys
        = env -> WithMSYS env
forall env. env -> WithMSYS env
WithMSYS (env -> WithMSYS env) -> env -> WithMSYS env
forall a b. (a -> b) -> a -> b
$
          ASetter
  env
  env
  (EnvSettings -> IO ProcessContext)
  (EnvSettings -> IO ProcessContext)
-> (EnvSettings -> IO ProcessContext) -> env -> env
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  env
  env
  (EnvSettings -> IO ProcessContext)
  (EnvSettings -> IO ProcessContext)
forall env.
HasConfig env =>
Lens' env (EnvSettings -> IO ProcessContext)
Lens' env (EnvSettings -> IO ProcessContext)
envOverrideSettingsL (\EnvSettings
_ -> ProcessContext -> IO ProcessContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessContext
pc) (env -> env) -> env -> env
forall a b. (a -> b) -> a -> b
$
          ASetter env env ProcessContext ProcessContext
-> ProcessContext -> env -> env
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter env env ProcessContext ProcessContext
forall env. HasProcessContext env => Lens' env ProcessContext
Lens' env ProcessContext
processContextL ProcessContext
pc env
env
  WithMSYS env -> RIO (WithMSYS env) a -> RIO env a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO WithMSYS env
envMsys RIO (WithMSYS 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 (SourceMap -> ActualCompiler) -> SourceMap -> ActualCompiler
forall a b. (a -> b) -> a -> b
$ EnvConfig -> SourceMap
envConfigSourceMap EnvConfig
envConfig
  WithGHC BuildConfig
-> RIO (WithGHC BuildConfig) EnvConfig -> RIO env EnvConfig
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO (CompilerPaths -> BuildConfig -> WithGHC BuildConfig
forall env. CompilerPaths -> env -> WithGHC env
WithGHC CompilerPaths
cp BuildConfig
bc) (RIO (WithGHC BuildConfig) EnvConfig -> RIO env EnvConfig)
-> RIO (WithGHC BuildConfig) EnvConfig -> RIO env EnvConfig
forall a b. (a -> b) -> a -> b
$ do
    SMActual DumpedGlobalPackage
smActual <- SMWanted
-> ActualCompiler
-> RIO (WithGHC BuildConfig) (SMActual DumpedGlobalPackage)
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 =
          Map PackageName DepPackage -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet (SMActual DumpedGlobalPackage -> Map PackageName DepPackage
forall global. SMActual global -> Map PackageName DepPackage
smaDeps SMActual DumpedGlobalPackage
smActual) Set PackageName -> Set PackageName -> Set PackageName
forall a. Semigroup a => a -> a -> a
<> Map PackageName ProjectPackage -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet (SMActual DumpedGlobalPackage -> Map PackageName ProjectPackage
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 (SMActual DumpedGlobalPackage -> Map PackageName DumpedGlobalPackage
forall global. SMActual global -> Map PackageName global
smaGlobal SMActual DumpedGlobalPackage
smActual) Set PackageName
actualPkgs }
    SMTargets
targets <- NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO (WithGHC BuildConfig) SMTargets
forall env.
HasBuildConfig env =>
NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
parseTargets NeedTargets
needTargets Bool
haddockDeps BuildOptsCLI
boptsCLI SMActual GlobalPackage
prunedActual
    SourceMap
sourceMap <- SMTargets
-> BuildOptsCLI
-> SMActual DumpedGlobalPackage
-> RIO (WithGHC BuildConfig) SourceMap
forall env.
HasBuildConfig env =>
SMTargets
-> BuildOptsCLI
-> SMActual DumpedGlobalPackage
-> RIO env SourceMap
loadSourceMap SMTargets
targets BuildOptsCLI
boptsCLI SMActual DumpedGlobalPackage
smActual
    EnvConfig -> RIO (WithGHC BuildConfig) EnvConfig
forall a. a -> RIO (WithGHC BuildConfig) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EnvConfig -> RIO (WithGHC BuildConfig) EnvConfig)
-> EnvConfig -> RIO (WithGHC BuildConfig) EnvConfig
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 <- Getting EnvConfig env EnvConfig -> RIO env EnvConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting EnvConfig env EnvConfig
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' env EnvConfig
envConfigL
  Bool
haddockDeps <- Getting Bool env Bool -> RIO env Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Bool env Bool -> RIO env Bool)
-> Getting Bool env Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ (Config -> Const Bool Config) -> env -> Const Bool env
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL((Config -> Const Bool Config) -> env -> Const Bool env)
-> ((Bool -> Const Bool Bool) -> Config -> Const Bool Config)
-> Getting Bool env Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> BuildOpts) -> SimpleGetter Config BuildOpts
forall s a. (s -> a) -> SimpleGetter s a
to Config -> BuildOpts
configBuildGetting Bool Config BuildOpts
-> ((Bool -> Const Bool Bool) -> BuildOpts -> Const Bool BuildOpts)
-> (Bool -> Const Bool Bool)
-> Config
-> Const Bool Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(BuildOpts -> Bool) -> SimpleGetter BuildOpts Bool
forall s a. (s -> a) -> SimpleGetter s a
to BuildOpts -> Bool
shouldHaddockDeps
  let boptsCLI :: BuildOptsCLI
boptsCLI = EnvConfig -> BuildOptsCLI
envConfigBuildOptsCLI EnvConfig
envConfig
  EnvConfig
envConfig' <- EnvConfig
-> NeedTargets -> Bool -> BuildOptsCLI -> RIO env EnvConfig
forall env.
EnvConfig
-> NeedTargets -> Bool -> BuildOptsCLI -> RIO env EnvConfig
rebuildEnv EnvConfig
envConfig NeedTargets
NeedTargets Bool
haddockDeps (BuildOptsCLI -> RIO env EnvConfig)
-> BuildOptsCLI -> RIO env EnvConfig
forall a b. (a -> b) -> a -> b
$
                BuildOptsCLI
boptsCLI {boptsCLITargets :: [Text]
boptsCLITargets = [Text]
targets}
  (env -> env) -> RIO env a -> RIO env a
forall a. (env -> env) -> RIO env a -> RIO env a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter env env EnvConfig EnvConfig -> EnvConfig -> env -> env
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter env env EnvConfig EnvConfig
forall env. HasEnvConfig env => Lens' env EnvConfig
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 [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++
      (Path Abs Dir -> [Char]) -> [Path Abs Dir] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Path Abs Dir -> [Char]
forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep [Path Abs Dir]
includes
  , configExtraLibDirs :: [[Char]]
configExtraLibDirs =
      Config -> [[Char]]
configExtraLibDirs Config
config [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++
      (Path Abs Dir -> [Char]) -> [Path Abs Dir] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Path Abs Dir -> [Char]
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' <- RIO env SetupInfo -> RIO env (Memoized SetupInfo)
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Memoized a)
memoizeRef RIO env SetupInfo
forall env. HasConfig env => RIO env SetupInfo
getSetupInfo
  Maybe Tool
mmsys2Tool <- SetupOpts -> Memoized SetupInfo -> RIO env (Maybe Tool)
forall env.
HasBuildConfig env =>
SetupOpts -> Memoized SetupInfo -> RIO env (Maybe Tool)
ensureMsys SetupOpts
sopts Memoized SetupInfo
getSetupInfo'
  Maybe ExtraDirs
mmsysPaths <- RIO env (Maybe ExtraDirs)
-> (Tool -> RIO env (Maybe ExtraDirs))
-> Maybe Tool
-> RIO env (Maybe ExtraDirs)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe ExtraDirs -> RIO env (Maybe ExtraDirs)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ExtraDirs
forall a. Maybe a
Nothing) ((ExtraDirs -> Maybe ExtraDirs)
-> RIO env ExtraDirs -> RIO env (Maybe ExtraDirs)
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ExtraDirs -> Maybe ExtraDirs
forall a. a -> Maybe a
Just (RIO env ExtraDirs -> RIO env (Maybe ExtraDirs))
-> (Tool -> RIO env ExtraDirs) -> Tool -> RIO env (Maybe ExtraDirs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tool -> RIO env ExtraDirs
forall env. HasConfig env => Tool -> RIO env ExtraDirs
extraDirs) Maybe Tool
mmsys2Tool
  ActualCompiler
actual <- (CompilerException -> RIO env ActualCompiler)
-> (ActualCompiler -> RIO env ActualCompiler)
-> Either CompilerException ActualCompiler
-> RIO env ActualCompiler
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either CompilerException -> RIO env ActualCompiler
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ActualCompiler -> RIO env ActualCompiler
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CompilerException ActualCompiler -> RIO env ActualCompiler)
-> Either CompilerException ActualCompiler
-> RIO env ActualCompiler
forall a b. (a -> b) -> a -> b
$ WantedCompiler -> Either CompilerException ActualCompiler
wantedToActual (WantedCompiler -> Either CompilerException ActualCompiler)
-> WantedCompiler -> Either CompilerException ActualCompiler
forall a b. (a -> b) -> a -> b
$ SetupOpts -> WantedCompiler
soptsWantedCompiler SetupOpts
sopts
  Bool
didWarn <- Version -> RIO env Bool
forall env. HasTerm env => Version -> RIO env Bool
warnUnsupportedCompiler (Version -> RIO env Bool) -> Version -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ ActualCompiler -> Version
getGhcVersion ActualCompiler
actual
  -- Modify the initial environment to include the MSYS2 path, if MSYS2 is being

  -- used

  (CompilerPaths
cp, ExtraDirs
ghcPaths) <- Maybe ExtraDirs
-> RIO (WithMSYS env) (CompilerPaths, ExtraDirs)
-> RIO env (CompilerPaths, ExtraDirs)
forall env a.
HasConfig env =>
Maybe ExtraDirs -> RIO (WithMSYS env) a -> RIO env a
runWithMSYS Maybe ExtraDirs
mmsysPaths (RIO (WithMSYS env) (CompilerPaths, ExtraDirs)
 -> RIO env (CompilerPaths, ExtraDirs))
-> RIO (WithMSYS env) (CompilerPaths, ExtraDirs)
-> RIO env (CompilerPaths, ExtraDirs)
forall a b. (a -> b) -> a -> b
$ SetupOpts
-> Memoized SetupInfo
-> RIO (WithMSYS env) (CompilerPaths, ExtraDirs)
forall env.
(HasConfig env, HasBuildConfig env, HasGHCVariant env) =>
SetupOpts
-> Memoized SetupInfo
-> RIO (WithMSYS env) (CompilerPaths, ExtraDirs)
ensureCompiler SetupOpts
sopts Memoized SetupInfo
getSetupInfo'

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

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

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

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

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

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

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

  if
    | Version
cabalVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
1, Int
24, Int
0] -> do
        [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
          [ [Char] -> StyleDoc
flow [Char]
"Stack no longer supports Cabal versions below 1.24.0.0, but \
                 \version"
          , [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
versionString Version
cabalVersion)
          , [Char] -> StyleDoc
flow [Char]
"was found. This invocation will most likely fail. To fix \
                 \this, either use an older version of Stack or a newer \
                 \resolver. Acceptable resolvers: lts-7.0/nightly-2016-05-26 \
                 \or later."
          ]
    | Version
cabalVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
3, Int
11] ->
        [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
          [ [Char] -> StyleDoc
flow [Char]
"Stack has not been tested with Cabal versions 3.12 and above, \
                 \but version"
          , [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
versionString Version
cabalVersion)
          , [Char] -> StyleDoc
flow [Char]
"was found, this may fail."
          ]
    | Bool
otherwise -> () -> RIO env ()
forall a. a -> RIO env a
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 <- Getting Platform env Platform -> RIO env Platform
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Platform env Platform
forall env. HasPlatform env => Lens' env Platform
Lens' env Platform
platformL
  Path Abs Dir
localPrograms <- Getting (Path Abs Dir) env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Path Abs Dir) env (Path Abs Dir)
 -> RIO env (Path Abs Dir))
-> Getting (Path Abs Dir) env (Path Abs Dir)
-> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ (Config -> Const (Path Abs Dir) Config)
-> env -> Const (Path Abs Dir) env
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL((Config -> Const (Path Abs Dir) Config)
 -> env -> Const (Path Abs Dir) env)
-> ((Path Abs Dir -> Const (Path Abs Dir) (Path Abs Dir))
    -> Config -> Const (Path Abs Dir) Config)
-> Getting (Path Abs Dir) env (Path Abs Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> Path Abs Dir) -> SimpleGetter Config (Path Abs Dir)
forall s a. (s -> a) -> SimpleGetter s a
to Config -> Path Abs Dir
configLocalPrograms
  [Tool]
installed <- Path Abs Dir -> RIO env [Tool]
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") (Bool -> Version -> Bool
forall a b. a -> b -> a
const Bool
True) of
        Just Tool
tool -> Maybe Tool -> RIO env (Maybe Tool)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tool -> Maybe Tool
forall a. a -> Maybe a
Just Tool
tool)
        Maybe Tool
Nothing
          | SetupOpts -> Bool
soptsInstallIfMissing SetupOpts
sopts -> do
              SetupInfo
si <- Memoized SetupInfo -> RIO env SetupInfo
forall (m :: * -> *) a. MonadIO m => Memoized a -> m a
runMemoized Memoized SetupInfo
getSetupInfo'
              Text
osKey <- Platform -> RIO env Text
forall (m :: * -> *). MonadThrow m => Platform -> m Text
getOSKey Platform
platform
              Config
config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL
              VersionedDownloadInfo Version
version DownloadInfo
info <-
                case Text
-> Map Text VersionedDownloadInfo -> Maybe VersionedDownloadInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
osKey (Map Text VersionedDownloadInfo -> Maybe VersionedDownloadInfo)
-> Map Text VersionedDownloadInfo -> Maybe VersionedDownloadInfo
forall a b. (a -> b) -> a -> b
$ SetupInfo -> Map Text VersionedDownloadInfo
siMsys2 SetupInfo
si of
                  Just VersionedDownloadInfo
x -> VersionedDownloadInfo -> RIO env VersionedDownloadInfo
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VersionedDownloadInfo
x
                  Maybe VersionedDownloadInfo
Nothing -> SetupPrettyException -> RIO env VersionedDownloadInfo
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (SetupPrettyException -> RIO env VersionedDownloadInfo)
-> SetupPrettyException -> RIO env VersionedDownloadInfo
forall a b. (a -> b) -> a -> b
$ Text -> SetupPrettyException
MSYS2NotFound Text
osKey
              let tool :: Tool
tool = PackageIdentifier -> Tool
Tool (PackageName -> Version -> PackageIdentifier
PackageIdentifier ([Char] -> PackageName
mkPackageName [Char]
"msys2") Version
version)
              Tool -> Maybe Tool
forall a. a -> Maybe a
Just (Tool -> Maybe Tool) -> RIO env Tool -> RIO env (Maybe Tool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs Dir
-> DownloadInfo
-> Tool
-> (Path Abs File
    -> ArchiveType -> Path Abs Dir -> Path Abs Dir -> RIO env ())
-> RIO env 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
info
                         Tool
tool
                         (SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
forall env.
HasBuildConfig env =>
SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
installMsys2Windows SetupInfo
si)
          | Bool
otherwise -> do
              [Char] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[Char] -> m ()
prettyWarnS [Char]
"Continuing despite missing tool: msys2"
              Maybe Tool -> RIO env (Maybe Tool)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Tool
forall a. Maybe a
Nothing
    Platform
_ -> Maybe Tool -> RIO env (Maybe Tool)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Tool
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
_ <- Getting Platform env Platform -> RIO env Platform
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Platform env Platform
forall env. HasPlatform env => Lens' env Platform
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 <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL
  GHCVariant
ghcVariant <- Getting GHCVariant env GHCVariant -> RIO env GHCVariant
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting GHCVariant env GHCVariant
forall env. HasGHCVariant env => SimpleGetter env GHCVariant
SimpleGetter env GHCVariant
ghcVariantL
  WhichCompiler
wc <- (CompilerException -> RIO env WhichCompiler)
-> (ActualCompiler -> RIO env WhichCompiler)
-> Either CompilerException ActualCompiler
-> RIO env WhichCompiler
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either CompilerException -> RIO env WhichCompiler
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (WhichCompiler -> RIO env WhichCompiler
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WhichCompiler -> RIO env WhichCompiler)
-> (ActualCompiler -> WhichCompiler)
-> ActualCompiler
-> RIO env WhichCompiler
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActualCompiler -> WhichCompiler
whichCompiler) (Either CompilerException ActualCompiler -> RIO env WhichCompiler)
-> Either CompilerException ActualCompiler -> RIO env 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 <- RIO env [CompilerBuild]
forall env. HasConfig env => RIO env [CompilerBuild]
getGhcBuilds
        [CompilerBuild]
-> (CompilerBuild -> RIO env (Maybe Tool, CompilerBuild))
-> RIO env [(Maybe Tool, CompilerBuild)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CompilerBuild]
ghcBuilds ((CompilerBuild -> RIO env (Maybe Tool, CompilerBuild))
 -> RIO env [(Maybe Tool, CompilerBuild)])
-> (CompilerBuild -> RIO env (Maybe Tool, CompilerBuild))
-> RIO env [(Maybe Tool, CompilerBuild)]
forall a b. (a -> b) -> a -> b
$ \CompilerBuild
ghcBuild -> do
          PackageName
ghcPkgName <- [Char] -> RIO env PackageName
forall (m :: * -> *). MonadThrow m => [Char] -> m PackageName
parsePackageNameThrowing
            (  [Char]
"ghc"
            [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ GHCVariant -> [Char]
ghcVariantSuffix GHCVariant
ghcVariant
            [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ CompilerBuild -> [Char]
compilerBuildSuffix CompilerBuild
ghcBuild
            )
          (Maybe Tool, CompilerBuild) -> RIO env (Maybe Tool, CompilerBuild)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Tool] -> PackageName -> (Version -> Bool) -> Maybe Tool
getInstalledTool [Tool]
installed PackageName
ghcPkgName (ActualCompiler -> Bool
isWanted (ActualCompiler -> Bool)
-> (Version -> ActualCompiler) -> Version -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> ActualCompiler
ACGhc), CompilerBuild
ghcBuild)
  let existingCompilers :: [(Tool, CompilerBuild)]
existingCompilers = ((Maybe Tool, CompilerBuild) -> [(Tool, CompilerBuild)])
-> [(Maybe Tool, CompilerBuild)] -> [(Tool, CompilerBuild)]
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
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
       Utf8Builder
"Found already installed GHC builds: "
    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat (Utf8Builder -> [Utf8Builder] -> [Utf8Builder]
forall a. a -> [a] -> [a]
intersperse Utf8Builder
", " (((Tool, CompilerBuild) -> Utf8Builder)
-> [(Tool, CompilerBuild)] -> [Utf8Builder]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString ([Char] -> Utf8Builder)
-> ((Tool, CompilerBuild) -> [Char])
-> (Tool, CompilerBuild)
-> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerBuild -> [Char]
compilerBuildName (CompilerBuild -> [Char])
-> ((Tool, CompilerBuild) -> CompilerBuild)
-> (Tool, CompilerBuild)
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tool, CompilerBuild) -> CompilerBuild
forall a b. (a, b) -> b
snd) [(Tool, CompilerBuild)]
existingCompilers))
  case [(Tool, CompilerBuild)]
existingCompilers of
    (Tool
tool, CompilerBuild
build_):[(Tool, CompilerBuild)]
_ -> (Tool, CompilerBuild) -> RIO env (Tool, CompilerBuild)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tool
tool, CompilerBuild
build_)
    []
      | SetupOpts -> Bool
soptsInstallIfMissing SetupOpts
sopts -> do
          SetupInfo
si <- Memoized SetupInfo -> RIO env SetupInfo
forall (m :: * -> *) a. MonadIO m => Memoized a -> m a
runMemoized Memoized SetupInfo
getSetupInfo'
          [CompilerBuild]
-> SetupInfo
-> WantedCompiler
-> VersionCheck
-> Maybe [Char]
-> RIO env (Tool, CompilerBuild)
forall env.
(HasGHCVariant env, HasBuildConfig env) =>
[CompilerBuild]
-> SetupInfo
-> WantedCompiler
-> VersionCheck
-> Maybe [Char]
-> RIO env (Tool, CompilerBuild)
downloadAndInstallPossibleCompilers
            (((Maybe Tool, CompilerBuild) -> CompilerBuild)
-> [(Maybe Tool, CompilerBuild)] -> [CompilerBuild]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Tool, CompilerBuild) -> CompilerBuild
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 = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe
                ([Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                  [ Text
"To install the correct GHC into "
                  , [Char] -> Text
T.pack (Path Abs Dir -> [Char]
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)
          BuildException -> RIO env (Tool, CompilerBuild)
forall e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (BuildException -> RIO env (Tool, CompilerBuild))
-> BuildException -> RIO env (Tool, CompilerBuild)
forall a b. (a -> b) -> a -> b
$ Maybe (ActualCompiler, Arch)
-> (WantedCompiler, Arch)
-> GHCVariant
-> CompilerBuild
-> VersionCheck
-> Maybe (Path Abs File)
-> Text
-> BuildException
CompilerVersionMismatch
            Maybe (ActualCompiler, Arch)
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.

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

  Path Abs File
hook <- RIO (WithMSYS env) (Path Abs File)
forall env. HasConfig env => RIO env (Path Abs File)
ghcInstallHook
  Bool
hookIsExecutable <- (IOException -> RIO (WithMSYS env) Bool)
-> RIO (WithMSYS env) Bool -> RIO (WithMSYS env) Bool
forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> Bool -> RIO (WithMSYS env) Bool
forall a. a -> RIO (WithMSYS env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) (RIO (WithMSYS env) Bool -> RIO (WithMSYS env) Bool)
-> RIO (WithMSYS env) Bool -> RIO (WithMSYS env) Bool
forall a b. (a -> b) -> a -> b
$ if Bool
osIsWindows
    then Path Abs File -> RIO (WithMSYS env) Bool
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 (Permissions -> Bool)
-> RIO (WithMSYS env) Permissions -> RIO (WithMSYS env) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs File -> RIO (WithMSYS env) Permissions
forall (m :: * -> *) b t. MonadIO m => Path b t -> m Permissions
getPermissions Path Abs File
hook

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

  let canUseCompiler :: CompilerPaths -> RIO (WithMSYS env) CompilerPaths
canUseCompiler CompilerPaths
cp
        | SetupOpts -> Bool
soptsSkipGhcCheck SetupOpts
sopts = CompilerPaths -> RIO (WithMSYS env) CompilerPaths
forall a. a -> RIO (WithMSYS env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CompilerPaths
cp
        | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ActualCompiler -> Bool
isWanted (ActualCompiler -> Bool) -> ActualCompiler -> Bool
forall a b. (a -> b) -> a -> b
$ CompilerPaths -> ActualCompiler
cpCompilerVersion CompilerPaths
cp =
            SetupPrettyException -> RIO (WithMSYS env) CompilerPaths
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO SetupPrettyException
UnwantedCompilerVersion
        | CompilerPaths -> Arch
cpArch CompilerPaths
cp Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
/= Arch
expectedArch = SetupPrettyException -> RIO (WithMSYS env) CompilerPaths
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO SetupPrettyException
UnwantedArchitecture
        | Bool
otherwise = CompilerPaths -> RIO (WithMSYS env) CompilerPaths
forall a. a -> RIO (WithMSYS env) a
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 (WithMSYS env) (Maybe CompilerPaths)
      checkCompiler :: Path Abs File -> RIO (WithMSYS env) (Maybe CompilerPaths)
checkCompiler Path Abs File
compiler = do
        Either SomeException CompilerPaths
eres <- RIO (WithMSYS env) CompilerPaths
-> RIO (WithMSYS env) (Either SomeException CompilerPaths)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (RIO (WithMSYS env) CompilerPaths
 -> RIO (WithMSYS env) (Either SomeException CompilerPaths))
-> RIO (WithMSYS env) CompilerPaths
-> RIO (WithMSYS env) (Either SomeException CompilerPaths)
forall a b. (a -> b) -> a -> b
$
          WhichCompiler
-> CompilerBuild
-> Bool
-> Path Abs File
-> RIO (WithMSYS env) CompilerPaths
forall env.
HasConfig env =>
WhichCompiler
-> CompilerBuild -> Bool -> Path Abs File -> RIO env CompilerPaths
pathsFromCompiler WhichCompiler
wc CompilerBuild
CompilerBuildStandard Bool
False Path Abs File
compiler RIO (WithMSYS env) CompilerPaths
-> (CompilerPaths -> RIO (WithMSYS env) CompilerPaths)
-> RIO (WithMSYS env) CompilerPaths
forall a b.
RIO (WithMSYS env) a
-> (a -> RIO (WithMSYS env) b) -> RIO (WithMSYS env) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CompilerPaths -> RIO (WithMSYS env) CompilerPaths
canUseCompiler
        case Either SomeException CompilerPaths
eres of
          Left SomeException
e -> do
            Utf8Builder -> RIO (WithMSYS env) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO (WithMSYS env) ())
-> Utf8Builder -> RIO (WithMSYS env) ()
forall a b. (a -> b) -> a -> b
$
                 Utf8Builder
"Not using compiler at "
              Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
compiler)
              Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": "
              Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> SomeException -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow SomeException
e
            Maybe CompilerPaths -> RIO (WithMSYS env) (Maybe CompilerPaths)
forall a. a -> RIO (WithMSYS env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CompilerPaths
forall a. Maybe a
Nothing
          Right CompilerPaths
cp -> Maybe CompilerPaths -> RIO (WithMSYS env) (Maybe CompilerPaths)
forall a. a -> RIO (WithMSYS env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe CompilerPaths -> RIO (WithMSYS env) (Maybe CompilerPaths))
-> Maybe CompilerPaths -> RIO (WithMSYS env) (Maybe CompilerPaths)
forall a b. (a -> b) -> a -> b
$ CompilerPaths -> Maybe CompilerPaths
forall a. a -> Maybe a
Just CompilerPaths
cp

  Maybe CompilerPaths
mcp <-
    if | SetupOpts -> Bool
soptsUseSystem SetupOpts
sopts -> do
          Utf8Builder -> RIO (WithMSYS env) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Getting system compiler version"
          ConduitT () Void (RIO (WithMSYS env)) (Maybe CompilerPaths)
-> RIO (WithMSYS env) (Maybe CompilerPaths)
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void (RIO (WithMSYS env)) (Maybe CompilerPaths)
 -> RIO (WithMSYS env) (Maybe CompilerPaths))
-> ConduitT () Void (RIO (WithMSYS env)) (Maybe CompilerPaths)
-> RIO (WithMSYS env) (Maybe CompilerPaths)
forall a b. (a -> b) -> a -> b
$
            WantedCompiler
-> ConduitT () (Path Abs File) (RIO (WithMSYS env)) ()
forall env i.
(HasLogFunc env, HasProcessContext env) =>
WantedCompiler -> ConduitT i (Path Abs File) (RIO env) ()
sourceSystemCompilers WantedCompiler
wanted ConduitT () (Path Abs File) (RIO (WithMSYS env)) ()
-> ConduitT
     (Path Abs File) Void (RIO (WithMSYS env)) (Maybe CompilerPaths)
-> ConduitT () Void (RIO (WithMSYS env)) (Maybe CompilerPaths)
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
            (Path Abs File -> RIO (WithMSYS env) (Maybe CompilerPaths))
-> ConduitT
     (Path Abs File)
     (Element (Maybe CompilerPaths))
     (RIO (WithMSYS env))
     ()
forall (m :: * -> *) mono a.
(Monad m, MonoFoldable mono) =>
(a -> m mono) -> ConduitT a (Element mono) m ()
concatMapMC Path Abs File -> RIO (WithMSYS env) (Maybe CompilerPaths)
checkCompiler ConduitT (Path Abs File) CompilerPaths (RIO (WithMSYS env)) ()
-> ConduitT
     CompilerPaths Void (RIO (WithMSYS env)) (Maybe CompilerPaths)
-> ConduitT
     (Path Abs File) Void (RIO (WithMSYS env)) (Maybe CompilerPaths)
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
            ConduitT
  CompilerPaths Void (RIO (WithMSYS env)) (Maybe CompilerPaths)
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 <- SetupOpts
-> Path Abs File -> RIO (WithMSYS env) (Maybe (Path Abs File))
forall env.
HasBuildConfig env =>
SetupOpts -> Path Abs File -> RIO env (Maybe (Path Abs File))
runGHCInstallHook SetupOpts
sopts Path Abs File
hook
          RIO (WithMSYS env) (Maybe CompilerPaths)
-> (Path Abs File -> RIO (WithMSYS env) (Maybe CompilerPaths))
-> Maybe (Path Abs File)
-> RIO (WithMSYS env) (Maybe CompilerPaths)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe CompilerPaths -> RIO (WithMSYS env) (Maybe CompilerPaths)
forall a. a -> RIO (WithMSYS env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CompilerPaths
forall a. Maybe a
Nothing) Path Abs File -> RIO (WithMSYS env) (Maybe CompilerPaths)
checkCompiler Maybe (Path Abs File)
hookGHC
       | Bool
otherwise -> Maybe CompilerPaths -> RIO (WithMSYS env) (Maybe CompilerPaths)
forall a. a -> RIO (WithMSYS env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CompilerPaths
forall a. Maybe a
Nothing
  case Maybe CompilerPaths
mcp of
    Maybe CompilerPaths
Nothing -> SetupOpts
-> Memoized SetupInfo
-> RIO (WithMSYS env) (CompilerPaths, ExtraDirs)
forall env.
HasBuildConfig env =>
SetupOpts
-> Memoized SetupInfo
-> RIO (WithMSYS env) (CompilerPaths, ExtraDirs)
ensureSandboxedCompiler SetupOpts
sopts Memoized SetupInfo
getSetupInfo'
    Just CompilerPaths
cp -> do
      let paths :: ExtraDirs
paths = ExtraDirs
            { edBins :: [Path Abs Dir]
edBins = [Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent (Path Abs File -> Path Abs Dir) -> Path Abs File -> Path Abs Dir
forall a b. (a -> b) -> a -> b
$ CompilerPaths -> Path Abs File
cpCompiler CompilerPaths
cp]
            , edInclude :: [Path Abs Dir]
edInclude = [], edLib :: [Path Abs Dir]
edLib = []
            }
      (CompilerPaths, ExtraDirs)
-> RIO (WithMSYS env) (CompilerPaths, ExtraDirs)
forall a. a -> RIO (WithMSYS env) a
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
  Utf8Builder -> RIO env ()
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 <- Getting ProcessContext env ProcessContext -> RIO env ProcessContext
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ProcessContext env ProcessContext
forall env. HasProcessContext env => Lens' env ProcessContext
Lens' env ProcessContext
processContextL
  ProcessContext
menv <- Map Text Text -> RIO env ProcessContext
forall (m :: * -> *).
MonadIO m =>
Map Text Text -> m ProcessContext
mkProcessContext (Map Text Text -> Map Text Text -> Map Text Text
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (WantedCompiler -> Map Text Text
wantedCompilerToEnv WantedCompiler
wanted) (Map Text Text -> Map Text Text) -> Map Text Text -> Map Text Text
forall a b. (a -> b) -> a -> b
$
    Map Text Text -> Map Text Text
removeHaskellEnvVars (Getting (Map Text Text) ProcessContext (Map Text Text)
-> ProcessContext -> Map Text Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Map Text Text) ProcessContext (Map Text Text)
forall env.
HasProcessContext env =>
SimpleGetter env (Map Text Text)
SimpleGetter ProcessContext (Map Text Text)
envVarsL ProcessContext
menv0))
  (ExitCode
exit, ByteString
out) <- ProcessContext
-> RIO env (ExitCode, ByteString) -> RIO env (ExitCode, ByteString)
forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv (RIO env (ExitCode, ByteString) -> RIO env (ExitCode, ByteString))
-> RIO env (ExitCode, ByteString) -> RIO env (ExitCode, ByteString)
forall a b. (a -> b) -> a -> b
$ [Char]
-> [[Char]]
-> (ProcessConfig () () () -> RIO env (ExitCode, ByteString))
-> RIO env (ExitCode, ByteString)
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc [Char]
"sh" [Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
hook] ProcessConfig () () () -> RIO env (ExitCode, ByteString)
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 ShowS -> (ByteString -> [Char]) -> ByteString -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
TL.unpack (Text -> [Char]) -> (ByteString -> Text) -> ByteString -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
TL.decodeUtf8With OnDecodeError
T.lenientDecode (ByteString -> [Char]) -> ByteString -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString
out
      case [Char] -> Maybe (Path Abs File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs File)
parseAbsFile [Char]
ghcPath of
        Just Path Abs File
compiler -> do
          Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SetupOpts -> Bool
soptsSanityCheck SetupOpts
sopts) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Path Abs File -> RIO env ()
forall env.
(HasLogFunc env, HasProcessContext env) =>
Path Abs File -> RIO env ()
sanityCheck Path Abs File
compiler
          Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Using GHC compiler at: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString (Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
compiler))
          Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just Path Abs File
compiler)
        Maybe (Path Abs File)
Nothing -> do
          [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
            [ [Char] -> StyleDoc
flow [Char]
"Path to GHC binary is not a valid path:"
            , Style -> StyleDoc -> StyleDoc
style Style
Dir ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
ghcPath) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
            ]
          Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs File)
forall a. Maybe a
Nothing
    ExitFailure Int
i -> do
      [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
        [ [Char] -> StyleDoc
flow [Char]
"GHC install hook exited with code:"
        , Style -> StyleDoc -> StyleDoc
style Style
Error ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString ([Char] -> StyleDoc) -> [Char] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
        ]
      Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs File)
forall a. Maybe a
Nothing
 where
  wantedCompilerToEnv :: WantedCompiler -> EnvVars
  wantedCompilerToEnv :: WantedCompiler -> Map Text Text
wantedCompilerToEnv (WCGhc Version
ver) =
    [(Text, Text)] -> Map Text Text
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) =
    [(Text, Text)] -> Map Text Text
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) =
    [(Text, Text)] -> Map Text Text
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 -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char]
newlines)

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

  Config
config <- Getting Config (WithMSYS env) Config -> RIO (WithMSYS env) Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config (WithMSYS env) Config
forall env. HasConfig env => Lens' env Config
Lens' (WithMSYS env) Config
configL
  let localPrograms :: Path Abs Dir
localPrograms = Config -> Path Abs Dir
configLocalPrograms Config
config
  [Tool]
installed <- Path Abs Dir -> RIO (WithMSYS env) [Tool]
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs Dir -> m [Tool]
listInstalled Path Abs Dir
localPrograms
  Utf8Builder -> RIO (WithMSYS env) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO (WithMSYS env) ())
-> Utf8Builder -> RIO (WithMSYS env) ()
forall a b. (a -> b) -> a -> b
$
       Utf8Builder
"Installed tools: \n - "
    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat (Utf8Builder -> [Utf8Builder] -> [Utf8Builder]
forall a. a -> [a] -> [a]
intersperse Utf8Builder
"\n - " ((Tool -> Utf8Builder) -> [Tool] -> [Utf8Builder]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString ([Char] -> Utf8Builder) -> (Tool -> [Char]) -> Tool -> Utf8Builder
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 ->
       Memoized SetupInfo
-> [Tool]
-> CompilerRepository
-> Text
-> Text
-> RIO (WithMSYS env) (Tool, CompilerBuild)
forall env.
(HasTerm env, HasProcessContext env, HasBuildConfig env) =>
Memoized SetupInfo
-> [Tool]
-> CompilerRepository
-> Text
-> Text
-> RIO (WithMSYS env) (Tool, CompilerBuild)
buildGhcFromSource
         Memoized SetupInfo
getSetupInfo'
         [Tool]
installed
         (Config -> CompilerRepository
configCompilerRepository Config
config)
         Text
commitId
         Text
flavour
     WantedCompiler
_ -> SetupOpts
-> Memoized SetupInfo
-> [Tool]
-> RIO (WithMSYS env) (Tool, CompilerBuild)
forall env.
HasBuildConfig env =>
SetupOpts
-> Memoized SetupInfo -> [Tool] -> RIO env (Tool, CompilerBuild)
installGhcBindist SetupOpts
sopts Memoized SetupInfo
getSetupInfo' [Tool]
installed
  ExtraDirs
paths <- Tool -> RIO (WithMSYS env) ExtraDirs
forall env. HasConfig env => Tool -> RIO env ExtraDirs
extraDirs Tool
compilerTool

  WhichCompiler
wc <- (CompilerException -> RIO (WithMSYS env) WhichCompiler)
-> (ActualCompiler -> RIO (WithMSYS env) WhichCompiler)
-> Either CompilerException ActualCompiler
-> RIO (WithMSYS env) WhichCompiler
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either CompilerException -> RIO (WithMSYS env) WhichCompiler
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (WhichCompiler -> RIO (WithMSYS env) WhichCompiler
forall a. a -> RIO (WithMSYS env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WhichCompiler -> RIO (WithMSYS env) WhichCompiler)
-> (ActualCompiler -> WhichCompiler)
-> ActualCompiler
-> RIO (WithMSYS env) WhichCompiler
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActualCompiler -> WhichCompiler
whichCompiler) (Either CompilerException ActualCompiler
 -> RIO (WithMSYS env) WhichCompiler)
-> Either CompilerException ActualCompiler
-> RIO (WithMSYS env) WhichCompiler
forall a b. (a -> b) -> a -> b
$ WantedCompiler -> Either CompilerException ActualCompiler
wantedToActual WantedCompiler
wanted
  ProcessContext
menv0 <- Getting ProcessContext (WithMSYS env) ProcessContext
-> RIO (WithMSYS env) ProcessContext
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ProcessContext (WithMSYS env) ProcessContext
forall env. HasProcessContext env => Lens' env ProcessContext
Lens' (WithMSYS env) ProcessContext
processContextL
  Map Text Text
m <- (ProcessException -> RIO (WithMSYS env) (Map Text Text))
-> (Map Text Text -> RIO (WithMSYS env) (Map Text Text))
-> Either ProcessException (Map Text Text)
-> RIO (WithMSYS env) (Map Text Text)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ProcessException -> RIO (WithMSYS env) (Map Text Text)
forall e a. Exception e => e -> RIO (WithMSYS env) a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM Map Text Text -> RIO (WithMSYS env) (Map Text Text)
forall a. a -> RIO (WithMSYS env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
     (Either ProcessException (Map Text Text)
 -> RIO (WithMSYS env) (Map Text Text))
-> Either ProcessException (Map Text Text)
-> RIO (WithMSYS env) (Map Text Text)
forall a b. (a -> b) -> a -> b
$ [[Char]]
-> Map Text Text -> Either ProcessException (Map Text Text)
augmentPathMap (Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath (Path Abs Dir -> [Char]) -> [Path Abs Dir] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExtraDirs -> [Path Abs Dir]
edBins ExtraDirs
paths) (Getting (Map Text Text) ProcessContext (Map Text Text)
-> ProcessContext -> Map Text Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Map Text Text) ProcessContext (Map Text Text)
forall env.
HasProcessContext env =>
SimpleGetter env (Map Text Text)
SimpleGetter ProcessContext (Map Text Text)
envVarsL ProcessContext
menv0)
  ProcessContext
menv <- Map Text Text -> RIO (WithMSYS env) ProcessContext
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 -> [[Char]] -> RIO (WithMSYS env) [[Char]]
forall a. a -> RIO (WithMSYS env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Char]
"ghc-" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> [Char]
versionString Version
version, [Char]
"ghc"]
      WCGhcGit{} -> [[Char]] -> RIO (WithMSYS env) [[Char]]
forall a. a -> RIO (WithMSYS env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Char]
"ghc"]
      WCGhcjs{} -> CompilerException -> RIO (WithMSYS env) [[Char]]
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 (WithMSYS env) (Path Abs File)
loop [] = SetupPrettyException -> RIO (WithMSYS env) (Path Abs File)
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (SetupPrettyException -> RIO (WithMSYS env) (Path Abs File))
-> SetupPrettyException -> RIO (WithMSYS env) (Path Abs File)
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Path Abs Dir] -> SetupPrettyException
SandboxedCompilerNotFound [[Char]]
names (ExtraDirs -> [Path Abs Dir]
edBins ExtraDirs
paths)
      loop ([Char]
x:[[Char]]
xs) = do
        [[Char]]
res <- IO [[Char]] -> RIO (WithMSYS env) [[Char]]
forall a. IO a -> RIO (WithMSYS env) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[Char]] -> RIO (WithMSYS env) [[Char]])
-> IO [[Char]] -> RIO (WithMSYS env) [[Char]]
forall a b. (a -> b) -> a -> b
$
          [[Char]] -> [Char] -> IO [[Char]]
D.findExecutablesInDirectories ((Path Abs Dir -> [Char]) -> [Path Abs Dir] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath (ExtraDirs -> [Path Abs Dir]
edBins ExtraDirs
paths)) [Char]
x
        case [[Char]]
res of
          [] -> [[Char]] -> RIO (WithMSYS env) (Path Abs File)
loop [[Char]]
xs
          [Char]
compiler:[[Char]]
rest -> do
            Bool -> RIO (WithMSYS env) () -> RIO (WithMSYS env) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
rest) (RIO (WithMSYS env) () -> RIO (WithMSYS env) ())
-> RIO (WithMSYS env) () -> RIO (WithMSYS env) ()
forall a b. (a -> b) -> a -> b
$ do
              StyleDoc -> RIO (WithMSYS env) ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO (WithMSYS env) ())
-> StyleDoc -> RIO (WithMSYS env) ()
forall a b. (a -> b) -> a -> b
$
                   [Char] -> StyleDoc
flow [Char]
"Found multiple candidate compilers:"
                StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
                StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (([Char] -> StyleDoc) -> [[Char]] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [[Char]]
res)
                StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
                StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
                     [ [Char] -> StyleDoc
flow [Char]
"This usually indicates a failed installation. \
                        \Trying anyway with"
                     , [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
compiler
                     ]
            [Char] -> RIO (WithMSYS env) (Path Abs File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs File)
parseAbsFile [Char]
compiler
  Path Abs File
compiler <- ProcessContext
-> RIO (WithMSYS env) (Path Abs File)
-> RIO (WithMSYS env) (Path Abs File)
forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv (RIO (WithMSYS env) (Path Abs File)
 -> RIO (WithMSYS env) (Path Abs File))
-> RIO (WithMSYS env) (Path Abs File)
-> RIO (WithMSYS env) (Path Abs File)
forall a b. (a -> b) -> a -> b
$ do
    Path Abs File
compiler <- [[Char]] -> RIO (WithMSYS 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.

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

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

  CompilerPaths
cp <- WhichCompiler
-> CompilerBuild
-> Bool
-> Path Abs File
-> RIO (WithMSYS env) CompilerPaths
forall env.
HasConfig env =>
WhichCompiler
-> CompilerBuild -> Bool -> Path Abs File -> RIO env CompilerPaths
pathsFromCompiler WhichCompiler
wc CompilerBuild
compilerBuild Bool
True Path Abs File
compiler
  (CompilerPaths, ExtraDirs)
-> RIO (WithMSYS env) (CompilerPaths, ExtraDirs)
forall a. a -> RIO (WithMSYS env) a
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 (RIO env CompilerPaths -> RIO env CompilerPaths)
-> RIO env CompilerPaths -> RIO env CompilerPaths
forall a b. (a -> b) -> a -> b
$ (SomeException -> RIO env CompilerPaths)
-> RIO env CompilerPaths -> RIO env CompilerPaths
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny SomeException -> RIO env CompilerPaths
onErr (RIO env CompilerPaths -> RIO env CompilerPaths)
-> RIO env CompilerPaths -> RIO env CompilerPaths
forall a b. (a -> b) -> a -> b
$ do
    let dir :: [Char]
dir = Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath (Path Abs Dir -> [Char]) -> Path Abs Dir -> [Char]
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Path Abs Dir
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-"
          ShowS -> Maybe [Char] -> Maybe [Char]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char]
"-" ++) (Maybe [Char] -> Maybe [Char]) -> Maybe [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
prefix ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ Path Rel File -> [Char]
forall b t. Path b t -> [Char]
toFilePath (Path Rel File -> [Char]) -> Path Rel File -> [Char]
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Abs File
compiler
        suffixes :: [[Char]]
suffixes = ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]] -> [[Char]])
-> Maybe [Char]
-> [[Char]]
-> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [[Char]] -> [[Char]]
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
          [Path Abs File]
toTry <- ([Char] -> RIO env (Path Abs File))
-> [[Char]] -> RIO env [Path Abs File]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
                     [Char] -> RIO env (Path Abs File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs File)
parseAbsFile
                     [ [Char]
dir [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
suffix
                     | [Char]
suffix <- [[Char]]
suffixes, [Char]
name <- WhichCompiler -> [[Char]]
getNames WhichCompiler
wc
                     ]
          let loop :: [Path Abs File] -> RIO env (Path Abs File)
loop [] = PrettyException -> RIO env (Path Abs File)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PrettyException -> RIO env (Path Abs File))
-> PrettyException -> RIO env (Path Abs File)
forall a b. (a -> b) -> a -> b
$ SetupPrettyException -> PrettyException
forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException (SetupPrettyException -> PrettyException)
-> SetupPrettyException -> PrettyException
forall a b. (a -> b) -> a -> b
$ [Path Abs File] -> SetupPrettyException
ExecutableNotFound [Path Abs File]
toTry
              loop (Path Abs File
guessedPath:[Path Abs File]
rest) = do
                Bool
exists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
guessedPath
                if Bool
exists
                  then Path Abs File -> RIO env (Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
guessedPath
                  else [Path Abs File] -> RIO env (Path Abs File)
loop [Path Abs File]
rest
          StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyDebug (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
               [Char] -> StyleDoc
flow [Char]
"Looking for executable(s):"
            StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
            StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList ((Path Abs File -> StyleDoc) -> [Path Abs File] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty [Path Abs File]
toTry)
          [Path Abs File] -> RIO env (Path Abs File)
loop [Path Abs File]
toTry
    GhcPkgExe
pkg <- (Path Abs File -> GhcPkgExe)
-> RIO env (Path Abs File) -> RIO env GhcPkgExe
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Path Abs File -> GhcPkgExe
GhcPkgExe (RIO env (Path Abs File) -> RIO env GhcPkgExe)
-> RIO env (Path Abs File) -> RIO env GhcPkgExe
forall a b. (a -> b) -> a -> b
$ (WhichCompiler -> [[Char]]) -> RIO env (Path Abs File)
findHelper ((WhichCompiler -> [[Char]]) -> RIO env (Path Abs File))
-> (WhichCompiler -> [[Char]]) -> RIO env (Path Abs File)
forall a b. (a -> b) -> a -> b
$ \case
                               WhichCompiler
Ghc -> [[Char]
"ghc-pkg"]

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

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

    Either SomeException (Path Abs Dir)
eglobaldb <- RIO env (Path Abs Dir)
-> RIO env (Either SomeException (Path Abs Dir))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (RIO env (Path Abs Dir)
 -> RIO env (Either SomeException (Path Abs Dir)))
-> RIO env (Path Abs Dir)
-> RIO env (Either SomeException (Path Abs Dir))
forall a b. (a -> b) -> a -> b
$
      case [Char] -> Map [Char] [Char] -> Maybe [Char]
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 -> SetupPrettyException -> RIO env (Path Abs Dir)
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO SetupPrettyException
GHCInfoMissingGlobalPackageDB
        Just [Char]
db -> [Char] -> RIO env (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs Dir)
parseAbsDir [Char]
db

    Arch
arch <-
      case [Char] -> Map [Char] [Char] -> Maybe [Char]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
"Target platform" Map [Char] [Char]
infoMap of
        Maybe [Char]
Nothing -> SetupPrettyException -> RIO env Arch
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO SetupPrettyException
GHCInfoMissingTargetPlatform
        Just [Char]
targetPlatform ->
          case [Char] -> Maybe Arch
forall a. Parsec a => [Char] -> Maybe a
simpleParse ([Char] -> Maybe Arch) -> [Char] -> Maybe Arch
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') [Char]
targetPlatform of
            Maybe Arch
Nothing ->
              SetupPrettyException -> RIO env Arch
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (SetupPrettyException -> RIO env Arch)
-> SetupPrettyException -> RIO env Arch
forall a b. (a -> b) -> a -> b
$ [Char] -> SetupPrettyException
GHCInfoTargetPlatformInvalid [Char]
targetPlatform
            Just Arch
arch -> Arch -> RIO env Arch
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Arch
arch
    ActualCompiler
compilerVer <-
      case WhichCompiler
wc of
        WhichCompiler
Ghc ->
          case [Char] -> Map [Char] [Char] -> Maybe [Char]
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
              [Char] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[Char] -> m ()
prettyWarnS [Char]
"Key 'Project version' not found in GHC info."
              WhichCompiler -> Path Abs File -> RIO env ActualCompiler
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 (Version -> ActualCompiler)
-> RIO env Version -> RIO env ActualCompiler
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> RIO env Version
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
          StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
               [Char] -> StyleDoc
flow [Char]
"Stack failed to parse the global DB from GHC info."
            StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
            StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
"While parsing, Stack encountered the error:"
            StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
            StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
string (SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
e)
            StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
            StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
"Asking ghc-pkg directly."
          ProcessContext -> RIO env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv (RIO env (Path Abs Dir) -> RIO env (Path Abs Dir))
-> RIO env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ GhcPkgExe -> RIO env (Path Abs Dir)
forall env.
(HasProcessContext env, HasTerm env) =>
GhcPkgExe -> RIO env (Path Abs Dir)
getGlobalDB GhcPkgExe
pkg
        Right Path Abs Dir
x -> Path Abs Dir -> RIO env (Path Abs Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
x

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

    CompilerPaths -> RIO env CompilerPaths
forall a. a -> RIO env a
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 = PrettyException -> RIO env CompilerPaths
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PrettyException -> RIO env CompilerPaths)
-> (SomeException -> PrettyException)
-> SomeException
-> RIO env CompilerPaths
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SetupPrettyException -> PrettyException
forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException (SetupPrettyException -> PrettyException)
-> (SomeException -> SetupPrettyException)
-> SomeException
-> PrettyException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> SomeException -> SetupPrettyException
InvalidGhcAt Path Abs File
compiler

  withCache :: RIO env CompilerPaths -> RIO env CompilerPaths
withCache RIO env CompilerPaths
inner = do
    Either SomeException (Maybe CompilerPaths)
eres <- RIO env (Maybe CompilerPaths)
-> RIO env (Either SomeException (Maybe CompilerPaths))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (RIO env (Maybe CompilerPaths)
 -> RIO env (Either SomeException (Maybe CompilerPaths)))
-> RIO env (Maybe CompilerPaths)
-> RIO env (Either SomeException (Maybe CompilerPaths))
forall a b. (a -> b) -> a -> b
$ Path Abs File
-> CompilerBuild -> Bool -> RIO env (Maybe CompilerPaths)
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
          StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
               [Char] -> StyleDoc
flow [Char]
"Trouble loading CompilerPaths cache:"
            StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
            StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
string (SomeException -> [Char]
forall e. Exception e => e -> [Char]
displayException SomeException
e)
          Maybe CompilerPaths -> RIO env (Maybe CompilerPaths)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CompilerPaths
forall a. Maybe a
Nothing
        Right Maybe CompilerPaths
x -> Maybe CompilerPaths -> RIO env (Maybe CompilerPaths)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CompilerPaths
x
    case Maybe CompilerPaths
mres of
      Just CompilerPaths
cp -> CompilerPaths
cp CompilerPaths -> RIO env () -> RIO env CompilerPaths
forall a b. a -> RIO env b -> RIO env a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Utf8Builder -> RIO env ()
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
        CompilerPaths -> RIO env ()
forall env. HasConfig env => CompilerPaths -> RIO env ()
saveCompilerPaths CompilerPaths
cp RIO env () -> (SomeException -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
e ->
          StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
               [Char] -> StyleDoc
flow [Char]
"Unable to save CompilerPaths cache:"
            StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
            StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
string (SomeException -> [Char]
forall e. Exception e => e -> [Char]
displayException SomeException
e)
        CompilerPaths -> RIO env CompilerPaths
forall a. a -> RIO env a
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
     -- ^ Commit ID.

  -> Text
     -- ^ Hadrain flavour.

  -> RIO (WithMSYS env) (Tool, CompilerBuild)
buildGhcFromSource :: forall env.
(HasTerm env, HasProcessContext env, HasBuildConfig env) =>
Memoized SetupInfo
-> [Tool]
-> CompilerRepository
-> Text
-> Text
-> RIO (WithMSYS env) (Tool, CompilerBuild)
buildGhcFromSource Memoized SetupInfo
getSetupInfo' [Tool]
installed (CompilerRepository Text
url) Text
commitId Text
flavour = do
  Config
config <- Getting Config (WithMSYS env) Config -> RIO (WithMSYS env) Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config (WithMSYS env) Config
forall env. HasConfig env => Lens' env Config
Lens' (WithMSYS 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 Tool -> [Tool] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Tool]
installed
    then (Tool, CompilerBuild) -> RIO (WithMSYS env) (Tool, CompilerBuild)
forall a. a -> RIO (WithMSYS env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tool
compilerTool, CompilerBuild
CompilerBuildStandard)
    else
      -- clone the repository and execute the given commands

      SimpleRepo
-> RIO (WithMSYS env) (Tool, CompilerBuild)
-> RIO (WithMSYS env) (Tool, CompilerBuild)
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) (RIO (WithMSYS env) (Tool, CompilerBuild)
 -> RIO (WithMSYS env) (Tool, CompilerBuild))
-> RIO (WithMSYS env) (Tool, CompilerBuild)
-> RIO (WithMSYS env) (Tool, CompilerBuild)
forall a b. (a -> b) -> a -> b
$ do
        -- withRepo is guaranteed to set workingDirL, so let's get it

        Maybe (Path Abs Dir)
mcwd <- ([Char] -> RIO (WithMSYS env) (Path Abs Dir))
-> Maybe [Char] -> RIO (WithMSYS env) (Maybe (Path Abs Dir))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse [Char] -> RIO (WithMSYS env) (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs Dir)
parseAbsDir (Maybe [Char] -> RIO (WithMSYS env) (Maybe (Path Abs Dir)))
-> RIO (WithMSYS env) (Maybe [Char])
-> RIO (WithMSYS env) (Maybe (Path Abs Dir))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Getting (Maybe [Char]) (WithMSYS env) (Maybe [Char])
-> RIO (WithMSYS env) (Maybe [Char])
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe [Char]) (WithMSYS env) (Maybe [Char])
forall env. HasProcessContext env => Lens' env (Maybe [Char])
Lens' (WithMSYS env) (Maybe [Char])
workingDirL
        Path Abs Dir
cwd <- RIO (WithMSYS env) (Path Abs Dir)
-> (Path Abs Dir -> RIO (WithMSYS env) (Path Abs Dir))
-> Maybe (Path Abs Dir)
-> RIO (WithMSYS env) (Path Abs Dir)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SetupException -> RIO (WithMSYS env) (Path Abs Dir)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SetupException
WorkingDirectoryInvalidBug) Path Abs Dir -> RIO (WithMSYS env) (Path Abs Dir)
forall a. a -> RIO (WithMSYS env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs Dir)
mcwd
        let threads :: Int
threads = Config -> Int
configJobs Config
config
            relFileHadrianStackDotYaml' :: [Char]
relFileHadrianStackDotYaml' = Path Rel File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Rel File
relFileHadrianStackDotYaml
            ghcBootScriptPath :: Path Abs File
ghcBootScriptPath = Path Abs Dir
cwd Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
ghcBootScript
            boot :: RIO (WithMSYS env) ()
boot = if Bool
osIsWindows
              then [Char]
-> [[Char]]
-> (ProcessConfig () () () -> RIO (WithMSYS env) ())
-> RIO (WithMSYS env) ()
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc [Char]
"python3" [[Char]
"boot"] ProcessConfig () () () -> RIO (WithMSYS env) ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_
              else
                [Char]
-> [[Char]]
-> (ProcessConfig () () () -> RIO (WithMSYS env) ())
-> RIO (WithMSYS env) ()
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc (Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
ghcBootScriptPath) [] ProcessConfig () () () -> RIO (WithMSYS env) ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_
            stack :: [[Char]] -> RIO (WithMSYS env) ()
stack [[Char]]
args = [Char]
-> [[Char]]
-> (ProcessConfig () () () -> RIO (WithMSYS env) ())
-> RIO (WithMSYS env) ()
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc [Char]
"stack" [[Char]]
args'' ProcessConfig () () () -> RIO (WithMSYS env) ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_
             where
              args'' :: [[Char]]
args'' = [Char]
"--stack-yaml=" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
relFileHadrianStackDotYaml' [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
args'
              -- If a resolver is specified on the command line, Stack will

              -- apply it. This allows the resolver specified in Hadrian's

              -- stack.yaml file to be overridden.

              args' :: [[Char]]
args' = [[Char]]
-> (AbstractResolver -> [[Char]])
-> Maybe AbstractResolver
-> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [[Char]]
args AbstractResolver -> [[Char]]
addResolver (Config -> Maybe AbstractResolver
configResolver Config
config)
              addResolver :: AbstractResolver -> [[Char]]
addResolver AbstractResolver
resolver = [Char]
"--resolver=" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> AbstractResolver -> [Char]
forall a. Show a => a -> [Char]
show AbstractResolver
resolver [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
args
            happy :: RIO (WithMSYS env) ()
happy = [[Char]] -> RIO (WithMSYS env) ()
stack [[Char]
"install", [Char]
"happy"]
            alex :: RIO (WithMSYS env) ()
alex = [[Char]] -> RIO (WithMSYS env) ()
stack [[Char]
"install", [Char]
"alex"]
            -- Executed in the Stack environment, because GHC is required.

            configure :: RIO (WithMSYS env) ()
configure = [[Char]] -> RIO (WithMSYS env) ()
stack ([Char]
"exec" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char]
"--" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
ghcConfigure)
            ghcConfigure :: [[Char]]
ghcConfigure
              | Bool
osIsWindows = [[Char]]
ghcConfigureWindows
              | Bool
osIsMacOS = [[Char]]
ghcConfigureMacOS
              | Bool
otherwise   = [[Char]]
ghcConfigurePosix
            hadrianScripts :: [Path Rel File]
hadrianScripts
              | Bool
osIsWindows = [Path Rel File]
hadrianScriptsWindows
              | Bool
otherwise   = [Path Rel File]
hadrianScriptsPosix
            hadrianArgs :: [[Char]]
hadrianArgs = (Text -> [Char]) -> [Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> [Char]
T.unpack
              [ Text
"-j" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
threads   -- parallel build

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

              , Text
"binary-dist"
              ]
        [Path Abs File]
foundHadrianPaths <-
          (Path Abs File -> RIO (WithMSYS env) Bool)
-> [Path Abs File] -> RIO (WithMSYS env) [Path Abs File]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Path Abs File -> RIO (WithMSYS env) Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist ([Path Abs File] -> RIO (WithMSYS env) [Path Abs File])
-> [Path Abs File] -> RIO (WithMSYS env) [Path Abs File]
forall a b. (a -> b) -> a -> b
$ (Path Abs Dir
cwd </>) (Path Rel File -> Path Abs File)
-> [Path Rel File] -> [Path Abs File]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Path Rel File]
hadrianScripts
        Path Abs File
hadrianPath <- RIO (WithMSYS env) (Path Abs File)
-> (Path Abs File -> RIO (WithMSYS env) (Path Abs File))
-> Maybe (Path Abs File)
-> RIO (WithMSYS env) (Path Abs File)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SetupPrettyException -> RIO (WithMSYS env) (Path Abs File)
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO SetupPrettyException
HadrianScriptNotFound) Path Abs File -> RIO (WithMSYS env) (Path Abs File)
forall a. a -> RIO (WithMSYS env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Path Abs File) -> RIO (WithMSYS env) (Path Abs File))
-> Maybe (Path Abs File) -> RIO (WithMSYS env) (Path Abs File)
forall a b. (a -> b) -> a -> b
$
          [Path Abs File] -> Maybe (Path Abs File)
forall a. [a] -> Maybe a
listToMaybe [Path Abs File]
foundHadrianPaths
        Bool
exists <- Path Abs File -> RIO (WithMSYS env) Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
ghcBootScriptPath
        Bool -> RIO (WithMSYS env) () -> RIO (WithMSYS env) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (RIO (WithMSYS env) () -> RIO (WithMSYS env) ())
-> RIO (WithMSYS env) () -> RIO (WithMSYS env) ()
forall a b. (a -> b) -> a -> b
$ SetupPrettyException -> RIO (WithMSYS env) ()
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO SetupPrettyException
GhcBootScriptNotFound
        Path Abs Dir -> RIO (WithMSYS env) ()
forall env b.
(HasProcessContext env, HasTerm env) =>
Path b Dir -> RIO env ()
ensureConfigureScript Path Abs Dir
cwd
        Utf8Builder -> RIO (WithMSYS env) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Running GHC boot script..."
        RIO (WithMSYS env) ()
boot
        [Char] -> RIO (WithMSYS env) Bool
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
[Char] -> m Bool
doesExecutableExist [Char]
"happy" RIO (WithMSYS env) Bool
-> (Bool -> RIO (WithMSYS env) ()) -> RIO (WithMSYS env) ()
forall a b.
RIO (WithMSYS env) a
-> (a -> RIO (WithMSYS env) b) -> RIO (WithMSYS env) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Bool
True -> Utf8Builder -> RIO (WithMSYS env) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"happy executable installed on the PATH."
          Bool
False -> do
            Utf8Builder -> RIO (WithMSYS env) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Installing happy executable..."
            RIO (WithMSYS env) ()
happy
        [Char] -> RIO (WithMSYS env) Bool
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
[Char] -> m Bool
doesExecutableExist [Char]
"alex" RIO (WithMSYS env) Bool
-> (Bool -> RIO (WithMSYS env) ()) -> RIO (WithMSYS env) ()
forall a b.
RIO (WithMSYS env) a
-> (a -> RIO (WithMSYS env) b) -> RIO (WithMSYS env) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Bool
True -> Utf8Builder -> RIO (WithMSYS env) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"alex executable installed on the PATH."
          Bool
False -> do
            Utf8Builder -> RIO (WithMSYS env) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Installing alex executable..."
            RIO (WithMSYS env) ()
alex
        Utf8Builder -> RIO (WithMSYS env) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Running GHC configure script..."
        RIO (WithMSYS env) ()
configure
        Utf8Builder -> RIO (WithMSYS env) ()
forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logSticky (Utf8Builder -> RIO (WithMSYS env) ())
-> Utf8Builder -> RIO (WithMSYS env) ()
forall a b. (a -> b) -> a -> b
$
             Utf8Builder
"Building GHC from source with `"
          Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
flavour
          Utf8Builder -> Utf8Builder -> Utf8Builder
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.

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

        -- find the bindist and install it

        Path Rel Dir
bindistPath <- [Char] -> RIO (WithMSYS env) (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel Dir)
parseRelDir [Char]
"_build/bindist"
        ([Path Abs Dir]
_,[Path Abs File]
files) <- Path Abs Dir
-> RIO (WithMSYS env) ([Path Abs Dir], [Path Abs File])
forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir (Path Abs Dir
cwd Path Abs Dir -> Path Rel Dir -> Path Abs Dir
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 <- Path Rel File -> m [Char]
forall (m :: * -> *) b. MonadThrow m => Path b File -> m [Char]
fileExtension (Path b File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path b File
p)

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

        [Path Abs File]
mbindist <- (Path Abs File -> RIO (WithMSYS env) Bool)
-> [Path Abs File] -> RIO (WithMSYS env) [Path Abs File]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Path Abs File -> RIO (WithMSYS env) Bool
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 (Path Abs File -> [Char]
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 = Maybe Int
forall a. Maybe a
Nothing
                          , downloadInfoSha1 :: Maybe ByteString
downloadInfoSha1          = Maybe ByteString
forall a. Maybe a
Nothing
                          , downloadInfoSha256 :: Maybe ByteString
downloadInfoSha256        = Maybe ByteString
forall a. Maybe a
Nothing
                          }
                ghcdlinfo :: GHCDownloadInfo
ghcdlinfo = [Text] -> Map Text Text -> DownloadInfo -> GHCDownloadInfo
GHCDownloadInfo [Text]
forall a. Monoid a => a
mempty Map Text Text
forall a. Monoid a => a
mempty DownloadInfo
dlinfo
                installer :: SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO (WithMSYS env) ()
installer
                   | Bool
osIsWindows = SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO (WithMSYS env) ()
forall env.
HasBuildConfig env =>
SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
installGHCWindows
                   | Bool
otherwise   = GHCDownloadInfo
-> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO (WithMSYS env) ()
forall env.
HasConfig env =>
GHCDownloadInfo
-> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
installGHCPosix GHCDownloadInfo
ghcdlinfo
            SetupInfo
si <- Memoized SetupInfo -> RIO (WithMSYS env) SetupInfo
forall (m :: * -> *) a. MonadIO m => Memoized a -> m a
runMemoized Memoized SetupInfo
getSetupInfo'
            Tool
_ <- Path Abs Dir
-> DownloadInfo
-> Tool
-> (Path Abs File
    -> ArchiveType
    -> Path Abs Dir
    -> Path Abs Dir
    -> RIO (WithMSYS env) ())
-> RIO (WithMSYS env) 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 (WithMSYS env) ()
installer SetupInfo
si)
            (Tool, CompilerBuild) -> RIO (WithMSYS env) (Tool, CompilerBuild)
forall a. a -> RIO (WithMSYS env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tool
compilerTool, CompilerBuild
CompilerBuildStandard)
          [Path Abs File]
_ -> do
            [Path Abs File]
-> (Path Abs File -> RIO (WithMSYS env) ())
-> RIO (WithMSYS env) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path Abs File]
files (Utf8Builder -> RIO (WithMSYS env) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO (WithMSYS env) ())
-> (Path Abs File -> Utf8Builder)
-> Path Abs File
-> RIO (WithMSYS env) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString ([Char] -> Utf8Builder)
-> (Path Abs File -> [Char]) -> Path Abs File -> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
" - " ++) ShowS -> (Path Abs File -> [Char]) -> Path Abs File -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath)
            SetupPrettyException -> RIO (WithMSYS env) (Tool, CompilerBuild)
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO SetupPrettyException
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 <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL
  case Config -> Maybe CompilerBuild
configGHCBuild Config
config of
    Just CompilerBuild
ghcBuild -> [CompilerBuild] -> RIO env [CompilerBuild]
forall a. a -> RIO env a
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 <- Getting Platform env Platform -> RIO env Platform
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Platform env Platform
forall env. HasPlatform env => Lens' env Platform
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 = k -> a -> Map k a -> Map k a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
              k
"PATH"
              (a
"/sbin:/usr/sbin" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a -> (a -> a) -> Maybe a -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe a
"" (a
":" <>) (k -> Map k a -> Maybe 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 <- (Map Text Text -> Map Text Text)
-> RIO env (Either SomeException ByteString)
-> RIO env (Either SomeException ByteString)
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
(Map Text Text -> Map Text Text) -> m a -> m a
withModifyEnvVars Map Text Text -> Map Text Text
forall {k} {a}.
(Ord k, Semigroup a, IsString k, IsString a) =>
Map k a -> Map k a
sbinEnv
          (RIO env (Either SomeException ByteString)
 -> RIO env (Either SomeException ByteString))
-> RIO env (Either SomeException ByteString)
-> RIO env (Either SomeException ByteString)
forall a b. (a -> b) -> a -> b
$ [Char]
-> [[Char]]
-> (ProcessConfig () () ()
    -> RIO env (Either SomeException ByteString))
-> RIO env (Either SomeException ByteString)
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"]
          ((ProcessConfig () () ()
  -> RIO env (Either SomeException ByteString))
 -> RIO env (Either SomeException ByteString))
-> (ProcessConfig () () ()
    -> RIO env (Either SomeException ByteString))
-> RIO env (Either SomeException ByteString)
forall a b. (a -> b) -> a -> b
$ RIO env ByteString -> RIO env (Either SomeException ByteString)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (RIO env ByteString -> RIO env (Either SomeException ByteString))
-> (ProcessConfig () () () -> RIO env ByteString)
-> ProcessConfig () () ()
-> RIO env (Either SomeException ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, ByteString) -> ByteString)
-> RIO env (ByteString, ByteString) -> RIO env ByteString
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst (RIO env (ByteString, ByteString) -> RIO env ByteString)
-> (ProcessConfig () () () -> RIO env (ByteString, ByteString))
-> ProcessConfig () () ()
-> RIO env ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessConfig () () () -> RIO env (ByteString, ByteString)
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 -> (Text -> Maybe Text) -> [Text] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe ([Text] -> Maybe Text) -> (Text -> [Text]) -> Text -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$
                Text -> [Text]
T.lines (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
T.decodeUtf8With OnDecodeError
T.lenientDecode
                        (ByteString -> Text) -> ByteString -> Text
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 Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
firstWords = do
                  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                       Utf8Builder
"Found shared library "
                    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
libD
                    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" in 'ldconfig -p' output"
                  Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
              | Bool
osIsWindows =
                  -- Cannot parse /usr/lib on Windows

                  Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
              | Bool
otherwise = Path Rel File -> [Path Abs Dir] -> RIO env Bool
forall {m :: * -> *} {env} {b}.
(MonadIO m, HasLogFunc env, MonadReader env m) =>
Path Rel File -> [Path b Dir] -> m Bool
hasMatches Path Rel File
lib [Path Abs Dir]
usrLibDirs
              -- This is a workaround for the fact that libtinfo.so.x doesn't

              -- appear in the 'ldconfig -p' output on Arch or Slackware even

              -- when it exists. There doesn't seem to be an easy way to get the

              -- true list of directories to scan for shared libs, but this

              -- works for our particular cases.

             where
              libD :: Utf8Builder
libD = [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString (Path Rel File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Rel File
lib)
              libT :: Text
libT = [Char] -> Text
T.pack (Path Rel File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Rel File
lib)
            hasMatches :: Path Rel File -> [Path b Dir] -> m Bool
hasMatches Path Rel File
lib [Path b Dir]
dirs = do
              [Path b Dir]
matches <- (Path b Dir -> m Bool) -> [Path b Dir] -> m [Path b Dir]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (Path b File -> m Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist (Path b File -> m Bool)
-> (Path b Dir -> Path b File) -> Path b Dir -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Path b Dir -> Path Rel File -> Path b File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
lib)) [Path b Dir]
dirs
              case [Path b Dir]
matches of
                [] ->
                     Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug
                       (  Utf8Builder
"Did not find shared library "
                       Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
libD
                       )
                  m () -> m Bool -> m Bool
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                (Path b Dir
path:[Path b Dir]
_) ->
                     Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug
                       (  Utf8Builder
"Found shared library "
                       Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
libD
                       Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" in "
                       Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString (Path b Dir -> [Char]
forall b t. Path b t -> [Char]
Path.toFilePath Path b Dir
path)
                       )
                  m () -> m Bool -> m Bool
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
             where
              libD :: Utf8Builder
libD = [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString (Path Rel File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Rel File
lib)
            getLibc6Version :: RIO env (Maybe Version)
getLibc6Version = do
              Either SomeException (ByteString, ByteString)
elddOut <-
                -- On Alpine Linux, 'ldd --version' will send output to stderr,

                -- which we wish to smother.

                [Char]
-> [[Char]]
-> (ProcessConfig () () ()
    -> RIO env (Either SomeException (ByteString, ByteString)))
-> RIO env (Either SomeException (ByteString, ByteString))
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc [Char]
"ldd" [[Char]
"--version"] ((ProcessConfig () () ()
  -> RIO env (Either SomeException (ByteString, ByteString)))
 -> RIO env (Either SomeException (ByteString, ByteString)))
-> (ProcessConfig () () ()
    -> RIO env (Either SomeException (ByteString, ByteString)))
-> RIO env (Either SomeException (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$ RIO env (ByteString, ByteString)
-> RIO env (Either SomeException (ByteString, ByteString))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (RIO env (ByteString, ByteString)
 -> RIO env (Either SomeException (ByteString, ByteString)))
-> (ProcessConfig () () () -> RIO env (ByteString, ByteString))
-> ProcessConfig () () ()
-> RIO env (Either SomeException (ByteString, ByteString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessConfig () () () -> RIO env (ByteString, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_
              Maybe Version -> RIO env (Maybe Version)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Version -> RIO env (Maybe Version))
-> Maybe Version -> RIO env (Maybe Version)
forall a b. (a -> b) -> a -> b
$ case Either SomeException (ByteString, ByteString)
elddOut of
                Right (ByteString
lddOut, ByteString
_) ->
                  let lddOut' :: Text
lddOut' =
                        ByteString -> Text
decodeUtf8Lenient (ByteString -> ByteString
LBS.toStrict ByteString
lddOut)
                  in  case Parser Version -> Text -> Result Version
forall a. Parser a -> Text -> Result a
P.parse Parser Version
lddVersion Text
lddOut' of
                        P.Done Text
_ Version
result -> Version -> Maybe Version
forall a. a -> Maybe a
Just Version
result
                        Result Version
_ -> Maybe Version
forall a. Maybe a
Nothing
                Left SomeException
_ -> Maybe Version
forall a. Maybe a
Nothing
            -- Assumes the first line of ldd has the format:

            --

            -- ldd (...) nn.nn

            --

            -- where nn.nn corresponds to the version of libc6.

            lddVersion :: P.Parser Version
            lddVersion :: Parser Version
lddVersion = do
              (Char -> Bool) -> Parser ()
P.skipWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
')')
              (Char -> Bool) -> Parser ()
P.skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')')
              Parser ()
P.skipSpace
              Int
lddMajorVersion <- Parser Int
forall a. Integral a => Parser a
P.decimal
              (Char -> Bool) -> Parser ()
P.skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.')
              Int
lddMinorVersion <- Parser Int
forall a. Integral a => Parser a
P.decimal
              (Char -> Bool) -> Parser ()
P.skip (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDigit)
              Version -> Parser Version
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Version -> Parser Version) -> Version -> Parser Version
forall a b. (a -> b) -> a -> b
$ [Int] -> Version
mkVersion [ Int
lddMajorVersion, Int
lddMinorVersion ]
        Bool
hasMusl <- Path Rel File -> [Path Abs Dir] -> RIO env Bool
forall {m :: * -> *} {env} {b}.
(MonadIO m, HasLogFunc env, MonadReader env m) =>
Path Rel File -> [Path b Dir] -> m Bool
hasMatches Path Rel File
relFileLibcMuslx86_64So1 [Path Abs Dir]
libDirs
        Maybe Version
mLibc6Version <- RIO env (Maybe Version)
getLibc6Version
        case Maybe Version
mLibc6Version of
          Just Version
libc6Version -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
               Utf8Builder
"Found shared library libc6 in version: "
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
versionString Version
libc6Version)
          Maybe Version
Nothing -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug
            Utf8Builder
"Did not find a version of shared library libc6."
        let hasLibc6_2_32 :: Bool
hasLibc6_2_32 =
              Bool -> (Version -> Bool) -> Maybe Version -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
2 , Int
32]) Maybe Version
mLibc6Version
        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 = if Bool
hasMusl
              then
                [ [[Char]
"musl"] ]
              else
                [[[[Char]]]] -> [[[Char]]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                  [ if Bool
hastinfo6 Bool -> Bool -> Bool
&& Bool
hasgmp5
                      then
                        if Bool
hasLibc6_2_32
                          then [[[Char]
"tinfo6"]]
                          else [[[Char]
"tinfo6-libc6-pre232"]]
                      else [[]]
                  , [ [] | Bool
hastinfo5 Bool -> Bool -> Bool
&& Bool
hasgmp5 ]
                  , [ [[Char]
"ncurses6"] | Bool
hasncurses6 Bool -> Bool -> Bool
&& Bool
hasgmp5 ]
                  , [ [[Char]
"gmp4"] | Bool
hasgmp4 ]
                  ]
        [CompilerBuild] -> RIO env [CompilerBuild]
forall {m :: * -> *} {env}.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
[CompilerBuild] -> m [CompilerBuild]
useBuilds ([CompilerBuild] -> RIO env [CompilerBuild])
-> [CompilerBuild] -> RIO env [CompilerBuild]
forall a b. (a -> b) -> a -> b
$ ([[Char]] -> CompilerBuild) -> [[[Char]]] -> [CompilerBuild]
forall a b. (a -> b) -> [a] -> [b]
map
          (\[[Char]]
c -> case [[Char]]
c of
            [] -> CompilerBuild
CompilerBuildStandard
            [[Char]]
_ -> [Char] -> CompilerBuild
CompilerBuildSpecialized ([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"-" [[Char]]
c))
          [[[Char]]]
libComponents
      Platform Arch
_ OS
Cabal.FreeBSD -> do
        let getMajorVer :: [Char] -> Maybe Int
getMajorVer = [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
readMaybe ([Char] -> Maybe Int)
-> ([Char] -> Maybe [Char]) -> [Char] -> Maybe Int
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< [[Char]] -> Maybe [Char]
forall a. [a] -> Maybe a
headMaybe ([[Char]] -> Maybe [Char])
-> ([Char] -> [[Char]]) -> [Char] -> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [[Char]]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn [Char]
"."
        Maybe Int
majorVer <- [Char] -> Maybe Int
getMajorVer ([Char] -> Maybe Int) -> RIO env [Char] -> RIO env (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RIO env [Char]
forall env. HasTerm env => RIO env [Char]
sysRelease
        if Maybe Int
majorVer Maybe Int -> Maybe Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
12 :: Int)
          then
            [CompilerBuild] -> RIO env [CompilerBuild]
forall {m :: * -> *} {env}.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
[CompilerBuild] -> m [CompilerBuild]
useBuilds [[Char] -> CompilerBuild
CompilerBuildSpecialized [Char]
"ino64"]
          else
            [CompilerBuild] -> RIO env [CompilerBuild]
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 ShowS -> RIO env [Char] -> RIO env [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RIO env [Char]
forall env. HasTerm env => RIO env [Char]
sysRelease
        [CompilerBuild] -> RIO env [CompilerBuild]
forall {m :: * -> *} {env}.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
[CompilerBuild] -> m [CompilerBuild]
useBuilds [[Char] -> CompilerBuild
CompilerBuildSpecialized [Char]
releaseStr]
      Platform
_ -> [CompilerBuild] -> RIO env [CompilerBuild]
forall {m :: * -> *} {env}.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
[CompilerBuild] -> m [CompilerBuild]
useBuilds [CompilerBuild
CompilerBuildStandard]
  useBuilds :: [CompilerBuild] -> m [CompilerBuild]
useBuilds [CompilerBuild]
builds = do
    Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$
         Utf8Builder
"Potential GHC builds: "
      Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat (Utf8Builder -> [Utf8Builder] -> [Utf8Builder]
forall a. a -> [a] -> [a]
intersperse Utf8Builder
", " ((CompilerBuild -> Utf8Builder) -> [CompilerBuild] -> [Utf8Builder]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString ([Char] -> Utf8Builder)
-> (CompilerBuild -> [Char]) -> CompilerBuild -> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerBuild -> [Char]
compilerBuildName) [CompilerBuild]
builds))
    [CompilerBuild] -> m [CompilerBuild]
forall a. a -> m a
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 = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"-" ([[Char]] -> [Char]) -> ([Char] -> [[Char]]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [[Char]]
prefixMaj ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [[Char]]
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 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
rev) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]] -> [[a]]
k [[a]]
revs
  prefixFst [a]
_ [[a]] -> [[a]]
_ [] = []
  prefixMaj :: [[Char]] -> [[Char]]
prefixMaj = [Char] -> ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall {a}. [a] -> ([[a]] -> [[a]]) -> [[a]] -> [[a]]
prefixFst [Char]
"maj" [[Char]] -> [[Char]]
prefixMin
  prefixMin :: [[Char]] -> [[Char]]
prefixMin = [Char] -> ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall {a}. [a] -> ([[a]] -> [[a]]) -> [[a]] -> [[a]]
prefixFst [Char]
"min" (ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Char
'r':))

sysRelease :: HasTerm env => RIO env String
sysRelease :: forall env. HasTerm env => RIO env [Char]
sysRelease =
  (IOException -> RIO env [Char]) -> RIO env [Char] -> RIO env [Char]
forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOException -> m a) -> m a -> m a
handleIO
    ( \IOException
e -> do
        StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
             [Char] -> StyleDoc
flow [Char]
"Could not query OS version:"
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
string (IOException -> [Char]
forall e. Exception e => e -> [Char]
displayException IOException
e)
        [Char] -> RIO env [Char]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
""
    )
    (IO [Char] -> RIO env [Char]
forall a. IO a -> RIO env a
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 <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL
  Path Rel Dir
containerPlatformDir <-
    ReaderT (Platform, PlatformVariant) (RIO env) (Path Rel Dir)
-> (Platform, PlatformVariant) -> RIO env (Path Rel Dir)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (Platform, PlatformVariant) (RIO env) (Path Rel Dir)
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 Path Abs Dir -> Path Rel Dir -> Path Abs Dir
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 <- Path Abs Dir -> Tool -> RIO env (Path Abs Dir)
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 Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileStack
  Bool
stackExeExists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
stackExePath
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
stackExeExists (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
    [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
      [ [Char] -> StyleDoc
flow [Char]
"Downloading Docker-compatible"
      , [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
stackProgName
      , StyleDoc
"executable."
      ]
    StackReleaseInfo
sri <-
      Maybe [Char]
-> Maybe [Char] -> Maybe [Char] -> RIO env StackReleaseInfo
forall env.
(HasLogFunc env, HasPlatform env) =>
Maybe [Char]
-> Maybe [Char] -> Maybe [Char] -> RIO env StackReleaseInfo
downloadStackReleaseInfo
        Maybe [Char]
forall a. Maybe a
Nothing
        Maybe [Char]
forall a. Maybe a
Nothing
        ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just (Version -> [Char]
versionString Version
stackMinorVersion))
    [(Bool, [Char])]
platforms <-
      ReaderT (Platform, PlatformVariant) (RIO env) [(Bool, [Char])]
-> (Platform, PlatformVariant) -> RIO env [(Bool, [Char])]
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (Platform, PlatformVariant) (RIO env) [(Bool, [Char])]
forall env (m :: * -> *).
(MonadReader env m, HasPlatform env, MonadThrow m) =>
m [(Bool, [Char])]
preferredPlatforms (Platform
containerPlatform, PlatformVariant
PlatformVariantNone)
    [(Bool, [Char])]
-> StackReleaseInfo
-> Path Abs Dir
-> Bool
-> (Path Abs File -> IO ())
-> RIO env ()
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 (IO () -> Path Abs File -> IO ()
forall a b. a -> b -> a
const (IO () -> Path Abs File -> IO ())
-> IO () -> Path Abs File -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  Path Abs File -> RIO env (Path Abs File)
forall a. a -> RIO env a
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 ::
     (HasLogFunc env, HasProcessContext env)
  => WantedCompiler
  -> ConduitT i (Path Abs File) (RIO env) ()
sourceSystemCompilers :: forall env i.
(HasLogFunc env, HasProcessContext env) =>
WantedCompiler -> ConduitT i (Path Abs File) (RIO env) ()
sourceSystemCompilers WantedCompiler
wanted = do
  [[Char]]
searchPath <- Getting [[Char]] env [[Char]]
-> ConduitT i (Path Abs File) (RIO env) [[Char]]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [[Char]] env [[Char]]
forall env. HasProcessContext env => SimpleGetter env [[Char]]
SimpleGetter env [[Char]]
exeSearchPathL
  [[Char]]
names <-
    case WantedCompiler
wanted of
      WCGhc Version
version -> [[Char]] -> ConduitT i (Path Abs File) (RIO env) [[Char]]
forall a. a -> ConduitT i (Path Abs File) (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        [ [Char]
"ghc-" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> [Char]
versionString Version
version
        , [Char]
"ghc"
        ]
      WCGhcjs{} -> CompilerException -> ConduitT i (Path Abs File) (RIO env) [[Char]]
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO CompilerException
GhcjsNotSupported
      WCGhcGit{} -> [[Char]] -> ConduitT i (Path Abs File) (RIO env) [[Char]]
forall a. a -> ConduitT i (Path Abs File) (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [] -- only use sandboxed versions

  [[Char]]
-> ([Char] -> ConduitT i (Path Abs File) (RIO env) ())
-> ConduitT i (Path Abs File) (RIO env) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [[Char]]
names (([Char] -> ConduitT i (Path Abs File) (RIO env) ())
 -> ConduitT i (Path Abs File) (RIO env) ())
-> ([Char] -> ConduitT i (Path Abs File) (RIO env) ())
-> ConduitT i (Path Abs File) (RIO env) ()
forall a b. (a -> b) -> a -> b
$ \[Char]
name -> [[Char]]
-> ([Char] -> ConduitT i (Path Abs File) (RIO env) ())
-> ConduitT i (Path Abs File) (RIO env) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [[Char]]
searchPath (([Char] -> ConduitT i (Path Abs File) (RIO env) ())
 -> ConduitT i (Path Abs File) (RIO env) ())
-> ([Char] -> ConduitT i (Path Abs File) (RIO env) ())
-> ConduitT i (Path Abs File) (RIO env) ()
forall a b. (a -> b) -> a -> b
$ \[Char]
dir -> do
    Path Abs File
fp <- [Char] -> ConduitT i (Path Abs File) (RIO env) (Path Abs File)
forall (m :: * -> *). MonadIO m => [Char] -> m (Path Abs File)
resolveFile' ([Char] -> ConduitT i (Path Abs File) (RIO env) (Path Abs File))
-> [Char] -> ConduitT i (Path Abs File) (RIO env) (Path Abs File)
forall a b. (a -> b) -> a -> b
$ ShowS
addExe ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [Char]
dir [Char] -> ShowS
FP.</> [Char]
name
    Bool
exists <- Path Abs File -> ConduitT i (Path Abs File) (RIO env) Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
fp
    Bool
-> ConduitT i (Path Abs File) (RIO env) ()
-> ConduitT i (Path Abs File) (RIO env) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (ConduitT i (Path Abs File) (RIO env) ()
 -> ConduitT i (Path Abs File) (RIO env) ())
-> ConduitT i (Path Abs File) (RIO env) ()
-> ConduitT i (Path Abs File) (RIO env) ()
forall a b. (a -> b) -> a -> b
$ Path Abs File -> ConduitT i (Path Abs File) (RIO env) ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Path Abs File
fp
 where
  addExe :: ShowS
addExe
    | Bool
osIsWindows = ([Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
".exe")
    | Bool
otherwise = ShowS
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 <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
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 [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
locations' then [[Char]
defaultSetupInfoYaml] else [[Char]]
locations'

  [SetupInfo]
resolvedSetupInfos <- ([Char] -> RIO env SetupInfo) -> [[Char]] -> RIO env [SetupInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [Char] -> RIO env SetupInfo
forall {m :: * -> *} {b} {env}.
(MonadIO m, MonadThrow m, FromJSON (WithJSONWarnings b),
 MonadReader env m, HasLogFunc env) =>
[Char] -> m b
loadSetupInfo [[Char]]
locations
  SetupInfo -> RIO env SetupInfo
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SetupInfo
inlineSetupInfo SetupInfo -> SetupInfo -> SetupInfo
forall a. Semigroup a => a -> a -> a
<> [SetupInfo] -> SetupInfo
forall a. Monoid a => [a] -> a
mconcat [SetupInfo]
resolvedSetupInfos)
 where
  loadSetupInfo :: [Char] -> m b
loadSetupInfo [Char]
urlOrFile = do
    ByteString
bs <- case [Char] -> Maybe Request
forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseUrlThrow [Char]
urlOrFile of
            Just Request
req -> ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> (Response ByteString -> ByteString)
-> Response ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response ByteString -> ByteString
forall a. Response a -> a
getResponseBody (Response ByteString -> ByteString)
-> m (Response ByteString) -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpLbs Request
req
            Maybe Request
Nothing -> IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
S.readFile [Char]
urlOrFile
    WithJSONWarnings b
si [JSONWarning]
warnings <- (ParseException -> m (WithJSONWarnings b))
-> (WithJSONWarnings b -> m (WithJSONWarnings b))
-> Either ParseException (WithJSONWarnings b)
-> m (WithJSONWarnings b)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseException -> m (WithJSONWarnings b)
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM WithJSONWarnings b -> m (WithJSONWarnings b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Either ParseException (WithJSONWarnings b)
forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither' ByteString
bs)
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Char]
urlOrFile [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
defaultSetupInfoYaml) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      [Char] -> [JSONWarning] -> m ()
forall env (m :: * -> *).
(MonadReader env m, HasLogFunc env, HasCallStack, MonadIO m) =>
[Char] -> [JSONWarning] -> m ()
logJSONWarnings [Char]
urlOrFile [JSONWarning]
warnings
    b -> m b
forall a. a -> m a
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 (PackageIdentifier -> Tool)
-> Maybe PackageIdentifier -> Maybe Tool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  (PackageIdentifier -> PackageIdentifier -> Ordering)
-> [PackageIdentifier] -> Maybe PackageIdentifier
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> Maybe a
maximumByMaybe ((PackageIdentifier -> Version)
-> PackageIdentifier -> PackageIdentifier -> Ordering
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
  Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
programsDir
  (Path Abs File
file, ArchiveType
at) <- Path Abs Dir
-> DownloadInfo -> Tool -> RIO env (Path Abs File, ArchiveType)
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 <- Path Abs Dir -> Tool -> RIO env (Path Abs 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 <- Path Abs Dir -> Tool -> RIO env (Path Abs Dir)
forall env (m :: * -> *).
(MonadReader env m, MonadThrow m) =>
Path Abs Dir -> Tool -> m (Path Abs Dir)
tempInstallDir Path Abs Dir
programsDir Tool
tool
  IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path Abs Dir
tempDir)
  Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
tempDir
  Path Abs Dir -> Tool -> RIO env ()
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
  Path Abs Dir -> Tool -> RIO env ()
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs Dir -> Tool -> m ()
markInstalled Path Abs Dir
programsDir Tool
tool
  IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path Abs Dir
tempDir)
  Tool -> RIO env Tool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tool
tool

-- Exceptions thrown by this function are caught by

-- 'downloadAndInstallPossibleCompilers'.

downloadAndInstallCompiler ::
     (HasBuildConfig env, HasGHCVariant env)
  => CompilerBuild
  -> SetupInfo
  -> WantedCompiler
  -> VersionCheck
  -> Maybe String
  -> RIO env Tool
downloadAndInstallCompiler :: 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 <- Getting GHCVariant env GHCVariant -> RIO env GHCVariant
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting GHCVariant env GHCVariant
forall env. HasGHCVariant env => SimpleGetter env GHCVariant
SimpleGetter env GHCVariant
ghcVariantL
  (Version
selectedVersion, GHCDownloadInfo
downloadInfo) <- case Maybe [Char]
mbindistURL of
    Just [Char]
bindistURL -> do
      case GHCVariant
ghcVariant of
        GHCCustom [Char]
_ -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        GHCVariant
_ -> SetupPrettyException -> RIO env ()
forall e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SetupPrettyException
RequireCustomGHCVariant
      (Version, GHCDownloadInfo) -> RIO env (Version, GHCDownloadInfo)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( Version
version
        , [Text] -> Map Text Text -> DownloadInfo -> GHCDownloadInfo
GHCDownloadInfo [Text]
forall a. Monoid a => a
mempty Map Text Text
forall a. Monoid a => a
mempty DownloadInfo
            { downloadInfoUrl :: Text
downloadInfoUrl = [Char] -> Text
T.pack [Char]
bindistURL
            , downloadInfoContentLength :: Maybe Int
downloadInfoContentLength = Maybe Int
forall a. Maybe a
Nothing
            , downloadInfoSha1 :: Maybe ByteString
downloadInfoSha1 = Maybe ByteString
forall a. Maybe a
Nothing
            , downloadInfoSha256 :: Maybe ByteString
downloadInfoSha256 = Maybe ByteString
forall a. Maybe a
Nothing
            }
        )
    Maybe [Char]
_ -> do
      Text
ghcKey <- CompilerBuild -> RIO env Text
forall env (m :: * -> *).
(MonadReader env m, HasPlatform env, HasGHCVariant env,
 MonadThrow m) =>
CompilerBuild -> m Text
getGhcKey CompilerBuild
ghcBuild
      case Text
-> Map Text (Map Version GHCDownloadInfo)
-> Maybe (Map Version GHCDownloadInfo)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
ghcKey (Map Text (Map Version GHCDownloadInfo)
 -> Maybe (Map Version GHCDownloadInfo))
-> Map Text (Map Version GHCDownloadInfo)
-> Maybe (Map Version GHCDownloadInfo)
forall a b. (a -> b) -> a -> b
$ SetupInfo -> Map Text (Map Version GHCDownloadInfo)
siGHCs SetupInfo
si of
        Maybe (Map Version GHCDownloadInfo)
Nothing -> SetupPrettyException -> RIO env (Version, GHCDownloadInfo)
forall e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (SetupPrettyException -> RIO env (Version, GHCDownloadInfo))
-> SetupPrettyException -> RIO env (Version, GHCDownloadInfo)
forall a b. (a -> b) -> a -> b
$ Text -> SetupPrettyException
UnknownOSKey Text
ghcKey
        Just Map Version GHCDownloadInfo
pairs_ ->
          Text
-> VersionCheck
-> WantedCompiler
-> (Version -> ActualCompiler)
-> Map Version GHCDownloadInfo
-> RIO env (Version, GHCDownloadInfo)
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 <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
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 -> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
forall env.
HasBuildConfig env =>
SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
installGHCWindows
          Platform
_ -> GHCDownloadInfo
-> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
forall env.
HasConfig env =>
GHCDownloadInfo
-> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
installGHCPosix GHCDownloadInfo
downloadInfo
  StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    [StyleDoc] -> StyleDoc
fillSep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$
         [Char] -> StyleDoc
flow [Char]
"Preparing to install GHC"
      StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
:  case GHCVariant
ghcVariant of
           GHCVariant
GHCStandard -> []
           GHCVariant
v -> [StyleDoc
"(" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString (GHCVariant -> [Char]
ghcVariantName GHCVariant
v) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
")"]
      [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> case CompilerBuild
ghcBuild of
           CompilerBuild
CompilerBuildStandard -> []
           CompilerBuild
b -> [StyleDoc
"(" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString (CompilerBuild -> [Char]
compilerBuildName CompilerBuild
b) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
")"]
      [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> [ [Char] -> StyleDoc
flow [Char]
"to an isolated location. This will not interfere with any \
                \system-level installation."
         ]
  PackageName
ghcPkgName <- [Char] -> RIO env PackageName
forall (m :: * -> *). MonadThrow m => [Char] -> m PackageName
parsePackageNameThrowing
    ([Char]
"ghc" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ GHCVariant -> [Char]
ghcVariantSuffix GHCVariant
ghcVariant [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ CompilerBuild -> [Char]
compilerBuildSuffix CompilerBuild
ghcBuild)
  let tool :: Tool
tool = PackageIdentifier -> Tool
Tool (PackageIdentifier -> Tool) -> PackageIdentifier -> Tool
forall a b. (a -> b) -> a -> b
$ PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
ghcPkgName Version
selectedVersion
  Path Abs Dir
-> DownloadInfo
-> Tool
-> (Path Abs File
    -> ArchiveType -> Path Abs Dir -> Path Abs Dir -> RIO env ())
-> RIO env 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)
    (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]
_ = CompilerException -> RIO env Tool
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO CompilerException
GhcjsNotSupported

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

-- Exceptions thrown by this function are caught by

-- 'downloadAndInstallPossibleCompilers'.

getWantedCompilerInfo ::
     (Ord k, MonadThrow m)
  => Text
  -> VersionCheck
  -> WantedCompiler
  -> (k -> ActualCompiler)
  -> Map k a
  -> m (k, a)
getWantedCompilerInfo :: 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 -> (k, a) -> m (k, a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (k, a)
pair
    Maybe (k, a)
Nothing -> SetupPrettyException -> m (k, a)
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (SetupPrettyException -> m (k, a))
-> SetupPrettyException -> m (k, a)
forall a b. (a -> b) -> a -> b
$
      Set Text
-> WantedCompiler -> Set ActualCompiler -> SetupPrettyException
UnknownCompilerVersion
        (Text -> Set Text
forall a. a -> Set a
Set.singleton Text
key)
        WantedCompiler
wanted
        ([ActualCompiler] -> Set ActualCompiler
forall a. Ord a => [a] -> Set a
Set.fromList ([ActualCompiler] -> Set ActualCompiler)
-> [ActualCompiler] -> Set ActualCompiler
forall a b. (a -> b) -> a -> b
$ (k -> ActualCompiler) -> [k] -> [ActualCompiler]
forall a b. (a -> b) -> [a] -> [b]
map k -> ActualCompiler
toCV (Map k a -> [k]
forall k a. Map k a -> [k]
Map.keys Map k a
pairs_))
 where
  mpair :: Maybe (k, a)
mpair =
    [(k, a)] -> Maybe (k, a)
forall a. [a] -> Maybe a
listToMaybe ([(k, a)] -> Maybe (k, a)) -> [(k, a)] -> Maybe (k, a)
forall a b. (a -> b) -> a -> b
$
    ((k, a) -> Down k) -> [(k, a)] -> [(k, a)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (k -> Down k
forall a. a -> Down a
Down (k -> Down k) -> ((k, a) -> k) -> (k, a) -> Down k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k, a) -> k
forall a b. (a, b) -> a
fst) ([(k, a)] -> [(k, a)]) -> [(k, a)] -> [(k, a)]
forall a b. (a -> b) -> a -> b
$
    ((k, a) -> Bool) -> [(k, a)] -> [(k, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter
      (VersionCheck -> WantedCompiler -> ActualCompiler -> Bool
isWantedCompiler VersionCheck
versionCheck WantedCompiler
wanted (ActualCompiler -> Bool)
-> ((k, a) -> ActualCompiler) -> (k, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> ActualCompiler
toCV (k -> ActualCompiler) -> ((k, a) -> k) -> (k, a) -> ActualCompiler
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k, a) -> k
forall a b. (a, b) -> a
fst)
      (Map k a -> [(k, a)]
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 SetupPrettyException -> RIO env (Tool, CompilerBuild)
go [CompilerBuild]
possibleCompilers Maybe SetupPrettyException
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 SetupPrettyException -> RIO env (Tool, CompilerBuild)
go [] Maybe SetupPrettyException
Nothing = SetupPrettyException -> RIO env (Tool, CompilerBuild)
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM SetupPrettyException
UnsupportedSetupConfiguration
  go [] (Just SetupPrettyException
e) = SetupPrettyException -> RIO env (Tool, CompilerBuild)
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM SetupPrettyException
e
  go (CompilerBuild
b:[CompilerBuild]
bs) Maybe SetupPrettyException
e = do
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Trying to setup GHC build: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString (CompilerBuild -> [Char]
compilerBuildName CompilerBuild
b)
    Either SetupPrettyException Tool
er <- RIO env Tool -> RIO env (Either SetupPrettyException Tool)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (RIO env Tool -> RIO env (Either SetupPrettyException Tool))
-> RIO env Tool -> RIO env (Either SetupPrettyException Tool)
forall a b. (a -> b) -> a -> b
$ CompilerBuild
-> SetupInfo
-> WantedCompiler
-> VersionCheck
-> Maybe [Char]
-> RIO env Tool
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 SetupPrettyException Tool
er of
      Left e' :: SetupPrettyException
e'@(UnknownCompilerVersion Set Text
ks' WantedCompiler
w' Set ActualCompiler
vs') ->
        case Maybe SetupPrettyException
e of
          Maybe SetupPrettyException
Nothing -> [CompilerBuild]
-> Maybe SetupPrettyException -> RIO env (Tool, CompilerBuild)
go [CompilerBuild]
bs (SetupPrettyException -> Maybe SetupPrettyException
forall a. a -> Maybe a
Just SetupPrettyException
e')
          Just (UnknownOSKey Text
k) ->
            [CompilerBuild]
-> Maybe SetupPrettyException -> RIO env (Tool, CompilerBuild)
go [CompilerBuild]
bs (Maybe SetupPrettyException -> RIO env (Tool, CompilerBuild))
-> Maybe SetupPrettyException -> RIO env (Tool, CompilerBuild)
forall a b. (a -> b) -> a -> b
$ SetupPrettyException -> Maybe SetupPrettyException
forall a. a -> Maybe a
Just (SetupPrettyException -> Maybe SetupPrettyException)
-> SetupPrettyException -> Maybe SetupPrettyException
forall a b. (a -> b) -> a -> b
$ Set Text
-> WantedCompiler -> Set ActualCompiler -> SetupPrettyException
UnknownCompilerVersion (Text -> Set Text -> Set Text
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 SetupPrettyException -> RIO env (Tool, CompilerBuild)
go [CompilerBuild]
bs (Maybe SetupPrettyException -> RIO env (Tool, CompilerBuild))
-> Maybe SetupPrettyException -> RIO env (Tool, CompilerBuild)
forall a b. (a -> b) -> a -> b
$ SetupPrettyException -> Maybe SetupPrettyException
forall a. a -> Maybe a
Just (SetupPrettyException -> Maybe SetupPrettyException)
-> SetupPrettyException -> Maybe SetupPrettyException
forall a b. (a -> b) -> a -> b
$
              Set Text
-> WantedCompiler -> Set ActualCompiler -> SetupPrettyException
UnknownCompilerVersion (Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Text
ks' Set Text
ks) WantedCompiler
w' (Set ActualCompiler -> Set ActualCompiler -> Set ActualCompiler
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set ActualCompiler
vs' Set ActualCompiler
vs)
          Just SetupPrettyException
x -> SetupPrettyException -> RIO env (Tool, CompilerBuild)
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM SetupPrettyException
x
      Left e' :: SetupPrettyException
e'@(UnknownOSKey Text
k') ->
        case Maybe SetupPrettyException
e of
          Maybe SetupPrettyException
Nothing -> [CompilerBuild]
-> Maybe SetupPrettyException -> RIO env (Tool, CompilerBuild)
go [CompilerBuild]
bs (SetupPrettyException -> Maybe SetupPrettyException
forall a. a -> Maybe a
Just SetupPrettyException
e')
          Just (UnknownOSKey Text
_) -> [CompilerBuild]
-> Maybe SetupPrettyException -> RIO env (Tool, CompilerBuild)
go [CompilerBuild]
bs Maybe SetupPrettyException
e
          Just (UnknownCompilerVersion Set Text
ks WantedCompiler
w Set ActualCompiler
vs) ->
            [CompilerBuild]
-> Maybe SetupPrettyException -> RIO env (Tool, CompilerBuild)
go [CompilerBuild]
bs (Maybe SetupPrettyException -> RIO env (Tool, CompilerBuild))
-> Maybe SetupPrettyException -> RIO env (Tool, CompilerBuild)
forall a b. (a -> b) -> a -> b
$ SetupPrettyException -> Maybe SetupPrettyException
forall a. a -> Maybe a
Just (SetupPrettyException -> Maybe SetupPrettyException)
-> SetupPrettyException -> Maybe SetupPrettyException
forall a b. (a -> b) -> a -> b
$ Set Text
-> WantedCompiler -> Set ActualCompiler -> SetupPrettyException
UnknownCompilerVersion (Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
Set.insert Text
k' Set Text
ks) WantedCompiler
w Set ActualCompiler
vs
          Just SetupPrettyException
x -> SetupPrettyException -> RIO env (Tool, CompilerBuild)
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM SetupPrettyException
x
      Left SetupPrettyException
e' -> SetupPrettyException -> RIO env (Tool, CompilerBuild)
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM SetupPrettyException
e'
      Right Tool
r -> (Tool, CompilerBuild) -> RIO env (Tool, CompilerBuild)
forall a. a -> RIO env a
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 <- Getting GHCVariant env GHCVariant -> m GHCVariant
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting GHCVariant env GHCVariant
forall env. HasGHCVariant env => SimpleGetter env GHCVariant
SimpleGetter env GHCVariant
ghcVariantL
  Platform
platform <- Getting Platform env Platform -> m Platform
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Platform env Platform
forall env. HasPlatform env => Lens' env Platform
Lens' env Platform
platformL
  Text
osKey <- Platform -> m Text
forall (m :: * -> *). MonadThrow m => Platform -> m Text
getOSKey Platform
platform
  Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$
       Text
osKey
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (GHCVariant -> [Char]
ghcVariantSuffix GHCVariant
ghcVariant)
    Text -> Text -> Text
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   -> Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"linux32"
    Platform Arch
X86_64                OS
Cabal.Linux   -> Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"linux64"
    Platform Arch
I386                  OS
Cabal.OSX     -> Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"macosx"
    Platform Arch
X86_64                OS
Cabal.OSX     -> Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"macosx"
    Platform Arch
I386                  OS
Cabal.FreeBSD -> Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"freebsd32"
    Platform Arch
X86_64                OS
Cabal.FreeBSD -> Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"freebsd64"
    Platform Arch
I386                  OS
Cabal.OpenBSD -> Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"openbsd32"
    Platform Arch
X86_64                OS
Cabal.OpenBSD -> Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"openbsd64"
    Platform Arch
I386                  OS
Cabal.Windows -> Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"windows32"
    Platform Arch
X86_64                OS
Cabal.Windows -> Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"windows64"
    Platform Arch
Arm                   OS
Cabal.Linux   -> Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"linux-armv7"
    Platform Arch
AArch64               OS
Cabal.Linux   -> Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"linux-aarch64"
    Platform Arch
Sparc                 OS
Cabal.Linux   -> Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"linux-sparc"
    Platform Arch
AArch64               OS
Cabal.OSX     -> Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"macosx-aarch64"
    Platform Arch
AArch64               OS
Cabal.FreeBSD -> Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"freebsd-aarch64"
    Platform Arch
arch OS
os -> SetupPrettyException -> m Text
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (SetupPrettyException -> m Text) -> SetupPrettyException -> m Text
forall a b. (a -> b) -> a -> b
$ OS -> Arch -> SetupPrettyException
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
    ([Char] -> Maybe Request
forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseUrlThrow -> Just Request
_) -> do
      Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
destination)
      Text -> DownloadInfo -> Path Abs File -> RIO env ()
forall env.
HasTerm env =>
Text -> DownloadInfo -> Path Abs File -> RIO env ()
chattyDownload Text
downloadLabel DownloadInfo
downloadInfo Path Abs File
destination
      Path Abs File -> RIO env (Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
destination
    ([Char] -> Maybe (Path Abs File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs File)
parseAbsFile -> Just Path Abs File
path) -> do
      RIO env ()
warnOnIgnoredChecks
      Path Abs File -> RIO env (Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
path
    ([Char] -> Maybe (Path Rel File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile -> Just Path Rel File
path) -> do
      RIO env ()
warnOnIgnoredChecks
      Path Abs Dir
root <- Getting (Path Abs Dir) env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) env (Path Abs Dir)
forall env r. HasBuildConfig env => Getting r env (Path Abs Dir)
projectRootL
      Path Abs File -> RIO env (Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir
root Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
path)
    [Char]
_ -> SetupPrettyException -> RIO env (Path Abs File)
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (SetupPrettyException -> RIO env (Path Abs File))
-> SetupPrettyException -> RIO env (Path Abs File)
forall a b. (a -> b) -> a -> b
$ [Char] -> SetupPrettyException
URLInvalid [Char]
url
 where
  url :: [Char]
url = Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
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
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust Maybe Int
contentLength) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
      [Char] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[Char] -> m ()
prettyWarnS
        [Char]
"`content-length` is not checked and should not be specified when \
        \`url` is a file path."
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
sha1) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
      [Char] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[Char] -> m ()
prettyWarnS
        [Char]
"`sha1` is not checked and should not be specified when `url` is a \
        \file path."
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
sha256) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
      StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn
        StyleDoc
"`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" -> ArchiveType -> RIO env ArchiveType
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ArchiveType
TarXz
      [Char]
".tar.bz2" -> ArchiveType -> RIO env ArchiveType
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ArchiveType
TarBz2
      [Char]
".tar.gz" -> ArchiveType -> RIO env ArchiveType
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ArchiveType
TarGz
      [Char]
".7z.exe" -> ArchiveType -> RIO env ArchiveType
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ArchiveType
SevenZ
      [Char]
_ -> SetupPrettyException -> RIO env ArchiveType
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (SetupPrettyException -> RIO env ArchiveType)
-> SetupPrettyException -> RIO env ArchiveType
forall a b. (a -> b) -> a -> b
$ [Char] -> SetupPrettyException
UnknownArchiveExtension [Char]
url

  Path Rel File
relativeFile <- [Char] -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile ([Char] -> RIO env (Path Rel File))
-> [Char] -> RIO env (Path Rel File)
forall a b. (a -> b) -> a -> b
$ Tool -> [Char]
toolString Tool
tool [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
extension
  let destinationPath :: Path Abs File
destinationPath = Path Abs Dir
programsDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relativeFile
  Path Abs File
localPath <-
    Text -> DownloadInfo -> Path Abs File -> RIO env (Path Abs File)
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
  (Path Abs File, ArchiveType)
-> RIO env (Path Abs File, ArchiveType)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs File
localPath, ArchiveType
archiveType)

 where
  url :: [Char]
url = Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
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 [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
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' [Char] -> ShowS
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 <- Getting Platform env Platform -> RIO env Platform
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Platform env Platform
forall env. HasPlatform env => Lens' env Platform
Lens' env Platform
platformL
  ProcessContext
menv0 <- Getting ProcessContext env ProcessContext -> RIO env ProcessContext
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ProcessContext env ProcessContext
forall env. HasProcessContext env => Lens' env ProcessContext
Lens' env ProcessContext
processContextL
  ProcessContext
menv <- Map Text Text -> RIO env ProcessContext
forall (m :: * -> *).
MonadIO m =>
Map Text Text -> m ProcessContext
mkProcessContext (Map Text Text -> Map Text Text
removeHaskellEnvVars (Getting (Map Text Text) ProcessContext (Map Text Text)
-> ProcessContext -> Map Text Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Map Text Text) ProcessContext (Map Text Text)
forall env.
HasProcessContext env =>
SimpleGetter env (Map Text Text)
SimpleGetter ProcessContext (Map Text Text)
envVarsL ProcessContext
menv0))
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"menv = " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Map Text Text -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (Getting (Map Text Text) ProcessContext (Map Text Text)
-> ProcessContext -> Map Text Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Map Text Text) ProcessContext (Map Text Text)
forall env.
HasProcessContext env =>
SimpleGetter env (Map Text Text)
SimpleGetter ProcessContext (Map Text Text)
envVarsL ProcessContext
menv)
  ([Char]
zipTool', Char
compOpt) <-
    case ArchiveType
archiveType of
      ArchiveType
TarXz -> ([Char], Char) -> RIO env ([Char], Char)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"xz", Char
'J')
      ArchiveType
TarBz2 -> ([Char], Char) -> RIO env ([Char], Char)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"bzip2", Char
'j')
      ArchiveType
TarGz -> ([Char], Char) -> RIO env ([Char], Char)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"gzip", Char
'z')
      ArchiveType
SevenZ -> SetupPrettyException -> RIO env ([Char], Char)
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO SetupPrettyException
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) -> [Char] -> CheckDependency env [Char]
forall env.
HasProcessContext env =>
[Char] -> CheckDependency env [Char]
checkDependency [Char]
"gtar"
          (Platform, ArchiveType)
_ -> [Char] -> CheckDependency env [Char]
forall env.
HasProcessContext env =>
[Char] -> CheckDependency env [Char]
checkDependency [Char]
"tar"
  ([Char]
zipTool, [Char]
makeTool, [Char]
tarTool) <- CheckDependency env ([Char], [Char], [Char])
-> RIO env ([Char], [Char], [Char])
forall env a. CheckDependency env a -> RIO env a
checkDependencies (CheckDependency env ([Char], [Char], [Char])
 -> RIO env ([Char], [Char], [Char]))
-> CheckDependency env ([Char], [Char], [Char])
-> RIO env ([Char], [Char], [Char])
forall a b. (a -> b) -> a -> b
$ (,,)
    ([Char] -> [Char] -> [Char] -> ([Char], [Char], [Char]))
-> CheckDependency env [Char]
-> CheckDependency
     env ([Char] -> [Char] -> ([Char], [Char], [Char]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> CheckDependency env [Char]
forall env.
HasProcessContext env =>
[Char] -> CheckDependency env [Char]
checkDependency [Char]
zipTool'
    CheckDependency env ([Char] -> [Char] -> ([Char], [Char], [Char]))
-> CheckDependency env [Char]
-> CheckDependency env ([Char] -> ([Char], [Char], [Char]))
forall a b.
CheckDependency env (a -> b)
-> CheckDependency env a -> CheckDependency env b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([Char] -> CheckDependency env [Char]
forall env.
HasProcessContext env =>
[Char] -> CheckDependency env [Char]
checkDependency [Char]
"gmake" CheckDependency env [Char]
-> CheckDependency env [Char] -> CheckDependency env [Char]
forall a.
CheckDependency env a
-> CheckDependency env a -> CheckDependency env a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Char] -> CheckDependency env [Char]
forall env.
HasProcessContext env =>
[Char] -> CheckDependency env [Char]
checkDependency [Char]
"make")
    CheckDependency env ([Char] -> ([Char], [Char], [Char]))
-> CheckDependency env [Char]
-> CheckDependency env ([Char], [Char], [Char])
forall a b.
CheckDependency env (a -> b)
-> CheckDependency env a -> CheckDependency env b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CheckDependency env [Char]
tarDep

  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"ziptool: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString [Char]
zipTool
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"make: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString [Char]
makeTool
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"tar: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
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' <- ProcessContext
-> (Map Text Text -> Map Text Text) -> RIO env ProcessContext
forall (m :: * -> *).
MonadIO m =>
ProcessContext
-> (Map Text Text -> Map Text Text) -> m ProcessContext
modifyEnvVars ProcessContext
menv (Map Text Text -> Map Text Text -> Map Text Text
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 = ConduitT ByteString ByteString m ()
forall (m :: * -> *).
Monad m =>
ConduitT ByteString ByteString m ()
CB.lines ConduitT ByteString ByteString m ()
-> ConduitT ByteString c m () -> ConduitT ByteString c m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (ByteString -> m ()) -> ConduitT ByteString c m ()
forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ (Utf8Builder -> m ()
lvl (Utf8Builder -> m ())
-> (ByteString -> Utf8Builder) -> ByteString -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Utf8Builder
displayBytesUtf8)
            logStdout :: ConduitT ByteString c (RIO env) ()
logStdout = (Utf8Builder -> RIO env ()) -> ConduitT ByteString c (RIO env) ()
forall {m :: * -> *} {c}.
Monad m =>
(Utf8Builder -> m ()) -> ConduitT ByteString c m ()
logLines Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug
            logStderr :: ConduitT ByteString c (RIO env) ()
logStderr = (Utf8Builder -> RIO env ()) -> ConduitT ByteString c (RIO env) ()
forall {m :: * -> *} {c}.
Monad m =>
(Utf8Builder -> m ()) -> ConduitT ByteString c m ()
logLines Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError
        RIO env ((), ()) -> RIO env ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO env ((), ()) -> RIO env ()) -> RIO env ((), ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [Char] -> RIO env ((), ()) -> RIO env ((), ())
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
[Char] -> m a -> m a
withWorkingDir (Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
wd) (RIO env ((), ()) -> RIO env ((), ()))
-> RIO env ((), ()) -> RIO env ((), ())
forall a b. (a -> b) -> a -> b
$
          ProcessContext -> RIO env ((), ()) -> RIO env ((), ())
forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv' (RIO env ((), ()) -> RIO env ((), ()))
-> RIO env ((), ()) -> RIO env ((), ())
forall a b. (a -> b) -> a -> b
$
          [Char]
-> [[Char]]
-> ConduitM ByteString Void (RIO env) ()
-> ConduitM ByteString Void (RIO env) ()
-> RIO env ((), ())
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 ConduitM ByteString Void (RIO env) ()
forall {c}. ConduitT ByteString c (RIO env) ()
logStderr ConduitM ByteString Void (RIO env) ()
forall {c}. ConduitT ByteString c (RIO env) ()
logStdout
          RIO env ((), ())
-> (SomeException -> RIO env ((), ())) -> RIO env ((), ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
ex ->
            SetupPrettyException -> RIO env ((), ())
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (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)

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

  Path Abs Dir
dir <- Path Abs File -> Path Abs Dir -> RIO env (Path Abs 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 <- Getting (Maybe (Path Abs File)) env (Maybe (Path Abs File))
-> RIO env (Maybe (Path Abs File))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Maybe (Path Abs File)) env (Maybe (Path Abs File))
 -> RIO env (Maybe (Path Abs File)))
-> Getting (Maybe (Path Abs File)) env (Maybe (Path Abs File))
-> RIO env (Maybe (Path Abs File))
forall a b. (a -> b) -> a -> b
$ (Config -> Const (Maybe (Path Abs File)) Config)
-> env -> Const (Maybe (Path Abs File)) env
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL((Config -> Const (Maybe (Path Abs File)) Config)
 -> env -> Const (Maybe (Path Abs File)) env)
-> ((Maybe (Path Abs File)
     -> Const (Maybe (Path Abs File)) (Maybe (Path Abs File)))
    -> Config -> Const (Maybe (Path Abs File)) Config)
-> Getting (Maybe (Path Abs File)) env (Maybe (Path Abs File))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> Maybe (Path Abs File))
-> SimpleGetter Config (Maybe (Path Abs File))
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 =
                      k -> Text -> Map k Text
forall k a. k -> a -> Map k a
Map.singleton k
"CC" (Text -> Map k Text) -> Text -> Map k Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack (Path b t -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path b t
p)
                in  Path Abs File -> Map Text Text
forall {k} {b} {t}. IsString k => Path b t -> Map k Text
gccEnvFromPath (Path Abs File -> Map Text Text)
-> Maybe (Path Abs File) -> Maybe (Map Text Text)
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 =
        Map Text Text -> Maybe (Map Text Text) -> Map Text Text
forall a. a -> Maybe a -> a
fromMaybe Map Text Text
forall k a. Map k a
Map.empty Maybe (Map Text Text)
mGccEnv Map Text Text -> Map Text Text -> Map Text Text
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` GHCDownloadInfo -> Map Text Text
gdiConfigureEnv GHCDownloadInfo
downloadInfo

  Utf8Builder -> RIO env ()
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
    (Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath (Path Abs File -> [Char]) -> Path Abs File -> [Char]
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
dir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileConfigure)
    ( ([Char]
"--prefix=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
destDir)
    [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: (Text -> [Char]) -> [Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
T.unpack (GHCDownloadInfo -> [Text]
gdiConfigureOpts GHCDownloadInfo
downloadInfo)
    )

  Utf8Builder -> RIO env ()
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 Map Text Text
forall a. Monoid a => a
mempty [Char]
makeTool [[Char]
"install"]

  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone Utf8Builder
"Installed GHC."
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"GHC installed to " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString (Path Abs Dir -> [Char]
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 RIO env (Either [[Char]] a)
-> (Either [[Char]] a -> RIO env a) -> RIO env a
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([[Char]] -> RIO env a)
-> (a -> RIO env a) -> Either [[Char]] a -> RIO env a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (SetupPrettyException -> RIO env a
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (SetupPrettyException -> RIO env a)
-> ([[Char]] -> SetupPrettyException) -> [[Char]] -> RIO env a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> SetupPrettyException
MissingDependencies) a -> RIO env a
forall a. a -> RIO env a
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 = RIO env (Either [[Char]] [Char]) -> CheckDependency env [Char]
forall env a. RIO env (Either [[Char]] a) -> CheckDependency env a
CheckDependency (RIO env (Either [[Char]] [Char]) -> CheckDependency env [Char])
-> RIO env (Either [[Char]] [Char]) -> CheckDependency env [Char]
forall a b. (a -> b) -> a -> b
$ do
  Bool
exists <- [Char] -> RIO env Bool
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
[Char] -> m Bool
doesExecutableExist [Char]
tool
  Either [[Char]] [Char] -> RIO env (Either [[Char]] [Char])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [[Char]] [Char] -> RIO env (Either [[Char]] [Char]))
-> Either [[Char]] [Char] -> RIO env (Either [[Char]] [Char])
forall a b. (a -> b) -> a -> b
$ if Bool
exists then [Char] -> Either [[Char]] [Char]
forall a b. b -> Either a b
Right [Char]
tool else [[Char]] -> Either [[Char]] [Char]
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 -> b) -> CheckDependency env a -> CheckDependency env b)
-> (forall a b.
    a -> CheckDependency env b -> CheckDependency env a)
-> Functor (CheckDependency env)
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
$cfmap :: forall env a b.
(a -> b) -> CheckDependency env a -> CheckDependency env b
fmap :: forall a b.
(a -> b) -> CheckDependency env a -> CheckDependency env b
$c<$ :: forall env a b. a -> CheckDependency env b -> CheckDependency env a
<$ :: forall a b. a -> CheckDependency env b -> CheckDependency env a
Functor

instance Applicative (CheckDependency env) where
  pure :: forall a. a -> CheckDependency env a
pure a
x = RIO env (Either [[Char]] a) -> CheckDependency env a
forall env a. RIO env (Either [[Char]] a) -> CheckDependency env a
CheckDependency (RIO env (Either [[Char]] a) -> CheckDependency env a)
-> RIO env (Either [[Char]] a) -> CheckDependency env a
forall a b. (a -> b) -> a -> b
$ Either [[Char]] a -> RIO env (Either [[Char]] a)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either [[Char]] a
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 = RIO env (Either [[Char]] b) -> CheckDependency env b
forall env a. RIO env (Either [[Char]] a) -> CheckDependency env a
CheckDependency (RIO env (Either [[Char]] b) -> CheckDependency env b)
-> RIO env (Either [[Char]] b) -> CheckDependency env b
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
    Either [[Char]] b -> RIO env (Either [[Char]] b)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [[Char]] b -> RIO env (Either [[Char]] b))
-> Either [[Char]] b -> RIO env (Either [[Char]] b)
forall a b. (a -> b) -> a -> b
$
      case (Either [[Char]] (a -> b)
f', Either [[Char]] a
x') of
        (Left [[Char]]
e1, Left [[Char]]
e2) -> [[Char]] -> Either [[Char]] b
forall a b. a -> Either a b
Left ([[Char]] -> Either [[Char]] b) -> [[Char]] -> Either [[Char]] b
forall a b. (a -> b) -> a -> b
$ [[Char]]
e1 [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
e2
        (Left [[Char]]
e, Right a
_) -> [[Char]] -> Either [[Char]] b
forall a b. a -> Either a b
Left [[Char]]
e
        (Right a -> b
_, Left [[Char]]
e) -> [[Char]] -> Either [[Char]] b
forall a b. a -> Either a b
Left [[Char]]
e
        (Right a -> b
f'', Right a
x'') -> b -> Either [[Char]] b
forall a b. b -> Either a b
Right (b -> Either [[Char]] b) -> b -> Either [[Char]] b
forall a b. (a -> b) -> a -> b
$ a -> b
f'' a
x''

instance Alternative (CheckDependency env) where
  empty :: forall a. CheckDependency env a
empty = RIO env (Either [[Char]] a) -> CheckDependency env a
forall env a. RIO env (Either [[Char]] a) -> CheckDependency env a
CheckDependency (RIO env (Either [[Char]] a) -> CheckDependency env a)
-> RIO env (Either [[Char]] a) -> CheckDependency env a
forall a b. (a -> b) -> a -> b
$ Either [[Char]] a -> RIO env (Either [[Char]] a)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [[Char]] a -> RIO env (Either [[Char]] a))
-> Either [[Char]] a -> RIO env (Either [[Char]] a)
forall a b. (a -> b) -> a -> b
$ [[Char]] -> Either [[Char]] a
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 = RIO env (Either [[Char]] a) -> CheckDependency env a
forall env a. RIO env (Either [[Char]] a) -> CheckDependency env a
CheckDependency (RIO env (Either [[Char]] a) -> CheckDependency env a)
-> RIO env (Either [[Char]] a) -> CheckDependency env a
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' -> Either [[Char]] a -> RIO env (Either [[Char]] a)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [[Char]] a -> RIO env (Either [[Char]] a))
-> Either [[Char]] a -> RIO env (Either [[Char]] a)
forall a b. (a -> b) -> a -> b
$ a -> Either [[Char]] a
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
  [Char]
-> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> RIO env ()
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
  [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
    [ [Char] -> StyleDoc
flow [Char]
"GHC installed to"
    , Path Abs Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
destDir StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
    ]

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 <- IO Bool -> RIO env Bool
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RIO env Bool) -> IO Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
D.doesDirectoryExist ([Char] -> IO Bool) -> [Char] -> IO Bool
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
destDir
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ()
D.removeDirectoryRecursive ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
destDir) RIO env () -> (IOException -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (IOException -> m a) -> m a
`catchIO` \IOException
e ->
      SetupPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (SetupPrettyException -> RIO env ())
-> SetupPrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> IOException -> SetupPrettyException
ExistingMSYS2NotDeleted Path Abs Dir
destDir IOException
e

  [Char]
-> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> RIO env ()
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 <- Getting ProcessContext env ProcessContext -> RIO env ProcessContext
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ProcessContext env ProcessContext
forall env. HasProcessContext env => Lens' env ProcessContext
Lens' env ProcessContext
processContextL
  ProcessContext
newEnv0 <- ProcessContext
-> (Map Text Text -> Map Text Text) -> RIO env ProcessContext
forall (m :: * -> *).
MonadIO m =>
ProcessContext
-> (Map Text Text -> Map Text Text) -> m ProcessContext
modifyEnvVars ProcessContext
menv0 ((Map Text Text -> Map Text Text) -> RIO env ProcessContext)
-> (Map Text Text -> Map Text Text) -> RIO env ProcessContext
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Map Text Text -> Map Text Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"MSYSTEM" Text
"MSYS"
  Map Text Text
newEnv <- (ProcessException -> RIO env (Map Text Text))
-> (Map Text Text -> RIO env (Map Text Text))
-> Either ProcessException (Map Text Text)
-> RIO env (Map Text Text)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ProcessException -> RIO env (Map Text Text)
forall e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM Map Text Text -> RIO env (Map Text Text)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ProcessException (Map Text Text)
 -> RIO env (Map Text Text))
-> Either ProcessException (Map Text Text)
-> RIO env (Map Text Text)
forall a b. (a -> b) -> a -> b
$ [[Char]]
-> Map Text Text -> Either ProcessException (Map Text Text)
augmentPathMap
              [Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath (Path Abs Dir -> [Char]) -> Path Abs Dir -> [Char]
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
destDir Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirUsr Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirBin]
              (Getting (Map Text Text) ProcessContext (Map Text Text)
-> ProcessContext -> Map Text Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Map Text Text) ProcessContext (Map Text Text)
forall env.
HasProcessContext env =>
SimpleGetter env (Map Text Text)
SimpleGetter ProcessContext (Map Text Text)
envVarsL ProcessContext
newEnv0)
  ProcessContext
menv <- Map Text Text -> RIO env ProcessContext
forall (m :: * -> *).
MonadIO m =>
Map Text Text -> m ProcessContext
mkProcessContext Map Text Text
newEnv
  [Char] -> RIO env () -> RIO env ()
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
[Char] -> m a -> m a
withWorkingDir (Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
destDir) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ ProcessContext -> RIO env () -> RIO env ()
forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv
    (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [Char]
-> [[Char]] -> (ProcessConfig () () () -> RIO env ()) -> RIO env ()
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"] ProcessConfig () () () -> RIO env ()
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 -> Text -> RIO env Text
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
".xz"
      ArchiveType
TarBz2 -> Text -> RIO env Text
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
".bz2"
      ArchiveType
TarGz -> Text -> RIO env Text
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
".gz"
      ArchiveType
_ -> SetupPrettyException -> RIO env Text
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (SetupPrettyException -> RIO env Text)
-> SetupPrettyException -> RIO env Text
forall a b. (a -> b) -> a -> b
$ [Char] -> SetupPrettyException
TarballInvalid [Char]
name
  Path Rel File
tarFile <-
    case Text -> Text -> Maybe Text
T.stripSuffix Text
suffix (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Path Rel File -> [Char]
forall b t. Path b t -> [Char]
toFilePath (Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Abs File
archiveFile) of
      Maybe Text
Nothing -> SetupPrettyException -> RIO env (Path Rel File)
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (SetupPrettyException -> RIO env (Path Rel File))
-> SetupPrettyException -> RIO env (Path Rel File)
forall a b. (a -> b) -> a -> b
$ [Char] -> Path Abs File -> SetupPrettyException
TarballFileInvalid [Char]
name Path Abs File
archiveFile
      Just Text
x -> [Char] -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile ([Char] -> RIO env (Path Rel File))
-> [Char] -> RIO env (Path Rel File)
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
x
  Path Abs Dir -> Path Abs File -> RIO env ()
run7z <- SetupInfo -> RIO env (Path Abs Dir -> Path Abs File -> RIO env ())
forall env (m :: * -> *).
(HasBuildConfig env, MonadIO m) =>
SetupInfo -> RIO env (Path Abs Dir -> Path Abs File -> m ())
setup7z SetupInfo
si
  -- We use a short name for the temporary directory to reduce the risk of a

  -- filepath length of more than 260 characters, which can be problematic for

  -- 7-Zip even if Long Filepaths are enabled on Windows.

  let tmpName :: [Char]
tmpName = [Char]
"stack-tmp"
      destDrive :: Path Abs Dir
destDrive = Maybe (Path Abs Dir) -> Path Abs Dir
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Path Abs Dir) -> Path Abs Dir)
-> Maybe (Path Abs Dir) -> Path Abs Dir
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs Dir)
parseAbsDir ([Char] -> Maybe (Path Abs Dir)) -> [Char] -> Maybe (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ ShowS
takeDrive ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> [Char]
fromAbsDir Path Abs Dir
destDir
  Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (Path Abs Dir -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs Dir
destDir)
  ((forall a. RIO env a -> IO a) -> IO ()) -> RIO env ()
forall b. ((forall a. RIO env a -> IO a) -> IO b) -> RIO env b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. RIO env a -> IO a) -> IO ()) -> RIO env ())
-> ((forall a. RIO env a -> IO a) -> IO ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \forall a. RIO env a -> IO a
run ->
  -- We use a temporary directory in the same drive as that of 'destDir' to

  -- reduce the risk of a filepath length of more than 260 characters, which can

  -- be problematic for 7-Zip even if Long Filepaths are enabled on Windows. We

  -- do not use the system temporary directory as it may be on a different

  -- drive.

    Path Abs Dir -> [Char] -> (Path Abs Dir -> IO ()) -> IO ()
forall (m :: * -> *) b a.
(MonadIO m, MonadMask m) =>
Path b Dir -> [Char] -> (Path Abs Dir -> m a) -> m a
withTempDir Path Abs Dir
destDrive [Char]
tmpName ((Path Abs Dir -> IO ()) -> IO ())
-> (Path Abs Dir -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
tmpDir ->
      RIO env () -> IO ()
forall a. RIO env a -> IO a
run (RIO env () -> IO ()) -> RIO env () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (Path Abs Dir -> IO ()
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 Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
tarFile)
        Path Abs Dir
absSrcDir <- Path Abs File -> Path Abs Dir -> RIO env (Path Abs 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
tmpDir
        -- On Windows, 'renameDir' does not work across drives. However, we have

        -- ensured that 'tmpDir' has the same drive as 'destDir'.

        Path Abs Dir -> Path Abs Dir -> RIO env ()
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
unpackDir = do
  ([Path Abs Dir], [Path Abs File])
contents <- Path Abs Dir -> m ([Path Abs Dir], [Path Abs File])
forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
unpackDir
  case ([Path Abs Dir], [Path Abs File])
contents of
    ([Path Abs Dir
dir], [Path Abs File]
_ ) -> Path Abs Dir -> m (Path Abs Dir)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
dir
    ([Path Abs Dir], [Path Abs File])
_ -> SetupPrettyException -> m (Path Abs Dir)
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (SetupPrettyException -> m (Path Abs Dir))
-> SetupPrettyException -> m (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs File -> SetupPrettyException
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 <- Getting (Path Abs Dir) env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Path Abs Dir) env (Path Abs Dir)
 -> RIO env (Path Abs Dir))
-> Getting (Path Abs Dir) env (Path Abs Dir)
-> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ (Config -> Const (Path Abs Dir) Config)
-> env -> Const (Path Abs Dir) env
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL((Config -> Const (Path Abs Dir) Config)
 -> env -> Const (Path Abs Dir) env)
-> ((Path Abs Dir -> Const (Path Abs Dir) (Path Abs Dir))
    -> Config -> Const (Path Abs Dir) Config)
-> Getting (Path Abs Dir) env (Path Abs Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> Path Abs Dir) -> SimpleGetter Config (Path Abs Dir)
forall s a. (s -> a) -> SimpleGetter s a
to Config -> Path Abs Dir
configLocalPrograms
  Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
dir
  let exeDestination :: Path Abs File
exeDestination = Path Abs Dir
dir Path Abs Dir -> Path Rel File -> Path Abs File
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 Path Abs Dir -> Path Rel File -> Path Abs File
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
_ <- Text -> DownloadInfo -> Path Abs File -> RIO env (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 <- Text -> DownloadInfo -> Path Abs File -> RIO env (Path Abs File)
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 a. RIO env a -> IO a)
 -> IO (Path Abs Dir -> Path Abs File -> m ()))
-> RIO env (Path Abs Dir -> Path Abs File -> m ())
forall b. ((forall a. RIO env a -> IO a) -> IO b) -> RIO env b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. RIO env a -> IO a)
  -> IO (Path Abs Dir -> Path Abs File -> m ()))
 -> RIO env (Path Abs Dir -> Path Abs File -> m ()))
-> ((forall a. RIO env a -> IO a)
    -> IO (Path Abs Dir -> Path Abs File -> m ()))
-> RIO env (Path Abs Dir -> Path Abs File -> m ())
forall a b. (a -> b) -> a -> b
$ \forall a. RIO env a -> IO a
run -> (Path Abs Dir -> Path Abs File -> m ())
-> IO (Path Abs Dir -> Path Abs File -> m ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Path Abs Dir -> Path Abs File -> m ())
 -> IO (Path Abs Dir -> Path Abs File -> m ()))
-> (Path Abs Dir -> Path Abs File -> m ())
-> IO (Path Abs Dir -> Path Abs File -> m ())
forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
outdir Path Abs File
archive -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ RIO env () -> IO ()
forall a. RIO env a -> IO a
run (RIO env () -> IO ()) -> RIO env () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let cmd :: [Char]
cmd = Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
exePath
            args :: [[Char]]
args =
              [ [Char]
"x"
              , [Char]
"-o" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
outdir
              , [Char]
"-y"
              , [Char]
archiveFP
              ]
            archiveFP :: [Char]
archiveFP = Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
archive
            archiveFileName :: Path Rel File
archiveFileName = Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Abs File
archive
            archiveDisplay :: Utf8Builder
archiveDisplay = [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString ([Char] -> Utf8Builder) -> [Char] -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ Path Rel File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Rel File
archiveFileName
            isExtract :: Bool
isExtract = ShowS
FP.takeExtension [Char]
archiveFP [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
".tar"
        [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
          [ if Bool
isExtract then StyleDoc
"Extracting" else StyleDoc
"Decompressing"
          , Path Rel File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Rel File
archiveFileName StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"..."
          ]
        ExitCode
ec <-
          [Char]
-> [[Char]]
-> (ProcessConfig () () () -> RIO env ExitCode)
-> RIO env ExitCode
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 ((ProcessConfig () () () -> RIO env ExitCode) -> RIO env ExitCode)
-> (ProcessConfig () () () -> RIO env ExitCode) -> RIO env ExitCode
forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
pc ->
          if Bool
isExtract
            then ProcessConfig () (ConduitM () ByteString (RIO env) ()) ()
-> (Process () (ConduitM () ByteString (RIO env) ()) ()
    -> RIO env ExitCode)
-> RIO env ExitCode
forall (m :: * -> *) stdin stdout stderr a.
MonadUnliftIO m =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
withProcessWait (StreamSpec 'STOutput (ConduitM () ByteString (RIO env) ())
-> ProcessConfig () () ()
-> ProcessConfig () (ConduitM () ByteString (RIO env) ()) ()
forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout StreamSpec 'STOutput (ConduitM () ByteString (RIO env) ())
forall (m :: * -> *) i.
MonadIO m =>
StreamSpec 'STOutput (ConduitM i ByteString m ())
createSource ProcessConfig () () ()
pc) ((Process () (ConduitM () ByteString (RIO env) ()) ()
  -> RIO env ExitCode)
 -> RIO env ExitCode)
-> (Process () (ConduitM () ByteString (RIO env) ()) ()
    -> RIO env ExitCode)
-> RIO env ExitCode
forall a b. (a -> b) -> a -> b
$ \Process () (ConduitM () ByteString (RIO env) ()) ()
p -> do
              Int
total <- ConduitT () Void (RIO env) Int -> RIO env Int
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit
                 (ConduitT () Void (RIO env) Int -> RIO env Int)
-> ConduitT () Void (RIO env) Int -> RIO env Int
forall a b. (a -> b) -> a -> b
$ Process () (ConduitM () ByteString (RIO env) ()) ()
-> ConduitM () ByteString (RIO env) ()
forall stdin stdout stderr. Process stdin stdout stderr -> stdout
getStdout Process () (ConduitM () ByteString (RIO env) ()) ()
p
                ConduitM () ByteString (RIO env) ()
-> ConduitT ByteString Void (RIO env) Int
-> ConduitT () Void (RIO env) Int
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (Element ByteString -> Bool)
-> ConduitT ByteString ByteString (RIO env) ()
forall seq (m :: * -> *).
(IsSequence seq, Monad m) =>
(Element seq -> Bool) -> ConduitT seq seq m ()
filterCE (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
10) -- newline characters

                ConduitT ByteString ByteString (RIO env) ()
-> ConduitT ByteString Void (RIO env) Int
-> ConduitT ByteString Void (RIO env) Int
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (Int -> ByteString -> RIO env Int)
-> Int -> ConduitT ByteString Void (RIO env) Int
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
bs
                         Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logSticky (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Extracted " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
count' Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" files"
                         Int -> RIO env Int
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
count'
                     )
                     Int
0
              Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                   Utf8Builder
"Extracted total of "
                Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
total
                Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" files from "
                Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
archiveDisplay
              Process () (ConduitM () ByteString (RIO env) ()) ()
-> RIO env ExitCode
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
Process stdin stdout stderr -> m ExitCode
waitExitCode Process () (ConduitM () ByteString (RIO env) ()) ()
p
            else ProcessConfig () () () -> RIO env ExitCode
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ExitCode
runProcess ProcessConfig () () ()
pc
        Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
ec ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
          IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ SetupPrettyException -> IO ()
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (Path Abs File -> SetupPrettyException
ProblemWhileDecompressing Path Abs File
archive)
    (Maybe DownloadInfo, Maybe DownloadInfo)
_ -> SetupPrettyException
-> RIO env (Path Abs Dir -> Path Abs File -> m ())
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM SetupPrettyException
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 <- [Char] -> RIO env Request
forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseUrlThrow ([Char] -> RIO env Request) -> [Char] -> RIO env Request
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
url
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logSticky (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
       Utf8Builder
"Preparing to download "
    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
label
    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" ..."
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
       Utf8Builder
"Downloading from "
    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
url
    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" to "
    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString (Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
path)
    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" ..."
  [HashCheck]
hashChecks <- ([Maybe HashCheck] -> [HashCheck])
-> RIO env [Maybe HashCheck] -> RIO env [HashCheck]
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe HashCheck] -> [HashCheck]
forall a. [Maybe a] -> [a]
catMaybes (RIO env [Maybe HashCheck] -> RIO env [HashCheck])
-> RIO env [Maybe HashCheck] -> RIO env [HashCheck]
forall a b. (a -> b) -> a -> b
$ [(Utf8Builder, CheckHexDigest -> HashCheck,
  DownloadInfo -> Maybe ByteString)]
-> ((Utf8Builder, CheckHexDigest -> HashCheck,
     DownloadInfo -> Maybe ByteString)
    -> RIO env (Maybe HashCheck))
-> RIO env [Maybe HashCheck]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM
    [ (Utf8Builder
"sha1",   SHA1 -> CheckHexDigest -> HashCheck
forall a.
(Show a, HashAlgorithm a) =>
a -> CheckHexDigest -> HashCheck
HashCheck SHA1
SHA1,   DownloadInfo -> Maybe ByteString
downloadInfoSha1)
    , (Utf8Builder
"sha256", SHA256 -> CheckHexDigest -> HashCheck
forall a.
(Show a, HashAlgorithm a) =>
a -> CheckHexDigest -> HashCheck
HashCheck SHA256
SHA256, DownloadInfo -> Maybe ByteString
downloadInfoSha256)
    ]
    (((Utf8Builder, CheckHexDigest -> HashCheck,
   DownloadInfo -> Maybe ByteString)
  -> RIO env (Maybe HashCheck))
 -> RIO env [Maybe HashCheck])
-> ((Utf8Builder, CheckHexDigest -> HashCheck,
     DownloadInfo -> Maybe ByteString)
    -> RIO env (Maybe HashCheck))
-> RIO env [Maybe HashCheck]
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
          Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
               Utf8Builder
"Will check against "
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
name
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" hash: "
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Utf8Builder
displayBytesUtf8 ByteString
bs
          Maybe HashCheck -> RIO env (Maybe HashCheck)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe HashCheck -> RIO env (Maybe HashCheck))
-> Maybe HashCheck -> RIO env (Maybe HashCheck)
forall a b. (a -> b) -> a -> b
$ HashCheck -> Maybe HashCheck
forall a. a -> Maybe a
Just (HashCheck -> Maybe HashCheck) -> HashCheck -> Maybe HashCheck
forall a b. (a -> b) -> a -> b
$ CheckHexDigest -> HashCheck
constr (CheckHexDigest -> HashCheck) -> CheckHexDigest -> HashCheck
forall a b. (a -> b) -> a -> b
$ ByteString -> CheckHexDigest
CheckHexDigestByteString ByteString
bs
        Maybe ByteString
Nothing -> Maybe HashCheck -> RIO env (Maybe HashCheck)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe HashCheck
forall a. Maybe a
Nothing
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([HashCheck] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HashCheck]
hashChecks) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    [Char] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[Char] -> m ()
prettyWarnS
      [Char]
"No sha1 or sha256 found in metadata, download hash won't be checked."
  let dReq :: DownloadRequest
dReq = [HashCheck] -> DownloadRequest -> DownloadRequest
setHashChecks [HashCheck]
hashChecks (DownloadRequest -> DownloadRequest)
-> DownloadRequest -> DownloadRequest
forall a b. (a -> b) -> a -> b
$
             Maybe Int -> DownloadRequest -> DownloadRequest
setLengthCheck Maybe Int
mtotalSize (DownloadRequest -> DownloadRequest)
-> DownloadRequest -> DownloadRequest
forall a b. (a -> b) -> a -> b
$
             Request -> DownloadRequest
mkDownloadRequest Request
req
  Bool
x <- DownloadRequest
-> Path Abs File -> Text -> Maybe Int -> RIO env Bool
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 Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone (Utf8Builder
"Downloaded " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
label Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".")
    else Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone (Utf8Builder
"Already downloaded " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
label Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".")
 where
  mtotalSize :: Maybe Int
mtotalSize = DownloadInfo -> Maybe Int
downloadInfoContentLength DownloadInfo
downloadInfo

-- | Perform a basic sanity check of GHC

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

    , [Char]
"main = putStrLn \"Hello World\""
    ]
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Performing a sanity check on: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString (Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
ghc)
  Either SomeException (ByteString, ByteString)
eres <- [Char]
-> RIO env (Either SomeException (ByteString, ByteString))
-> RIO env (Either SomeException (ByteString, ByteString))
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
[Char] -> m a -> m a
withWorkingDir (Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
dir) (RIO env (Either SomeException (ByteString, ByteString))
 -> RIO env (Either SomeException (ByteString, ByteString)))
-> RIO env (Either SomeException (ByteString, ByteString))
-> RIO env (Either SomeException (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$ [Char]
-> [[Char]]
-> (ProcessConfig () () ()
    -> RIO env (Either SomeException (ByteString, ByteString)))
-> RIO env (Either SomeException (ByteString, ByteString))
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc (Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
ghc)
    [ [Char]
fp
    , [Char]
"-no-user-package-db"
    -- Required to stop GHC looking for a package environment in default

    -- locations.

    , [Char]
"-hide-all-packages"
    -- Required because GHC flag -hide-all-packages is passed.

    , [Char]
"-package base"
    , [Char]
"-package Cabal" -- required for "import Distribution.Simple"

    ] ((ProcessConfig () () ()
  -> RIO env (Either SomeException (ByteString, ByteString)))
 -> RIO env (Either SomeException (ByteString, ByteString)))
-> (ProcessConfig () () ()
    -> RIO env (Either SomeException (ByteString, ByteString)))
-> RIO env (Either SomeException (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$ RIO env (ByteString, ByteString)
-> RIO env (Either SomeException (ByteString, ByteString))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (RIO env (ByteString, ByteString)
 -> RIO env (Either SomeException (ByteString, ByteString)))
-> (ProcessConfig () () () -> RIO env (ByteString, ByteString))
-> ProcessConfig () () ()
-> RIO env (Either SomeException (ByteString, ByteString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessConfig () () () -> RIO env (ByteString, ByteString)
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 -> SetupPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (SetupPrettyException -> RIO env ())
-> SetupPrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ SomeException -> Path Abs File -> SetupPrettyException
GHCSanityCheckCompileFailed SomeException
e Path Abs File
ghc
    Right (ByteString, ByteString)
_ -> () -> RIO env ()
forall a. a -> RIO env a
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 =
  Text -> Map Text Text -> Map Text Text
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"GHC_PACKAGE_PATH" (Map Text Text -> Map Text Text)
-> (Map Text Text -> Map Text Text)
-> Map Text Text
-> Map Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Text -> Map Text Text -> Map Text Text
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"GHC_ENVIRONMENT" (Map Text Text -> Map Text Text)
-> (Map Text Text -> Map Text Text)
-> Map Text Text
-> Map Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Text -> Map Text Text -> Map Text Text
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"HASKELL_PACKAGE_SANDBOX" (Map Text Text -> Map Text Text)
-> (Map Text Text -> Map Text Text)
-> Map Text Text
-> Map Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Text -> Map Text Text -> Map Text Text
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"HASKELL_PACKAGE_SANDBOXES" (Map Text Text -> Map Text Text)
-> (Map Text Text -> Map Text Text)
-> Map Text Text
-> Map Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Text -> Map Text Text -> Map Text Text
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"HASKELL_DIST_DIR" (Map Text Text -> Map Text Text)
-> (Map Text Text -> Map Text Text)
-> Map Text Text
-> Map Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  -- https://github.com/commercialhaskell/stack/issues/1460

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

  Text -> Map Text Text -> Map Text Text
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 ::
     (HasPlatform env, HasProcessContext env, HasTerm env)
  => ActualCompiler
  -> RIO env (Map Text Text)
getUtf8EnvVars :: forall env.
(HasPlatform env, HasProcessContext env, HasTerm env) =>
ActualCompiler -> RIO env (Map Text Text)
getUtf8EnvVars ActualCompiler
compilerVer =
  if ActualCompiler -> Version
getGhcVersion ActualCompiler
compilerVer Version -> Version -> Bool
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 Map Text Text -> RIO env (Map Text Text)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Text Text -> RIO env (Map Text Text))
-> Map Text Text -> RIO env (Map Text Text)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Map Text Text
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 <- Getting ProcessContext env ProcessContext -> RIO env ProcessContext
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ProcessContext env ProcessContext
forall env. HasProcessContext env => Lens' env ProcessContext
Lens' env ProcessContext
processContextL
    Platform Arch
_ OS
os <- Getting Platform env Platform -> RIO env Platform
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Platform env Platform
forall env. HasPlatform env => Lens' env Platform
Lens' env Platform
platformL
    if OS
os OS -> OS -> Bool
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.

        Map Text Text -> RIO env (Map Text Text)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text Text
forall k a. Map k a
Map.empty
      else do
        let checkedVars :: [([Text], Set Text)]
checkedVars = ((Text, Text) -> ([Text], Set Text))
-> [(Text, Text)] -> [([Text], Set Text)]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> ([Text], Set Text)
checkVar (Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Text Text -> [(Text, Text)])
-> Map Text Text -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ Getting (Map Text Text) ProcessContext (Map Text Text)
-> ProcessContext -> Map Text Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Map Text Text) ProcessContext (Map Text Text)
forall env.
HasProcessContext env =>
SimpleGetter env (Map Text Text)
SimpleGetter ProcessContext (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 = (([Text], Set Text) -> [Text]) -> [([Text], Set Text)] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Text], Set Text) -> [Text]
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 = [Set Text] -> Set Text
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ((([Text], Set Text) -> Set Text)
-> [([Text], Set Text)] -> [Set Text]
forall a b. (a -> b) -> [a] -> [b]
map ([Text], Set Text) -> Set Text
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 =
              (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
existingVarNames) [Text
"LANG", Text
"LANGUAGE", Text
"LC_ALL"]
        if [Text] -> Bool
forall a. [a] -> Bool
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.

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

            Either SomeException ByteString
elocales <- RIO env ByteString -> RIO env (Either SomeException ByteString)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny ((ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> RIO env (ByteString, ByteString) -> RIO env ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char]
-> [[Char]]
-> (ProcessConfig () () () -> RIO env (ByteString, ByteString))
-> RIO env (ByteString, ByteString)
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"] ProcessConfig () () () -> RIO env (ByteString, ByteString)
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 ->
                      (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter
                        Text -> Bool
isUtf8Locale
                        ( Text -> [Text]
T.lines (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$
                          OnDecodeError -> ByteString -> Text
T.decodeUtf8With
                            OnDecodeError
T.lenientDecode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$
                            ByteString -> ByteString
LBS.toStrict ByteString
locales
                        )
                mfallback :: Maybe Text
mfallback = [Text] -> Maybe Text
getFallbackLocale [Text]
utf8Locales
            Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
              (Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Text
mfallback)
              ( [Char] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[Char] -> m ()
prettyWarnS
                  [Char]
"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 =
                  [Map Text Text] -> Map Text Text
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions ([Map Text Text] -> Map Text Text)
-> [Map Text Text] -> Map Text Text
forall a b. (a -> b) -> a -> b
$
                  (Text -> Map Text Text) -> [Text] -> [Map Text Text]
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.

                      Map Text Text
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 -> Map Text Text
forall k a. Map k a
Map.empty
                        Just Text
fallback ->
                          Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
Map.singleton Text
"LANG" Text
fallback
            Map Text Text -> RIO env (Map Text Text)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Text Text -> Map Text Text -> Map Text Text
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 Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
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 ([], Text -> Set Text
forall a. a -> Set a
Set.singleton Text
k)
             else ([Text
k], Text -> Set Text
forall a. a -> Set a
Set.singleton Text
k)
      else ([], Set Text
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 Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
k (Getting (Map Text Text) ProcessContext (Map Text Text)
-> ProcessContext -> Map Text Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Map Text Text) ProcessContext (Map Text Text)
forall env.
HasProcessContext env =>
SimpleGetter env (Map Text Text)
SimpleGetter ProcessContext (Map Text Text)
envVarsL ProcessContext
menv) of
      Maybe Text
Nothing -> Map Text Text
forall k a. Map k a
Map.empty
      Just Text
v ->
        case (Text -> [Text]) -> [Text] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
               ([Text] -> Text -> [Text]
matchingLocales [Text]
utf8Locales)
               [ (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
               , (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_') Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_"] of
          (Text
v':[Text]
_) -> Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
Map.singleton Text
k Text
v'
          [] -> case Maybe Text
mfallback of
                  Just Text
fallback -> Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
Map.singleton Text
k Text
fallback
                  Maybe Text
Nothing -> Map Text Text
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 (Text -> [Text]) -> [Text] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Text] -> Text -> [Text]
matchingLocales [Text]
utf8Locales) [Text]
fallbackPrefixes of
      (Text
v:[Text]
_) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
v
      [] -> case [Text]
utf8Locales of
              [] -> Maybe Text
forall a. Maybe a
Nothing
              (Text
v:[Text]
_) -> Text -> Maybe 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 =
    (Text -> Bool) -> [Text] -> [Text]
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 =
    (Text -> Bool) -> [Text] -> Bool
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]
(Int -> HaskellStackOrg -> ShowS)
-> (HaskellStackOrg -> [Char])
-> ([HaskellStackOrg] -> ShowS)
-> Show HaskellStackOrg
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HaskellStackOrg -> ShowS
showsPrec :: Int -> HaskellStackOrg -> ShowS
$cshow :: HaskellStackOrg -> [Char]
show :: HaskellStackOrg -> [Char]
$cshowList :: [HaskellStackOrg] -> ShowS
showList :: [HaskellStackOrg] -> ShowS
Show

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

  -> Maybe String -- GitHub repo

  -> Maybe String -- ^ optional version

  -> RIO env StackReleaseInfo
downloadStackReleaseInfo :: forall env.
(HasLogFunc env, HasPlatform env) =>
Maybe [Char]
-> Maybe [Char] -> Maybe [Char] -> RIO env StackReleaseInfo
downloadStackReleaseInfo Maybe [Char]
Nothing Maybe [Char]
Nothing Maybe [Char]
Nothing = do
  Platform
platform <- Getting Platform env Platform -> RIO env Platform
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Platform env Platform
forall env. HasPlatform env => Lens' env Platform
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 [[Char]] -> [[Char]]
forall a. [a] -> [a]
reverse ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [[Char]]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn [Char]
"/" ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
loc of
            [Char]
_final:[Char]
version0:[[Char]]
_ -> [Char] -> Either [Char] [Char]
forall a b. b -> Either a b
Right [Char]
version0
            [[Char]]
_ -> [Char] -> Either [Char] [Char]
forall a b. a -> Either a b
Left ([Char] -> Either [Char] [Char]) -> [Char] -> Either [Char] [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"Insufficient pieces in location: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
loc
        [Char]
version1 <-
          Either [Char] [Char]
-> ([Char] -> Either [Char] [Char])
-> Maybe [Char]
-> Either [Char] [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Either [Char] [Char]
forall a b. a -> Either a b
Left [Char]
"no leading v on version") [Char] -> Either [Char] [Char]
forall a b. b -> Either a b
Right (Maybe [Char] -> Either [Char] [Char])
-> Maybe [Char] -> Either [Char] [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
"v" [Char]
version0
        Either [Char] Version
-> (Version -> Either [Char] Version)
-> Maybe Version
-> Either [Char] Version
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Either [Char] Version
forall a b. a -> Either a b
Left ([Char] -> Either [Char] Version)
-> [Char] -> Either [Char] Version
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid version: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> [Char]
show [Char]
version1) Version -> Either [Char] Version
forall a b. b -> Either a b
Right (Maybe Version -> Either [Char] Version)
-> Maybe Version -> Either [Char] Version
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
        Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Could not get binary from haskellstack.org, trying GitHub"
        Maybe [Char] -> Maybe [Char] -> Maybe [Char] -> m StackReleaseInfo
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Maybe [Char] -> Maybe [Char] -> Maybe [Char] -> m StackReleaseInfo
downloadStackReleaseInfoGitHub Maybe [Char]
forall a. Maybe a
Nothing Maybe [Char]
forall a. Maybe a
Nothing Maybe [Char]
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" (Request -> Request) -> m Request -> m Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> m Request
forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseRequest (Text -> [Char]
T.unpack Text
url)
        Response ByteString
res <- Request -> m (Response ByteString)
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 HeaderName -> Response ByteString -> [ByteString]
forall a. HeaderName -> Response a -> [ByteString]
getResponseHeader HeaderName
"location" Response ByteString
res of
          [] -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"No location header found, continuing" m () -> m StackReleaseInfo -> m StackReleaseInfo
forall a b. m a -> m b -> m b
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 ->
                   Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug
                     (   Utf8Builder
"Invalid UTF8: "
                     Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> (ByteString, UnicodeException) -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (ByteString
locBS, UnicodeException
e)
                     )
                m () -> m StackReleaseInfo -> m StackReleaseInfo
forall a b. m a -> m b -> m b
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 ->
                       Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug
                         (   Utf8Builder
"No version found: "
                         Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> (Text, Text, [Char]) -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (Text
url, Text
loc, [Char]
s)
                         )
                    m () -> m StackReleaseInfo -> m StackReleaseInfo
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Text] -> m StackReleaseInfo
loop (Text
locText -> [Text] -> [Text]
forall 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
                                }
                    Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$
                         Utf8Builder
"Downloading from haskellstack.org: "
                      Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> HaskellStackOrg -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow HaskellStackOrg
hso
                    StackReleaseInfo -> m StackReleaseInfo
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StackReleaseInfo -> m StackReleaseInfo)
-> StackReleaseInfo -> m StackReleaseInfo
forall a b. (a -> b) -> a -> b
$ HaskellStackOrg -> StackReleaseInfo
SRIHaskellStackOrg HaskellStackOrg
hso
          [ByteString]
locs ->
               Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug
                 (  Utf8Builder
"Multiple location headers found: "
                 Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow [ByteString]
locs
                 )
            m () -> m StackReleaseInfo -> m StackReleaseInfo
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Text] -> m StackReleaseInfo
loop [Text]
urls
  [Text] -> RIO env StackReleaseInfo
forall {m :: * -> *} {env}.
(MonadThrow m, MonadIO m, HasLogFunc env, MonadReader env m) =>
[Text] -> m StackReleaseInfo
loop [Text]
urls0
downloadStackReleaseInfo Maybe [Char]
morg Maybe [Char]
mrepo Maybe [Char]
mver =
  Maybe [Char]
-> Maybe [Char] -> Maybe [Char] -> RIO env StackReleaseInfo
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 = IO StackReleaseInfo -> m StackReleaseInfo
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO StackReleaseInfo -> m StackReleaseInfo)
-> IO StackReleaseInfo -> m StackReleaseInfo
forall a b. (a -> b) -> a -> b
$ do
  let org :: [Char]
org = [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"commercialhaskell" Maybe [Char]
morg
      repo :: [Char]
repo = [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"stack" Maybe [Char]
mrepo
  let url :: [Char]
url = [[Char]] -> [Char]
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" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
ver
        ]
  Request
req <- [Char] -> IO Request
forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseRequest [Char]
url
  Response Value
res <- Request -> IO (Response Value)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON (Request -> IO (Response Value)) -> Request -> IO (Response Value)
forall a b. (a -> b) -> a -> b
$ Request -> Request
setGitHubHeaders Request
req
  let code :: Int
code = Response Value -> Int
forall a. Response a -> Int
getResponseStatusCode Response Value
res
  if Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
200 Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
300
    then StackReleaseInfo -> IO StackReleaseInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StackReleaseInfo -> IO StackReleaseInfo)
-> StackReleaseInfo -> IO StackReleaseInfo
forall a b. (a -> b) -> a -> b
$ Value -> StackReleaseInfo
SRIGitHub (Value -> StackReleaseInfo) -> Value -> StackReleaseInfo
forall a b. (a -> b) -> a -> b
$ Response Value -> Value
forall a. Response a -> a
getResponseBody Response Value
res
    else SetupPrettyException -> IO StackReleaseInfo
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (SetupPrettyException -> IO StackReleaseInfo)
-> SetupPrettyException -> IO StackReleaseInfo
forall a b. (a -> b) -> a -> b
$ [Char] -> SetupPrettyException
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' <- Getting Platform env Platform -> m Platform
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Platform env Platform
forall env. HasPlatform env => Lens' env Platform
Lens' env Platform
platformL
  (Bool
isWindows, [Char]
os) <-
    case OS
os' of
      OS
Cabal.Linux -> (Bool, [Char]) -> m (Bool, [Char])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, [Char]
"linux")
      OS
Cabal.Windows -> (Bool, [Char]) -> m (Bool, [Char])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
True, [Char]
"windows")
      OS
Cabal.OSX -> (Bool, [Char]) -> m (Bool, [Char])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, [Char]
"osx")
      OS
Cabal.FreeBSD -> (Bool, [Char]) -> m (Bool, [Char])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, [Char]
"freebsd")
      OS
_ -> SetupPrettyException -> m (Bool, [Char])
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (SetupPrettyException -> m (Bool, [Char]))
-> SetupPrettyException -> m (Bool, [Char])
forall a b. (a -> b) -> a -> b
$ OS -> SetupPrettyException
BinaryUpgradeOnOSUnsupported OS
os'
  [Char]
arch <-
    case Arch
arch' of
      Arch
I386 -> [Char] -> m [Char]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"i386"
      Arch
X86_64 -> [Char] -> m [Char]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"x86_64"
      Arch
Arm -> [Char] -> m [Char]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"arm"
      Arch
AArch64 -> [Char] -> m [Char]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"aarch64"
      Arch
_ -> SetupPrettyException -> m [Char]
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (SetupPrettyException -> m [Char])
-> SetupPrettyException -> m [Char]
forall a b. (a -> b) -> a -> b
$ Arch -> SetupPrettyException
BinaryUpgradeOnArchUnsupported Arch
arch'
  let hasgmp4 :: Bool
hasgmp4 = Bool
False -- FIXME import relevant code from Stack.Setup?

                      -- checkLib $(mkRelFile "libgmp.so.3")

      suffixes :: [[Char]]
suffixes
          -- 'gmp4' ceased to be relevant after Stack 1.9.3 (December 2018).

        | Bool
hasgmp4 = [[Char]
"-static", [Char]
"-gmp4", [Char]
""]
          -- 'static' will cease to be relevant after Stack 2.11.1 (May 2023).

        | Bool
otherwise = [[Char]
"-static", [Char]
""]
  [(Bool, [Char])] -> m [(Bool, [Char])]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Bool, [Char])] -> m [(Bool, [Char])])
-> [(Bool, [Char])] -> m [(Bool, [Char])]
forall a b. (a -> b) -> a -> b
$ ([Char] -> (Bool, [Char])) -> [[Char]] -> [(Bool, [Char])]
forall a b. (a -> b) -> [a] -> [b]
map (\[Char]
suffix -> (Bool
isWindows, [[Char]] -> [Char]
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 [] =
          SetupPrettyException -> RIO env (Bool, Text)
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (SetupPrettyException -> RIO env (Bool, Text))
-> SetupPrettyException -> RIO env (Bool, Text)
forall a b. (a -> b) -> a -> b
$ [[Char]] -> SetupPrettyException
StackBinaryArchiveNotFound (((Bool, [Char]) -> [Char]) -> [(Bool, [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, [Char]) -> [Char]
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'
          [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
            [ [Char] -> StyleDoc
flow [Char]
"Querying for archive location for platform:"
            , Style -> StyleDoc -> StyleDoc
style Style
Current ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
p') StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
            ]
          case StackReleaseInfo -> Text -> Maybe Text
findArchive StackReleaseInfo
archiveInfo Text
p of
            Just Text
x -> (Bool, Text) -> RIO env (Bool, Text)
forall a. a -> RIO env a
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 Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileStackDotExe
            , Path Abs Dir
destDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileStackDotTmpDotExe
            )
        | Bool
otherwise =
            ( Path Abs Dir
destDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileStack
            , Path Abs Dir
destDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileStackDotTmp
            )

  [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
    [ [Char] -> StyleDoc
flow [Char]
"Downloading from:"
    , Style -> StyleDoc -> StyleDoc
style Style
Url ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString ([Char] -> StyleDoc) -> [Char] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
archiveURL) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
    ]

  IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    if | 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 ->
            SetupException -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SetupException
StackBinaryArchiveZipUnsupportedBug
       | Bool
otherwise -> SetupPrettyException -> IO ()
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (SetupPrettyException -> IO ()) -> SetupPrettyException -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> SetupPrettyException
StackBinaryArchiveUnsupported Text
archiveURL

  [Char] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[Char] -> m ()
prettyInfoS [Char]
"Download complete, testing executable."

  -- We need to call getExecutablePath before we overwrite the

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

  -- (deleted) to the filename.

  Path Abs File
currExe <- IO [Char] -> RIO env [Char]
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [Char]
getExecutablePath RIO env [Char]
-> ([Char] -> RIO env (Path Abs File)) -> RIO env (Path Abs File)
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> RIO env (Path Abs File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs File)
parseAbsFile

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

  Path Abs File -> Path Abs File -> Path Abs File -> RIO env ()
forall env.
HasTerm env =>
Path Abs File -> Path Abs File -> Path Abs File -> RIO env ()
relocateStackExeFile Path Abs File
currExe Path Abs File
tmpFile Path Abs File
destFile

  [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
    [ [Char] -> StyleDoc
flow [Char]
"New Stack executable available at:"
    , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
destFile StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
    ]

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

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

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

    findMatch :: Text -> Value -> Maybe Text
findMatch Text
pattern'' (Object Object
o) = do
        String Text
name <- Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"name" Object
o
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text
".asc" Text -> Text -> Bool
`T.isSuffixOf` Text
name
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Text
pattern'' Text -> Text -> Bool
`T.isInfixOf` Text
name
        String Text
url <- Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"browser_download_url" Object
o
        Text -> Maybe Text
forall a. a -> Maybe a
Just Text
url
    findMatch Text
_ Value
_ = Maybe Text
forall a. Maybe a
Nothing
  findArchive (SRIHaskellStackOrg HaskellStackOrg
hso) Text
_ = Text -> Maybe Text
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text) -> Text -> Maybe Text
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 <- (Request -> Request) -> IO Request -> IO Request
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Request -> Request
setGitHubHeaders (IO Request -> IO Request) -> IO Request -> IO Request
forall a b. (a -> b) -> a -> b
$ [Char] -> IO Request
forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseUrlThrow ([Char] -> IO Request) -> [Char] -> IO Request
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
url
    Request
-> (Response (ConduitM () ByteString IO ()) -> IO ()) -> IO ()
forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
Request -> (Response (ConduitM i ByteString n ()) -> m a) -> m a
withResponse Request
req ((Response (ConduitM () ByteString IO ()) -> IO ()) -> IO ())
-> (Response (ConduitM () ByteString IO ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Response (ConduitM () ByteString IO ())
res -> do
      Entries FormatError
entries <- ([ByteString] -> Entries FormatError)
-> IO [ByteString] -> IO (Entries FormatError)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Entries FormatError
Tar.read (ByteString -> Entries FormatError)
-> ([ByteString] -> ByteString)
-> [ByteString]
-> Entries FormatError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
LBS.fromChunks)
        (IO [ByteString] -> IO (Entries FormatError))
-> IO [ByteString] -> IO (Entries FormatError)
forall a b. (a -> b) -> a -> b
$ ConduitM () ByteString IO () -> IO [ByteString]
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadActive m) =>
Source m a -> m [a]
lazyConsume
        (ConduitM () ByteString IO () -> IO [ByteString])
-> ConduitM () ByteString IO () -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ Response (ConduitM () ByteString IO ())
-> ConduitM () ByteString IO ()
forall a. Response a -> a
getResponseBody Response (ConduitM () ByteString IO ())
res ConduitM () ByteString IO ()
-> ConduitT ByteString ByteString IO ()
-> ConduitM () ByteString IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString ByteString IO ()
forall (m :: * -> *).
(PrimMonad m, MonadThrow m) =>
ConduitT ByteString ByteString m ()
ungzip
      let loop :: Entries FormatError -> IO ()
loop Entries FormatError
Tar.Done = SetupPrettyException -> IO ()
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (SetupPrettyException -> IO ()) -> SetupPrettyException -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Text -> SetupPrettyException
StackBinaryNotInArchive [Char]
exeName Text
url
          loop (Tar.Fail FormatError
e) = FormatError -> IO ()
forall e a. Exception e => e -> IO a
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 [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
exeName -> do
                case Entry -> EntryContent
Tar.entryContent Entry
e of
                  Tar.NormalFile ByteString
lbs FileSize
_ -> do
                    Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
destDir
                    [Char] -> ByteString -> IO ()
LBS.writeFile (Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
tmpFile) ByteString
lbs
                  EntryContent
_ -> SetupPrettyException -> IO ()
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (SetupPrettyException -> IO ()) -> SetupPrettyException -> IO ()
forall a b. (a -> b) -> a -> b
$ Entry -> Text -> SetupPrettyException
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"

relocateStackExeFile ::
     HasTerm env
  => Path Abs File
     -- ^ Path to the currently running executable

  -> Path Abs File
     -- ^ Path to the executable file to be relocated

  -> Path Abs File
     -- ^ Path to the new location for the excutable file

  -> RIO env ()
relocateStackExeFile :: forall env.
HasTerm env =>
Path Abs File -> Path Abs File -> Path Abs File -> RIO env ()
relocateStackExeFile Path Abs File
currExeFile Path Abs File
newExeFile Path Abs File
destExeFile = do
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
osIsWindows Bool -> Bool -> Bool
&& Path Abs File
destExeFile Path Abs File -> Path Abs File -> Bool
forall a. Eq a => a -> a -> Bool
== Path Abs File
currExeFile) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
    -- Windows allows a running executable's file to be renamed, but not to be

    -- overwritten.

    Path Abs File
old <- [Char] -> Path Abs File -> RIO env (Path Abs File)
forall (m :: * -> *) b.
MonadThrow m =>
[Char] -> Path b File -> m (Path b File)
addExtension [Char]
".old" Path Abs File
currExeFile
    [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
      [ [Char] -> StyleDoc
flow [Char]
"Renaming existing:"
      , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
currExeFile
      , StyleDoc
"as:"
      , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
old StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
      ]
    Path Abs File -> Path Abs File -> RIO env ()
forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
renameFile Path Abs File
currExeFile Path Abs File
old
  Path Abs File -> Path Abs File -> RIO env ()
forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
renameFile Path Abs File
newExeFile Path Abs File
destExeFile

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

-- currently running executable. See:

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

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

  -> Path Abs File
     -- ^ Path to the currently running executable

  -> RIO env ()
performPathChecking :: forall env.
HasConfig env =>
Path Abs File -> Path Abs File -> RIO env ()
performPathChecking Path Abs File
newExeFile Path Abs File
currExeFile = do
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Path Abs File
newExeFile Path Abs File -> Path Abs File -> Bool
forall a. Eq a => a -> a -> Bool
== Path Abs File
currExeFile) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
    [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
      [ [Char] -> StyleDoc
flow [Char]
"Also copying Stack executable to:"
      , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
currExeFile StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
      ]
    [Char]
tmpFile <- Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath (Path Abs File -> [Char])
-> RIO env (Path Abs File) -> RIO env [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Path Abs File -> RIO env (Path Abs File)
forall (m :: * -> *) b.
MonadThrow m =>
[Char] -> Path b File -> m (Path b File)
addExtension [Char]
".tmp" Path Abs File
currExeFile
    Either IOException ()
eres <- RIO env () -> RIO env (Either IOException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
tryIO (RIO env () -> RIO env (Either IOException ()))
-> RIO env () -> RIO env (Either IOException ())
forall a b. (a -> b) -> a -> b
$
      Path Abs File -> Path Abs File -> Path Abs File -> RIO env ()
forall env.
HasTerm env =>
Path Abs File -> Path Abs File -> Path Abs File -> RIO env ()
relocateStackExeFile Path Abs File
currExeFile Path Abs File
newExeFile Path Abs File
currExeFile
    case Either IOException ()
eres of
      Right () -> [Char] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[Char] -> m ()
prettyInfoS [Char]
"Stack executable copied successfully!"
      Left IOException
e
        | IOException -> Bool
isPermissionError IOException
e -> if Bool
osIsWindows
            then do
              StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                   [Char] -> StyleDoc
flow [Char]
"Permission error when trying to copy:"
                StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
                StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
string (IOException -> [Char]
forall e. Exception e => e -> [Char]
displayException IOException
e)
            else do
              StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                   [Char] -> StyleDoc
flow [Char]
"Permission error when trying to copy:"
                StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
                StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
string (IOException -> [Char]
forall e. Exception e => e -> [Char]
displayException IOException
e)
                StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
                StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
                     [ [Char] -> StyleDoc
flow [Char]
"Should I try to perform the file copy using"
                     , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"sudo" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"?"
                     , [Char] -> StyleDoc
flow [Char]
"This may fail."
                     ]
              Bool
toSudo <- Text -> RIO env Bool
forall (m :: * -> *). MonadIO m => Text -> m Bool
promptBool Text
"Try using sudo? (y/n) "
              Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
toSudo (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
                let run :: [Char] -> [[Char]] -> m ()
run [Char]
cmd [[Char]]
args = do
                      ExitCode
ec <- [Char]
-> [[Char]] -> (ProcessConfig () () () -> m ExitCode) -> m ExitCode
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 ProcessConfig () () () -> m ExitCode
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ExitCode
runProcess
                      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
ec ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                        PerformPathCheckingException -> m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PerformPathCheckingException -> m ())
-> PerformPathCheckingException -> m ()
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"
                          , Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
newExeFile
                          , [Char]
tmpFile
                          ])
                      , ([Char]
"sudo",
                          [ [Char]
"mv"
                          , [Char]
tmpFile
                          , Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
currExeFile
                          ])
                      ]
                StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                     [Char] -> StyleDoc
flow [Char]
"Going to run the following commands:"
                  StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
                  StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList
                       ( (([Char], [[Char]]) -> StyleDoc)
-> [([Char], [[Char]])] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map
                         ( \([Char]
cmd, [[Char]]
args) ->
                             Style -> StyleDoc -> StyleDoc
style Style
Shell (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
fillSep
                               ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
cmd
                               StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: ([Char] -> StyleDoc) -> [[Char]] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [[Char]]
args
                         )
                         [([Char], [[Char]])]
commands
                       )
                (([Char], [[Char]]) -> RIO env ())
-> [([Char], [[Char]])] -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (([Char] -> [[Char]] -> RIO env ())
-> ([Char], [[Char]]) -> RIO env ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Char] -> [[Char]] -> RIO env ()
forall {m :: * -> *} {env}.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m) =>
[Char] -> [[Char]] -> m ()
run) [([Char], [[Char]])]
commands
                StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                     StyleDoc
line
                  StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
"sudo file copy worked!"
        | Bool
otherwise -> IOException -> RIO env ()
forall e a. Exception e => e -> RIO env a
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 <- Value -> Maybe Value
forall a. a -> Maybe a
Just Value
val
  String Text
rawName <- Key -> Object -> Maybe Value
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 ([Char] -> Maybe Version) -> [Char] -> Maybe Version
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack (Int -> Text -> Text
T.drop Int
1 Text
rawName)
getDownloadVersion (SRIHaskellStackOrg HaskellStackOrg
hso) = Version -> Maybe Version
forall a. a -> Maybe a
Just (Version -> Maybe Version) -> Version -> Maybe Version
forall a b. (a -> b) -> a -> b
$ HaskellStackOrg -> Version
hsoVersion HaskellStackOrg
hso