{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}

-- | The general Stack configuration that starts everything off. This should

-- be smart to fallback if there is no stack.yaml, instead relying on

-- whatever files are available.

--

-- If there is no stack.yaml, and there is a cabal.config, we

-- read in those constraints, and if there's a cabal.sandbox.config,

-- we read any constraints from there and also find the package

-- database from there, etc. And if there's nothing, we should

-- probably default to behaving like cabal, possibly with spitting out

-- a warning that "you should run `stk init` to make things better".

module Stack.Config
  ( loadConfig
  , loadConfigYaml
  , packagesParser
  , getImplicitGlobalProjectDir
  , getSnapshots
  , makeConcreteResolver
  , checkOwnership
  , getInContainer
  , getInNixShell
  , defaultConfigYaml
  , getProjectConfig
  , withBuildConfig
  , withNewLogFunc
  ) where

import           Control.Monad.Extra ( firstJustM )
import           Data.Array.IArray ( (!), (//) )
import qualified Data.ByteString as S
import           Data.ByteString.Builder ( byteString )
import           Data.Coerce ( coerce )
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import qualified Data.Map.Merge.Strict as MS
import qualified Data.Monoid
import           Data.Monoid.Map ( MonoidMap (..) )
import qualified Data.Text as T
import qualified Data.Yaml as Yaml
import           Distribution.System
                   ( Arch (OtherArch), OS (..), Platform (..), buildPlatform )
import qualified Distribution.Text
import           Distribution.Version ( simplifyVersionRange )
import           GHC.Conc ( getNumProcessors )
import           Network.HTTP.StackClient
                   ( httpJSON, parseUrlThrow, getResponseBody )
import           Options.Applicative ( Parser, help, long, metavar, strOption )
import           Pantry.Internal.AesonExtended
import           Path
import           Path.Extra ( toFilePathNoTrailingSep )
import           Path.Find ( findInParents )
import           Path.IO
import           RIO.List ( unzip )
import           RIO.Process
import           RIO.Time ( toGregorian )
import           Stack.Build.Haddock ( shouldHaddockDeps )
import           Stack.Config.Build
import           Stack.Config.Docker
import           Stack.Config.Nix
import           Stack.Constants
import           Stack.Lock ( lockCachedWanted )
import           Stack.Prelude
import           Stack.SourceMap
import           Stack.Storage.Project ( initProjectStorage )
import           Stack.Storage.User ( initUserStorage )
import           Stack.Storage.Util ( handleMigrationException )
import           Stack.Types.Build
import           Stack.Types.Compiler
import           Stack.Types.Config
import           Stack.Types.Docker
import           Stack.Types.Nix
import           Stack.Types.Resolver
import           Stack.Types.SourceMap
import           Stack.Types.Version
                   ( IntersectingVersionRange (..), VersionCheck (..)
                   , stackVersion, withinRange
                   )
import           System.Console.ANSI
                   ( hSupportsANSIWithoutEmulation, setSGRCode )
import           System.Environment
import           System.Info.ShortPathName ( getShortPathName )
import           System.PosixCompat.Files ( fileOwner, getFileStatus )
import           System.PosixCompat.User ( getEffectiveUserID )

-- | If deprecated path exists, use it and print a warning.

-- Otherwise, return the new path.

tryDeprecatedPath ::
       HasLogFunc env
    => Maybe T.Text -- ^ Description of file for warning (if Nothing, no deprecation warning is displayed)

    -> (Path Abs a -> RIO env Bool) -- ^ Test for existence

    -> Path Abs a -- ^ New path

    -> Path Abs a -- ^ Deprecated path

    -> RIO env (Path Abs a, Bool) -- ^ (Path to use, whether it already exists)

tryDeprecatedPath :: forall env a.
HasLogFunc env =>
Maybe Text
-> (Path Abs a -> RIO env Bool)
-> Path Abs a
-> Path Abs a
-> RIO env (Path Abs a, Bool)
tryDeprecatedPath Maybe Text
mWarningDesc Path Abs a -> RIO env Bool
exists Path Abs a
new Path Abs a
old = do
    Bool
newExists <- Path Abs a -> RIO env Bool
exists Path Abs a
new
    if Bool
newExists
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs a
new, Bool
True)
        else do
            Bool
oldExists <- Path Abs a -> RIO env Bool
exists Path Abs a
old
            if Bool
oldExists
                then do
                    case Maybe Text
mWarningDesc of
                        Maybe Text
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                        Just Text
desc ->
                            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
                                Utf8Builder
"Warning: Location of " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
desc forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" at '" forall a. Semigroup a => a -> a -> a
<>
                                forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs a
old) forall a. Semigroup a => a -> a -> a
<>
                                Utf8Builder
"' is deprecated; rename it to '" forall a. Semigroup a => a -> a -> a
<>
                                forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs a
new) forall a. Semigroup a => a -> a -> a
<>
                                Utf8Builder
"' instead"
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs a
old, Bool
True)
                else forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs a
new, Bool
False)

-- | Get the location of the implicit global project directory.

-- If the directory already exists at the deprecated location, its location is returned.

-- Otherwise, the new location is returned.

getImplicitGlobalProjectDir ::
       HasLogFunc env
    => Config -> RIO env (Path Abs Dir)
getImplicitGlobalProjectDir :: forall env. HasLogFunc env => Config -> RIO env (Path Abs Dir)
getImplicitGlobalProjectDir Config
config =
    --TEST no warning printed

    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall env a.
HasLogFunc env =>
Maybe Text
-> (Path Abs a -> RIO env Bool)
-> Path Abs a
-> Path Abs a
-> RIO env (Path Abs a, Bool)
tryDeprecatedPath
        forall a. Maybe a
Nothing
        forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist
        (Path Abs Dir -> Path Abs Dir
implicitGlobalProjectDir Path Abs Dir
stackRoot)
        (Path Abs Dir -> Path Abs Dir
implicitGlobalProjectDirDeprecated Path Abs Dir
stackRoot)
  where
    stackRoot :: Path Abs Dir
stackRoot = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s (Path Abs Dir)
stackRootL Config
config

-- | Download the 'Snapshots' value from stackage.org.

getSnapshots :: HasConfig env => RIO env Snapshots
getSnapshots :: forall env. HasConfig env => RIO env Snapshots
getSnapshots = do
    Text
latestUrlText <- forall env (m :: * -> *).
(MonadReader env m, HasConfig env) =>
m Text
askLatestSnapshotUrl
    Request
latestUrl <- forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (Text -> String
T.unpack Text
latestUrlText)
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Downloading snapshot versions file from " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
latestUrlText
    Response Snapshots
result <- forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON Request
latestUrl
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Done downloading and parsing snapshot versions file"
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Response a -> a
getResponseBody Response Snapshots
result

-- | Turn an 'AbstractResolver' into a 'Resolver'.

makeConcreteResolver ::
       HasConfig env
    => AbstractResolver
    -> RIO env RawSnapshotLocation
makeConcreteResolver :: forall env.
HasConfig env =>
AbstractResolver -> RIO env RawSnapshotLocation
makeConcreteResolver (ARResolver RawSnapshotLocation
r) = forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshotLocation
r
makeConcreteResolver AbstractResolver
ar = do
    RawSnapshotLocation
r <-
        case AbstractResolver
ar of
            AbstractResolver
ARGlobal -> do
                Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
                Path Abs Dir
implicitGlobalDir <- forall env. HasLogFunc env => Config -> RIO env (Path Abs Dir)
getImplicitGlobalProjectDir Config
config
                let fp :: Path Abs File
fp = Path Abs Dir
implicitGlobalDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
stackDotYaml
                IO ProjectAndConfigMonoid
iopc <- forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env a
loadConfigYaml (Path Abs Dir
-> Value -> Parser (WithJSONWarnings (IO ProjectAndConfigMonoid))
parseProjectAndConfigMonoid (forall b t. Path b t -> Path b Dir
parent Path Abs File
fp)) Path Abs File
fp
                ProjectAndConfigMonoid Project
project ConfigMonoid
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ProjectAndConfigMonoid
iopc
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Project -> RawSnapshotLocation
projectResolver Project
project
            AbstractResolver
ARLatestNightly -> SnapName -> RawSnapshotLocation
RSLSynonym forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> SnapName
Nightly forall b c a. (b -> c) -> (a -> b) -> a -> c
. Snapshots -> Day
snapshotsNightly forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env. HasConfig env => RIO env Snapshots
getSnapshots
            ARLatestLTSMajor Int
x -> do
                Snapshots
snapshots <- forall env. HasConfig env => RIO env Snapshots
getSnapshots
                case forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
x forall a b. (a -> b) -> a -> b
$ Snapshots -> IntMap Int
snapshotsLts Snapshots
snapshots of
                    Maybe Int
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Int -> ConfigException
NoLTSWithMajorVersion Int
x
                    Just Int
y -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SnapName -> RawSnapshotLocation
RSLSynonym forall a b. (a -> b) -> a -> b
$ Int -> Int -> SnapName
LTS Int
x Int
y
            AbstractResolver
ARLatestLTS -> do
                Snapshots
snapshots <- forall env. HasConfig env => RIO env Snapshots
getSnapshots
                if forall a. IntMap a -> Bool
IntMap.null forall a b. (a -> b) -> a -> b
$ Snapshots -> IntMap Int
snapshotsLts Snapshots
snapshots
                   then forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ConfigException
NoLTSFound
                   else let (Int
x, Int
y) = forall a. IntMap a -> (Int, a)
IntMap.findMax forall a b. (a -> b) -> a -> b
$ Snapshots -> IntMap Int
snapshotsLts Snapshots
snapshots
                        in forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SnapName -> RawSnapshotLocation
RSLSynonym forall a b. (a -> b) -> a -> b
$ Int -> Int -> SnapName
LTS Int
x Int
y
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Selected resolver: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
r
    forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshotLocation
r

-- | Get the latest snapshot resolver available.

getLatestResolver :: HasConfig env => RIO env RawSnapshotLocation
getLatestResolver :: forall env. HasConfig env => RIO env RawSnapshotLocation
getLatestResolver = do
    Snapshots
snapshots <- forall env. HasConfig env => RIO env Snapshots
getSnapshots
    let mlts :: Maybe SnapName
mlts = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> SnapName
LTS forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
               forall a. [a] -> Maybe a
listToMaybe (forall a. [a] -> [a]
reverse (forall a. IntMap a -> [(Int, a)]
IntMap.toList (Snapshots -> IntMap Int
snapshotsLts Snapshots
snapshots)))
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SnapName -> RawSnapshotLocation
RSLSynonym forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (Day -> SnapName
Nightly (Snapshots -> Day
snapshotsNightly Snapshots
snapshots)) Maybe SnapName
mlts

-- Interprets ConfigMonoid options.

configFromConfigMonoid ::
       HasRunner env
    => Path Abs Dir -- ^ Stack root, e.g. ~/.stack

    -> Path Abs File -- ^ user config file path, e.g. ~/.stack/config.yaml

    -> Maybe AbstractResolver
    -> ProjectConfig (Project, Path Abs File)
    -> ConfigMonoid
    -> (Config -> RIO env a)
    -> RIO env a
configFromConfigMonoid :: forall env a.
HasRunner env =>
Path Abs Dir
-> Path Abs File
-> Maybe AbstractResolver
-> ProjectConfig (Project, Path Abs File)
-> ConfigMonoid
-> (Config -> RIO env a)
-> RIO env a
configFromConfigMonoid
    Path Abs Dir
configStackRoot Path Abs File
configUserConfigPath Maybe AbstractResolver
configResolver
    ProjectConfig (Project, Path Abs File)
configProject ConfigMonoid{[String]
[Text]
[Path Abs Dir]
Maybe AllowNewerDeps
Map Text Text
First Bool
First Int
First String
First [PackageIndexConfig]
First Text
First CasaRepoPrefix
First PackageIndexConfig
First (Path Abs File)
First (Path Abs Dir)
First (Path Rel Dir)
First CompilerBuild
First TemplateName
First VersionCheck
First CompilerRepository
First PvpBounds
First GHCVariant
First SCM
First DumpLogs
First ApplyGhcOptions
First ColorWhen
StylesUpdate
FirstFalse
FirstTrue
MonoidMap PackageName (Dual [Text])
MonoidMap ApplyGhcOptions (Dual [Text])
MonoidMap CabalConfigKey (Dual [Text])
BuildOptsMonoid
NixOptsMonoid
IntersectingVersionRange
DockerOptsMonoid
SetupInfo
configMonoidStackDeveloperMode :: ConfigMonoid -> First Bool
configMonoidNoRunCompile :: ConfigMonoid -> FirstFalse
configMonoidSnapshotLocation :: ConfigMonoid -> First Text
configMonoidCasaRepoPrefix :: ConfigMonoid -> First CasaRepoPrefix
configMonoidRecommendUpgrade :: ConfigMonoid -> FirstTrue
configMonoidHideSourcePaths :: ConfigMonoid -> FirstTrue
configMonoidStyles :: ConfigMonoid -> StylesUpdate
configMonoidColorWhen :: ConfigMonoid -> First ColorWhen
configMonoidHackageBaseUrl :: ConfigMonoid -> First Text
configMonoidSaveHackageCreds :: ConfigMonoid -> First Bool
configMonoidDumpLogs :: ConfigMonoid -> First DumpLogs
configMonoidAllowDifferentUser :: ConfigMonoid -> First Bool
configMonoidDefaultTemplate :: ConfigMonoid -> First TemplateName
configMonoidAllowNewerDeps :: ConfigMonoid -> Maybe AllowNewerDeps
configMonoidAllowNewer :: ConfigMonoid -> First Bool
configMonoidApplyGhcOptions :: ConfigMonoid -> First ApplyGhcOptions
configMonoidRebuildGhcOptions :: ConfigMonoid -> FirstFalse
configMonoidModifyCodePage :: ConfigMonoid -> FirstTrue
configMonoidPvpBounds :: ConfigMonoid -> First PvpBounds
configMonoidLocalProgramsBase :: ConfigMonoid -> First (Path Abs Dir)
configMonoidSetupInfoInline :: ConfigMonoid -> SetupInfo
configMonoidSetupInfoLocations :: ConfigMonoid -> [String]
configMonoidExtraPath :: ConfigMonoid -> [Path Abs Dir]
configMonoidCabalConfigOpts :: ConfigMonoid -> MonoidMap CabalConfigKey (Dual [Text])
configMonoidGhcOptionsByCat :: ConfigMonoid -> MonoidMap ApplyGhcOptions (Dual [Text])
configMonoidGhcOptionsByName :: ConfigMonoid -> MonoidMap PackageName (Dual [Text])
configMonoidScmInit :: ConfigMonoid -> First SCM
configMonoidTemplateParameters :: ConfigMonoid -> Map Text Text
configMonoidLocalBinPath :: ConfigMonoid -> First String
configMonoidConcurrentTests :: ConfigMonoid -> First Bool
configMonoidOverrideHpack :: ConfigMonoid -> First String
configMonoidOverrideGccPath :: ConfigMonoid -> First (Path Abs File)
configMonoidCustomPreprocessorExts :: ConfigMonoid -> [Text]
configMonoidExtraLibDirs :: ConfigMonoid -> [String]
configMonoidExtraIncludeDirs :: ConfigMonoid -> [String]
configMonoidJobs :: ConfigMonoid -> First Int
configMonoidGHCBuild :: ConfigMonoid -> First CompilerBuild
configMonoidGHCVariant :: ConfigMonoid -> First GHCVariant
configMonoidArch :: ConfigMonoid -> First String
configMonoidRequireStackVersion :: ConfigMonoid -> IntersectingVersionRange
configMonoidCompilerRepository :: ConfigMonoid -> First CompilerRepository
configMonoidCompilerCheck :: ConfigMonoid -> First VersionCheck
configMonoidSkipMsys :: ConfigMonoid -> FirstFalse
configMonoidSkipGHCCheck :: ConfigMonoid -> FirstFalse
configMonoidInstallGHC :: ConfigMonoid -> FirstTrue
configMonoidSystemGHC :: ConfigMonoid -> First Bool
configMonoidPackageIndices :: ConfigMonoid -> First [PackageIndexConfig]
configMonoidPackageIndex :: ConfigMonoid -> First PackageIndexConfig
configMonoidLatestSnapshot :: ConfigMonoid -> First Text
configMonoidPrefixTimestamps :: ConfigMonoid -> First Bool
configMonoidHideTHLoading :: ConfigMonoid -> FirstTrue
configMonoidConnectionCount :: ConfigMonoid -> First Int
configMonoidNixOpts :: ConfigMonoid -> NixOptsMonoid
configMonoidDockerOpts :: ConfigMonoid -> DockerOptsMonoid
configMonoidBuildOpts :: ConfigMonoid -> BuildOptsMonoid
configMonoidWorkDir :: ConfigMonoid -> First (Path Rel Dir)
configMonoidStackRoot :: ConfigMonoid -> First (Path Abs Dir)
configMonoidStackDeveloperMode :: First Bool
configMonoidNoRunCompile :: FirstFalse
configMonoidSnapshotLocation :: First Text
configMonoidCasaRepoPrefix :: First CasaRepoPrefix
configMonoidRecommendUpgrade :: FirstTrue
configMonoidHideSourcePaths :: FirstTrue
configMonoidStyles :: StylesUpdate
configMonoidColorWhen :: First ColorWhen
configMonoidHackageBaseUrl :: First Text
configMonoidSaveHackageCreds :: First Bool
configMonoidDumpLogs :: First DumpLogs
configMonoidAllowDifferentUser :: First Bool
configMonoidDefaultTemplate :: First TemplateName
configMonoidAllowNewerDeps :: Maybe AllowNewerDeps
configMonoidAllowNewer :: First Bool
configMonoidApplyGhcOptions :: First ApplyGhcOptions
configMonoidRebuildGhcOptions :: FirstFalse
configMonoidModifyCodePage :: FirstTrue
configMonoidPvpBounds :: First PvpBounds
configMonoidLocalProgramsBase :: First (Path Abs Dir)
configMonoidSetupInfoInline :: SetupInfo
configMonoidSetupInfoLocations :: [String]
configMonoidExtraPath :: [Path Abs Dir]
configMonoidCabalConfigOpts :: MonoidMap CabalConfigKey (Dual [Text])
configMonoidGhcOptionsByCat :: MonoidMap ApplyGhcOptions (Dual [Text])
configMonoidGhcOptionsByName :: MonoidMap PackageName (Dual [Text])
configMonoidScmInit :: First SCM
configMonoidTemplateParameters :: Map Text Text
configMonoidLocalBinPath :: First String
configMonoidConcurrentTests :: First Bool
configMonoidOverrideHpack :: First String
configMonoidOverrideGccPath :: First (Path Abs File)
configMonoidCustomPreprocessorExts :: [Text]
configMonoidExtraLibDirs :: [String]
configMonoidExtraIncludeDirs :: [String]
configMonoidJobs :: First Int
configMonoidGHCBuild :: First CompilerBuild
configMonoidGHCVariant :: First GHCVariant
configMonoidArch :: First String
configMonoidRequireStackVersion :: IntersectingVersionRange
configMonoidCompilerRepository :: First CompilerRepository
configMonoidCompilerCheck :: First VersionCheck
configMonoidSkipMsys :: FirstFalse
configMonoidSkipGHCCheck :: FirstFalse
configMonoidInstallGHC :: FirstTrue
configMonoidSystemGHC :: First Bool
configMonoidPackageIndices :: First [PackageIndexConfig]
configMonoidPackageIndex :: First PackageIndexConfig
configMonoidLatestSnapshot :: First Text
configMonoidPrefixTimestamps :: First Bool
configMonoidHideTHLoading :: FirstTrue
configMonoidConnectionCount :: First Int
configMonoidNixOpts :: NixOptsMonoid
configMonoidDockerOpts :: DockerOptsMonoid
configMonoidBuildOpts :: BuildOptsMonoid
configMonoidWorkDir :: First (Path Rel Dir)
configMonoidStackRoot :: First (Path Abs Dir)
..} Config -> RIO env a
inner = do
     -- If --stack-work is passed, prefer it. Otherwise, if STACK_WORK

     -- is set, use that. If neither, use the default ".stack-work"

     Maybe String
mstackWorkEnv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
stackWorkEnvVar
     let mproject :: Maybe (Project, Path Abs File)
mproject =
           case ProjectConfig (Project, Path Abs File)
configProject of
             PCProject (Project, Path Abs File)
pair -> forall a. a -> Maybe a
Just (Project, Path Abs File)
pair
             ProjectConfig (Project, Path Abs File)
PCGlobalProject -> forall a. Maybe a
Nothing
             PCNoProject [PackageIdentifierRevision]
_deps -> forall a. Maybe a
Nothing
         configAllowLocals :: Bool
configAllowLocals =
           case ProjectConfig (Project, Path Abs File)
configProject of
             PCProject (Project, Path Abs File)
_ -> Bool
True
             ProjectConfig (Project, Path Abs File)
PCGlobalProject -> Bool
True
             PCNoProject [PackageIdentifierRevision]
_ -> Bool
False
     Path Rel Dir
configWorkDir0 <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Rel Dir
relDirStackWork) (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir) Maybe String
mstackWorkEnv
     let configWorkDir :: Path Rel Dir
configWorkDir = forall a. a -> First a -> a
fromFirst Path Rel Dir
configWorkDir0 First (Path Rel Dir)
configMonoidWorkDir
         configLatestSnapshot :: Text
configLatestSnapshot = forall a. a -> First a -> a
fromFirst
           Text
"https://s3.amazonaws.com/haddock.stackage.org/snapshots.json"
           First Text
configMonoidLatestSnapshot
         clConnectionCount :: Int
clConnectionCount = forall a. a -> First a -> a
fromFirst Int
8 First Int
configMonoidConnectionCount
         configHideTHLoading :: Bool
configHideTHLoading = FirstTrue -> Bool
fromFirstTrue FirstTrue
configMonoidHideTHLoading
         configPrefixTimestamps :: Bool
configPrefixTimestamps = forall a. a -> First a -> a
fromFirst Bool
False First Bool
configMonoidPrefixTimestamps

         configGHCVariant :: Maybe GHCVariant
configGHCVariant = forall a. First a -> Maybe a
getFirst First GHCVariant
configMonoidGHCVariant
         configCompilerRepository :: CompilerRepository
configCompilerRepository = forall a. a -> First a -> a
fromFirst
            CompilerRepository
defaultCompilerRepository
            First CompilerRepository
configMonoidCompilerRepository
         configGHCBuild :: Maybe CompilerBuild
configGHCBuild = forall a. First a -> Maybe a
getFirst First CompilerBuild
configMonoidGHCBuild
         configInstallGHC :: Bool
configInstallGHC = FirstTrue -> Bool
fromFirstTrue FirstTrue
configMonoidInstallGHC
         configSkipGHCCheck :: Bool
configSkipGHCCheck = FirstFalse -> Bool
fromFirstFalse FirstFalse
configMonoidSkipGHCCheck
         configSkipMsys :: Bool
configSkipMsys = FirstFalse -> Bool
fromFirstFalse FirstFalse
configMonoidSkipMsys

         configExtraIncludeDirs :: [String]
configExtraIncludeDirs = [String]
configMonoidExtraIncludeDirs
         configExtraLibDirs :: [String]
configExtraLibDirs = [String]
configMonoidExtraLibDirs
         configCustomPreprocessorExts :: [Text]
configCustomPreprocessorExts = [Text]
configMonoidCustomPreprocessorExts
         configOverrideGccPath :: Maybe (Path Abs File)
configOverrideGccPath = forall a. First a -> Maybe a
getFirst First (Path Abs File)
configMonoidOverrideGccPath

         -- Only place in the codebase where platform is hard-coded. In theory

         -- in the future, allow it to be configured.

         (Platform Arch
defArch OS
defOS) = Platform
buildPlatform
         arch :: Arch
arch = forall a. a -> Maybe a -> a
fromMaybe Arch
defArch
              forall a b. (a -> b) -> a -> b
$ forall a. First a -> Maybe a
getFirst First String
configMonoidArch forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Parsec a => String -> Maybe a
Distribution.Text.simpleParse
         os :: OS
os = OS
defOS
         configPlatform :: Platform
configPlatform = Arch -> OS -> Platform
Platform Arch
arch OS
os

         configRequireStackVersion :: VersionRange
configRequireStackVersion = VersionRange -> VersionRange
simplifyVersionRange (IntersectingVersionRange -> VersionRange
getIntersectingVersionRange IntersectingVersionRange
configMonoidRequireStackVersion)

         configCompilerCheck :: VersionCheck
configCompilerCheck = forall a. a -> First a -> a
fromFirst VersionCheck
MatchMinor First VersionCheck
configMonoidCompilerCheck

     case Arch
arch of
         OtherArch String
"aarch64" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
         OtherArch String
unk -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Warning: Unknown value for architecture setting: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow String
unk
         Arch
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

     PlatformVariant
configPlatformVariant <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
         forall b a. b -> (a -> b) -> Maybe a -> b
maybe PlatformVariant
PlatformVariantNone String -> PlatformVariant
PlatformVariant forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
platformVariantEnvVar

     let configBuild :: BuildOpts
configBuild = BuildOptsMonoid -> BuildOpts
buildOptsFromMonoid BuildOptsMonoid
configMonoidBuildOpts
     DockerOpts
configDocker <-
         forall (m :: * -> *).
MonadThrow m =>
Maybe Project
-> Maybe AbstractResolver -> DockerOptsMonoid -> m DockerOpts
dockerOptsFromMonoid (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst Maybe (Project, Path Abs File)
mproject) Maybe AbstractResolver
configResolver DockerOptsMonoid
configMonoidDockerOpts
     NixOpts
configNix <- forall env. HasRunner env => NixOptsMonoid -> OS -> RIO env NixOpts
nixOptsFromMonoid NixOptsMonoid
configMonoidNixOpts OS
os

     Bool
configSystemGHC <-
         case (forall a. First a -> Maybe a
getFirst First Bool
configMonoidSystemGHC, NixOpts -> Bool
nixEnable NixOpts
configNix) of
             (Just Bool
False, Bool
True) ->
                 forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ConfigException
NixRequiresSystemGhc
             (Maybe Bool, Bool)
_ ->
                 forall (f :: * -> *) a. Applicative f => a -> f a
pure
                     (forall a. a -> First a -> a
fromFirst
                         (DockerOpts -> Bool
dockerEnable DockerOpts
configDocker Bool -> Bool -> Bool
|| NixOpts -> Bool
nixEnable NixOpts
configNix)
                         First Bool
configMonoidSystemGHC)

     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe GHCVariant
configGHCVariant Bool -> Bool -> Bool
&& Bool
configSystemGHC) forall a b. (a -> b) -> a -> b
$
         forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ConfigException
ManualGHCVariantSettingsAreIncompatibleWithSystemGHC

     [(String, String)]
rawEnv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(String, String)]
getEnvironment
     Map Text Text
pathsEnv <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall (f :: * -> *) a. Applicative f => a -> f a
pure
               forall a b. (a -> b) -> a -> b
$ [String]
-> Map Text Text -> Either ProcessException (Map Text Text)
augmentPathMap (forall a b. (a -> b) -> [a] -> [b]
map forall b t. Path b t -> String
toFilePath [Path Abs Dir]
configMonoidExtraPath)
                                (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** String -> Text
T.pack) [(String, String)]
rawEnv))
     ProcessContext
origEnv <- forall (m :: * -> *).
MonadIO m =>
Map Text Text -> m ProcessContext
mkProcessContext Map Text Text
pathsEnv
     let configProcessContextSettings :: EnvSettings -> IO ProcessContext
configProcessContextSettings EnvSettings
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessContext
origEnv

     Path Abs Dir
configLocalProgramsBase <- case forall a. First a -> Maybe a
getFirst First (Path Abs Dir)
configMonoidLocalProgramsBase of
       Maybe (Path Abs Dir)
Nothing -> forall (m :: * -> *).
MonadThrow m =>
Path Abs Dir -> Platform -> ProcessContext -> m (Path Abs Dir)
getDefaultLocalProgramsBase Path Abs Dir
configStackRoot Platform
configPlatform ProcessContext
origEnv
       Just Path Abs Dir
path -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
path
     let localProgramsFilePath :: String
localProgramsFilePath = forall b t. Path b t -> String
toFilePath Path Abs Dir
configLocalProgramsBase
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
osIsWindows Bool -> Bool -> Bool
&& Char
' ' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
localProgramsFilePath) forall a b. (a -> b) -> a -> b
$ do
       forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
configLocalProgramsBase
       -- getShortPathName returns the long path name when a short name does not

       -- exist.

       String
shortLocalProgramsFilePath <-
         forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO String
getShortPathName String
localProgramsFilePath
       forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char
' ' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
shortLocalProgramsFilePath) forall a b. (a -> b) -> a -> b
$ do
         forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Error: [S-8432]\n"forall a. Semigroup a => a -> a -> a
<>
           Utf8Builder
"Stack's 'programs' path contains a space character and has no " forall a. Semigroup a => a -> a -> a
<>
           Utf8Builder
"alternative short ('8 dot 3') name. This will cause problems " forall a. Semigroup a => a -> a -> a
<>
           Utf8Builder
"with packages that use the GNU project's 'configure' shell " forall a. Semigroup a => a -> a -> a
<>
           Utf8Builder
"script. Use the 'local-programs-path' configuration option to " forall a. Semigroup a => a -> a -> a
<>
           Utf8Builder
"specify an alternative path. The current path is: " forall a. Semigroup a => a -> a -> a
<>
           forall a. Display a => a -> Utf8Builder
display (String -> Text
T.pack String
localProgramsFilePath)
     Path Rel Dir
platformOnlyDir <- forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall env (m :: * -> *).
(MonadReader env m, HasPlatform env, MonadThrow m) =>
m (Path Rel Dir)
platformOnlyRelDir (Platform
configPlatform, PlatformVariant
configPlatformVariant)
     let configLocalPrograms :: Path Abs Dir
configLocalPrograms = Path Abs Dir
configLocalProgramsBase forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
platformOnlyDir

     Path Abs Dir
configLocalBin <-
         case forall a. First a -> Maybe a
getFirst First String
configMonoidLocalBinPath of
             Maybe String
Nothing -> do
                 Path Abs Dir
localDir <- forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
getAppUserDataDir String
"local"
                 forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Path Abs Dir
localDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirBin
             Just String
userPath ->
                 (case Maybe (Project, Path Abs File)
mproject of
                     -- Not in a project

                     Maybe (Project, Path Abs File)
Nothing -> forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' String
userPath
                     -- Resolves to the project dir and appends the user path if it is relative

                     Just (Project
_, Path Abs File
configYaml) -> forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Path Abs Dir)
resolveDir (forall b t. Path b t -> Path b Dir
parent Path Abs File
configYaml) String
userPath)
                 -- TODO: Either catch specific exceptions or add a

                 -- parseRelAsAbsDirMaybe utility and use it along with

                 -- resolveDirMaybe.

                 forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny`
                 forall a b. a -> b -> a
const (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (String -> ConfigException
NoSuchDirectory String
userPath))

     Int
configJobs <-
        case forall a. First a -> Maybe a
getFirst First Int
configMonoidJobs of
            Maybe Int
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumProcessors
            Just Int
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
i
     let configConcurrentTests :: Bool
configConcurrentTests = forall a. a -> First a -> a
fromFirst Bool
True First Bool
configMonoidConcurrentTests

     let configTemplateParams :: Map Text Text
configTemplateParams = Map Text Text
configMonoidTemplateParameters
         configScmInit :: Maybe SCM
configScmInit = forall a. First a -> Maybe a
getFirst First SCM
configMonoidScmInit
         configCabalConfigOpts :: Map CabalConfigKey [Text]
configCabalConfigOpts = coerce :: forall a b. Coercible a b => a -> b
coerce MonoidMap CabalConfigKey (Dual [Text])
configMonoidCabalConfigOpts
         configGhcOptionsByName :: Map PackageName [Text]
configGhcOptionsByName = coerce :: forall a b. Coercible a b => a -> b
coerce MonoidMap PackageName (Dual [Text])
configMonoidGhcOptionsByName
         configGhcOptionsByCat :: Map ApplyGhcOptions [Text]
configGhcOptionsByCat = coerce :: forall a b. Coercible a b => a -> b
coerce MonoidMap ApplyGhcOptions (Dual [Text])
configMonoidGhcOptionsByCat
         configSetupInfoLocations :: [String]
configSetupInfoLocations = [String]
configMonoidSetupInfoLocations
         configSetupInfoInline :: SetupInfo
configSetupInfoInline = SetupInfo
configMonoidSetupInfoInline
         configPvpBounds :: PvpBounds
configPvpBounds = forall a. a -> First a -> a
fromFirst (PvpBoundsType -> Bool -> PvpBounds
PvpBounds PvpBoundsType
PvpBoundsNone Bool
False) First PvpBounds
configMonoidPvpBounds
         configModifyCodePage :: Bool
configModifyCodePage = FirstTrue -> Bool
fromFirstTrue FirstTrue
configMonoidModifyCodePage
         configRebuildGhcOptions :: Bool
configRebuildGhcOptions = FirstFalse -> Bool
fromFirstFalse FirstFalse
configMonoidRebuildGhcOptions
         configApplyGhcOptions :: ApplyGhcOptions
configApplyGhcOptions = forall a. a -> First a -> a
fromFirst ApplyGhcOptions
AGOLocals First ApplyGhcOptions
configMonoidApplyGhcOptions
         configAllowNewer :: Bool
configAllowNewer = forall a. a -> First a -> a
fromFirst Bool
False First Bool
configMonoidAllowNewer
         configAllowNewerDeps :: Maybe [PackageName]
configAllowNewerDeps = coerce :: forall a b. Coercible a b => a -> b
coerce Maybe AllowNewerDeps
configMonoidAllowNewerDeps
         configDefaultTemplate :: Maybe TemplateName
configDefaultTemplate = forall a. First a -> Maybe a
getFirst First TemplateName
configMonoidDefaultTemplate
         configDumpLogs :: DumpLogs
configDumpLogs = forall a. a -> First a -> a
fromFirst DumpLogs
DumpWarningLogs First DumpLogs
configMonoidDumpLogs
         configSaveHackageCreds :: Bool
configSaveHackageCreds = forall a. a -> First a -> a
fromFirst Bool
True First Bool
configMonoidSaveHackageCreds
         configHackageBaseUrl :: Text
configHackageBaseUrl = forall a. a -> First a -> a
fromFirst Text
"https://hackage.haskell.org/" First Text
configMonoidHackageBaseUrl
         configHideSourcePaths :: Bool
configHideSourcePaths = FirstTrue -> Bool
fromFirstTrue FirstTrue
configMonoidHideSourcePaths
         configRecommendUpgrade :: Bool
configRecommendUpgrade = FirstTrue -> Bool
fromFirstTrue FirstTrue
configMonoidRecommendUpgrade
         configNoRunCompile :: Bool
configNoRunCompile = FirstFalse -> Bool
fromFirstFalse FirstFalse
configMonoidNoRunCompile

     Bool
configAllowDifferentUser <-
        case forall a. First a -> Maybe a
getFirst First Bool
configMonoidAllowDifferentUser of
            Just Bool
True -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
            Maybe Bool
_ -> forall (m :: * -> *). MonadIO m => m Bool
getInContainer

     Runner
configRunner' <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasRunner env => Lens' env Runner
runnerL

     Bool
useAnsi <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Bool
True forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                         Handle -> IO (Maybe Bool)
hSupportsANSIWithoutEmulation Handle
stderr

     let stylesUpdate' :: StylesUpdate
stylesUpdate' = (Runner
configRunner' forall s a. s -> Getting a s a -> a
^. forall env. HasStylesUpdate env => Lens' env StylesUpdate
stylesUpdateL) forall a. Semigroup a => a -> a -> a
<>
           StylesUpdate
configMonoidStyles
         useColor' :: Bool
useColor' = Runner -> Bool
runnerUseColor Runner
configRunner'
         mUseColor :: Maybe Bool
mUseColor = do
            ColorWhen
colorWhen <- forall a. First a -> Maybe a
getFirst First ColorWhen
configMonoidColorWhen
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case ColorWhen
colorWhen of
                ColorWhen
ColorNever  -> Bool
False
                ColorWhen
ColorAlways -> Bool
True
                ColorWhen
ColorAuto  -> Bool
useAnsi
         useColor'' :: Bool
useColor'' = forall a. a -> Maybe a -> a
fromMaybe Bool
useColor' Maybe Bool
mUseColor
         configRunner'' :: Runner
configRunner'' = Runner
configRunner'
               forall a b. a -> (a -> b) -> b
& forall env. HasProcessContext env => Lens' env ProcessContext
processContextL forall s t a b. ASetter s t a b -> b -> s -> t
.~ ProcessContext
origEnv
               forall a b. a -> (a -> b) -> b
& forall env. HasStylesUpdate env => Lens' env StylesUpdate
stylesUpdateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ StylesUpdate
stylesUpdate'
               forall a b. a -> (a -> b) -> b
& forall env. HasTerm env => Lens' env Bool
useColorL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
useColor''
         go :: GlobalOpts
go = Runner -> GlobalOpts
runnerGlobalOpts Runner
configRunner'

     PackageIndexConfig
pic <-
         case forall a. First a -> Maybe a
getFirst First PackageIndexConfig
configMonoidPackageIndex of
             Maybe PackageIndexConfig
Nothing ->
                 case forall a. First a -> Maybe a
getFirst First [PackageIndexConfig]
configMonoidPackageIndices of
                     Maybe [PackageIndexConfig]
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIndexConfig
defaultPackageIndexConfig
                     Just [PackageIndexConfig
pic] -> do
                         forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString String
packageIndicesWarning
                         forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIndexConfig
pic
                     Just [PackageIndexConfig]
x -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ [PackageIndexConfig] -> ConfigException
MultiplePackageIndices [PackageIndexConfig]
x
             Just PackageIndexConfig
pic -> forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIndexConfig
pic
     Maybe String
mpantryRoot <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
pantryRootEnvVar
     Path Abs Dir
pantryRoot <-
       case Maybe String
mpantryRoot of
         Just String
dir ->
           case forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir String
dir of
             Maybe (Path Abs Dir)
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ String -> String -> ParseAbsolutePathException
ParseAbsolutePathException String
pantryRootEnvVar String
dir
             Just Path Abs Dir
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
x
         Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Path Abs Dir
configStackRoot forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirPantry

     let snapLoc :: SnapName -> RawSnapshotLocation
snapLoc =
            case forall a. First a -> Maybe a
getFirst First Text
configMonoidSnapshotLocation of
                Maybe Text
Nothing -> SnapName -> RawSnapshotLocation
defaultSnapshotLocation
                Just Text
addr -> SnapName -> RawSnapshotLocation
customSnapshotLocation
                                where
                    customSnapshotLocation :: SnapName -> RawSnapshotLocation
customSnapshotLocation (LTS Int
x Int
y) =
                        Utf8Builder -> RawSnapshotLocation
mkRSLUrl forall a b. (a -> b) -> a -> b
$ Utf8Builder
addr'
                            forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/lts/" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
x
                            forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
y forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".yaml"
                    customSnapshotLocation (Nightly Day
date) =
                        let (Year
year, Int
month, Int
day) = Day -> (Year, Int, Int)
toGregorian Day
date
                        in Utf8Builder -> RawSnapshotLocation
mkRSLUrl forall a b. (a -> b) -> a -> b
$ Utf8Builder
addr'
                            forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/nightly/"
                            forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Year
year
                            forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
month
                            forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
day forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".yaml"
                    mkRSLUrl :: Utf8Builder -> RawSnapshotLocation
mkRSLUrl Utf8Builder
builder = Text -> Maybe BlobKey -> RawSnapshotLocation
RSLUrl (Utf8Builder -> Text
utf8BuilderToText Utf8Builder
builder) forall a. Maybe a
Nothing
                    addr' :: Utf8Builder
addr' = forall a. Display a => a -> Utf8Builder
display forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhileEnd (forall a. Eq a => a -> a -> Bool
==Char
'/') Text
addr

     let configStackDeveloperMode :: Bool
configStackDeveloperMode = forall a. a -> First a -> a
fromFirst Bool
stackDeveloperModeDefault First Bool
configMonoidStackDeveloperMode

     forall (m :: * -> *) a.
MonadUnliftIO m =>
GlobalOpts -> Bool -> StylesUpdate -> (LogFunc -> m a) -> m a
withNewLogFunc GlobalOpts
go Bool
useColor'' StylesUpdate
stylesUpdate' forall a b. (a -> b) -> a -> b
$ \LogFunc
logFunc -> do
       let configRunner :: Runner
configRunner = Runner
configRunner'' forall a b. a -> (a -> b) -> b
& forall env. HasLogFunc env => Lens' env LogFunc
logFuncL forall s t a b. ASetter s t a b -> b -> s -> t
.~ LogFunc
logFunc
       forall env a. HasLogFunc env => LogFunc -> RIO env a -> RIO env a
withLocalLogFunc LogFunc
logFunc forall a b. (a -> b) -> a -> b
$ forall env a. HasLogFunc env => RIO env a -> RIO env a
handleMigrationException forall a b. (a -> b) -> a -> b
$
         forall env a.
HasLogFunc env =>
Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Int
-> CasaRepoPrefix
-> Int
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig
           Path Abs Dir
pantryRoot
           PackageIndexConfig
pic
           (forall b a. b -> (a -> b) -> Maybe a -> b
maybe HpackExecutable
HpackBundled String -> HpackExecutable
HpackCommand forall a b. (a -> b) -> a -> b
$ forall a. First a -> Maybe a
getFirst First String
configMonoidOverrideHpack)
           Int
clConnectionCount
           (forall a. a -> First a -> a
fromFirst CasaRepoPrefix
defaultCasaRepoPrefix First CasaRepoPrefix
configMonoidCasaRepoPrefix)
           Int
defaultCasaMaxPerRequest
           SnapName -> RawSnapshotLocation
snapLoc
           (\PantryConfig
configPantryConfig -> forall env a.
HasLogFunc env =>
Path Abs File -> (UserStorage -> RIO env a) -> RIO env a
initUserStorage
             (Path Abs Dir
configStackRoot forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileStorage)
             (\UserStorage
configUserStorage -> Config -> RIO env a
inner Config {Bool
Int
[String]
[Text]
Maybe [PackageName]
Maybe (Path Abs File)
Maybe CompilerBuild
Maybe AbstractResolver
Maybe TemplateName
Maybe GHCVariant
Maybe SCM
Platform
VersionRange
Map PackageName [Text]
Map Text Text
Map ApplyGhcOptions [Text]
Map CabalConfigKey [Text]
Text
PantryConfig
Path Abs File
Path Abs Dir
Path Rel Dir
BuildOpts
NixOpts
VersionCheck
DockerOpts
CompilerRepository
PvpBounds
SetupInfo
PlatformVariant
ProjectConfig (Project, Path Abs File)
DumpLogs
ApplyGhcOptions
UserStorage
Runner
EnvSettings -> IO ProcessContext
configStackDeveloperMode :: Bool
configNoRunCompile :: Bool
configRecommendUpgrade :: Bool
configHideSourcePaths :: Bool
configUserStorage :: UserStorage
configResolver :: Maybe AbstractResolver
configStackRoot :: Path Abs Dir
configPantryConfig :: PantryConfig
configRunner :: Runner
configHackageBaseUrl :: Text
configSaveHackageCreds :: Bool
configAllowLocals :: Bool
configProject :: ProjectConfig (Project, Path Abs File)
configDumpLogs :: DumpLogs
configAllowDifferentUser :: Bool
configDefaultTemplate :: Maybe TemplateName
configAllowNewerDeps :: Maybe [PackageName]
configAllowNewer :: Bool
configApplyGhcOptions :: ApplyGhcOptions
configRebuildGhcOptions :: Bool
configModifyCodePage :: Bool
configPvpBounds :: PvpBounds
configSetupInfoInline :: SetupInfo
configSetupInfoLocations :: [String]
configCabalConfigOpts :: Map CabalConfigKey [Text]
configGhcOptionsByCat :: Map ApplyGhcOptions [Text]
configGhcOptionsByName :: Map PackageName [Text]
configScmInit :: Maybe SCM
configTemplateParams :: Map Text Text
configConcurrentTests :: Bool
configCustomPreprocessorExts :: [Text]
configExtraLibDirs :: [String]
configExtraIncludeDirs :: [String]
configOverrideGccPath :: Maybe (Path Abs File)
configJobs :: Int
configRequireStackVersion :: VersionRange
configLocalBin :: Path Abs Dir
configCompilerRepository :: CompilerRepository
configCompilerCheck :: VersionCheck
configSkipMsys :: Bool
configSkipGHCCheck :: Bool
configInstallGHC :: Bool
configSystemGHC :: Bool
configLatestSnapshot :: Text
configGHCBuild :: Maybe CompilerBuild
configGHCVariant :: Maybe GHCVariant
configPlatformVariant :: PlatformVariant
configPlatform :: Platform
configPrefixTimestamps :: Bool
configHideTHLoading :: Bool
configLocalPrograms :: Path Abs Dir
configLocalProgramsBase :: Path Abs Dir
configProcessContextSettings :: EnvSettings -> IO ProcessContext
configNix :: NixOpts
configDocker :: DockerOpts
configBuild :: BuildOpts
configUserConfigPath :: Path Abs File
configWorkDir :: Path Rel Dir
configUserStorage :: UserStorage
configPantryConfig :: PantryConfig
configRunner :: Runner
configStackDeveloperMode :: Bool
configAllowDifferentUser :: Bool
configNoRunCompile :: Bool
configRecommendUpgrade :: Bool
configHideSourcePaths :: Bool
configHackageBaseUrl :: Text
configSaveHackageCreds :: Bool
configDumpLogs :: DumpLogs
configDefaultTemplate :: Maybe TemplateName
configAllowNewerDeps :: Maybe [PackageName]
configAllowNewer :: Bool
configApplyGhcOptions :: ApplyGhcOptions
configRebuildGhcOptions :: Bool
configModifyCodePage :: Bool
configPvpBounds :: PvpBounds
configSetupInfoInline :: SetupInfo
configSetupInfoLocations :: [String]
configGhcOptionsByCat :: Map ApplyGhcOptions [Text]
configGhcOptionsByName :: Map PackageName [Text]
configCabalConfigOpts :: Map CabalConfigKey [Text]
configScmInit :: Maybe SCM
configTemplateParams :: Map Text Text
configConcurrentTests :: Bool
configJobs :: Int
configLocalBin :: Path Abs Dir
configLocalPrograms :: Path Abs Dir
configLocalProgramsBase :: Path Abs Dir
configProcessContextSettings :: EnvSettings -> IO ProcessContext
configSystemGHC :: Bool
configNix :: NixOpts
configDocker :: DockerOpts
configBuild :: BuildOpts
configPlatformVariant :: PlatformVariant
configCompilerCheck :: VersionCheck
configRequireStackVersion :: VersionRange
configPlatform :: Platform
configOverrideGccPath :: Maybe (Path Abs File)
configCustomPreprocessorExts :: [Text]
configExtraLibDirs :: [String]
configExtraIncludeDirs :: [String]
configSkipMsys :: Bool
configSkipGHCCheck :: Bool
configInstallGHC :: Bool
configGHCBuild :: Maybe CompilerBuild
configCompilerRepository :: CompilerRepository
configGHCVariant :: Maybe GHCVariant
configPrefixTimestamps :: Bool
configHideTHLoading :: Bool
configLatestSnapshot :: Text
configWorkDir :: Path Rel Dir
configAllowLocals :: Bool
configProject :: ProjectConfig (Project, Path Abs File)
configResolver :: Maybe AbstractResolver
configUserConfigPath :: Path Abs File
configStackRoot :: Path Abs Dir
..}))

-- | Runs the provided action with the given 'LogFunc' in the environment

withLocalLogFunc :: HasLogFunc env => LogFunc -> RIO env a -> RIO env a
withLocalLogFunc :: forall env a. HasLogFunc env => LogFunc -> RIO env a -> RIO env a
withLocalLogFunc LogFunc
logFunc = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (forall s t a b. ASetter s t a b -> b -> s -> t
set forall env. HasLogFunc env => Lens' env LogFunc
logFuncL LogFunc
logFunc)

-- | Runs the provided action with a new 'LogFunc', given a 'StylesUpdate'.

withNewLogFunc :: MonadUnliftIO m
               => GlobalOpts
               -> Bool  -- ^ Use color

               -> StylesUpdate
               -> (LogFunc -> m a)
               -> m a
withNewLogFunc :: forall (m :: * -> *) a.
MonadUnliftIO m =>
GlobalOpts -> Bool -> StylesUpdate -> (LogFunc -> m a) -> m a
withNewLogFunc GlobalOpts
go Bool
useColor (StylesUpdate [(Style, StyleSpec)]
update) LogFunc -> m a
inner = do
  LogOptions
logOptions0 <- forall (m :: * -> *). MonadIO m => Handle -> Bool -> m LogOptions
logOptionsHandle Handle
stderr Bool
False
  let logOptions :: LogOptions
logOptions
        = Bool -> LogOptions -> LogOptions
setLogUseColor Bool
useColor
        forall a b. (a -> b) -> a -> b
$ (LogLevel -> Utf8Builder) -> LogOptions -> LogOptions
setLogLevelColors LogLevel -> Utf8Builder
logLevelColors
        forall a b. (a -> b) -> a -> b
$ Utf8Builder -> LogOptions -> LogOptions
setLogSecondaryColor Utf8Builder
secondaryColor
        forall a b. (a -> b) -> a -> b
$ (Int -> Utf8Builder) -> LogOptions -> LogOptions
setLogAccentColors (forall a b. a -> b -> a
const Utf8Builder
highlightColor)
        forall a b. (a -> b) -> a -> b
$ Bool -> LogOptions -> LogOptions
setLogUseTime (GlobalOpts -> Bool
globalTimeInLog GlobalOpts
go)
        forall a b. (a -> b) -> a -> b
$ LogLevel -> LogOptions -> LogOptions
setLogMinLevel (GlobalOpts -> LogLevel
globalLogLevel GlobalOpts
go)
        forall a b. (a -> b) -> a -> b
$ Bool -> LogOptions -> LogOptions
setLogVerboseFormat (GlobalOpts -> LogLevel
globalLogLevel GlobalOpts
go forall a. Ord a => a -> a -> Bool
<= LogLevel
LevelDebug)
        forall a b. (a -> b) -> a -> b
$ Bool -> LogOptions -> LogOptions
setLogTerminal (GlobalOpts -> Bool
globalTerminal GlobalOpts
go)
          LogOptions
logOptions0
  forall (m :: * -> *) a.
MonadUnliftIO m =>
LogOptions -> (LogFunc -> m a) -> m a
withLogFunc LogOptions
logOptions LogFunc -> m a
inner
 where
  styles :: Array Style StyleSpec
styles = Array Style StyleSpec
defaultStyles forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)] -> a i e
// [(Style, StyleSpec)]
update
  logLevelColors :: LogLevel -> Utf8Builder
  logLevelColors :: LogLevel -> Utf8Builder
logLevelColors LogLevel
level =
    forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Array Style StyleSpec
styles forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! LogLevel -> Style
logLevelToStyle LogLevel
level
  secondaryColor :: Utf8Builder
secondaryColor = forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Array Style StyleSpec
styles forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Style
Secondary
  highlightColor :: Utf8Builder
highlightColor = forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Array Style StyleSpec
styles forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Style
Highlight

-- | Get the default location of the local programs directory.

getDefaultLocalProgramsBase :: MonadThrow m
                            => Path Abs Dir
                            -> Platform
                            -> ProcessContext
                            -> m (Path Abs Dir)
getDefaultLocalProgramsBase :: forall (m :: * -> *).
MonadThrow m =>
Path Abs Dir -> Platform -> ProcessContext -> m (Path Abs Dir)
getDefaultLocalProgramsBase Path Abs Dir
configStackRoot Platform
configPlatform ProcessContext
override =
    case Platform
configPlatform of
      -- For historical reasons, on Windows a subdirectory of LOCALAPPDATA is

      -- used instead of a subdirectory of STACK_ROOT. Unifying the defaults would

      -- mean that Windows users would manually have to move data from the old

      -- location to the new one, which is undesirable.

        Platform Arch
_ OS
Windows -> do
            let envVars :: Map Text Text
envVars = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env.
HasProcessContext env =>
SimpleGetter env (Map Text Text)
envVarsL ProcessContext
override
            case Text -> String
T.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"LOCALAPPDATA" Map Text Text
envVars of
                Just String
t -> case forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir String
t of
                    Maybe (Path Abs Dir)
Nothing ->
                        forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> String -> ParseAbsolutePathException
ParseAbsolutePathException String
"LOCALAPPDATA" String
t
                    Just Path Abs Dir
lad ->
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Path Abs Dir
lad forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirUpperPrograms forall b t. Path b Dir -> Path Rel t -> Path b t
</>
                               Path Rel Dir
relDirStackProgName
                Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
defaultBase
        Platform
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
defaultBase
  where
    defaultBase :: Path Abs Dir
defaultBase = Path Abs Dir
configStackRoot forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirPrograms

-- | Load the configuration, using current directory, environment variables,

-- and defaults as necessary.

loadConfig :: HasRunner env => (Config -> RIO env a) -> RIO env a
loadConfig :: forall env a. HasRunner env => (Config -> RIO env a) -> RIO env a
loadConfig Config -> RIO env a
inner = do
    StackYamlLoc
mstackYaml <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasRunner env => Lens' env GlobalOpts
globalOptsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to GlobalOpts -> StackYamlLoc
globalStackYaml
    ProjectConfig (Project, Path Abs File, ConfigMonoid)
mproject <- forall env.
HasLogFunc env =>
StackYamlLoc
-> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid))
loadProjectConfig StackYamlLoc
mstackYaml
    Maybe AbstractResolver
mresolver <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasRunner env => Lens' env GlobalOpts
globalOptsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to GlobalOpts -> Maybe AbstractResolver
globalResolver
    ConfigMonoid
configArgs <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasRunner env => Lens' env GlobalOpts
globalOptsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to GlobalOpts -> ConfigMonoid
globalConfigMonoid
    (Path Abs Dir
configRoot, Path Abs Dir
stackRoot, Bool
userOwnsStackRoot) <- forall (m :: * -> *).
MonadIO m =>
ConfigMonoid -> m (Path Abs Dir, Path Abs Dir, Bool)
determineStackRootAndOwnership ConfigMonoid
configArgs

    let (ProjectConfig (Project, Path Abs File)
mproject', [ConfigMonoid] -> [ConfigMonoid]
addConfigMonoid) =
          case ProjectConfig (Project, Path Abs File, ConfigMonoid)
mproject of
            PCProject (Project
proj, Path Abs File
fp, ConfigMonoid
cm) -> (forall a. a -> ProjectConfig a
PCProject (Project
proj, Path Abs File
fp), (ConfigMonoid
cmforall a. a -> [a] -> [a]
:))
            ProjectConfig (Project, Path Abs File, ConfigMonoid)
PCGlobalProject -> (forall a. ProjectConfig a
PCGlobalProject, forall a. a -> a
id)
            PCNoProject [PackageIdentifierRevision]
deps -> (forall a. [PackageIdentifierRevision] -> ProjectConfig a
PCNoProject [PackageIdentifierRevision]
deps, forall a. a -> a
id)

    Path Abs File
userConfigPath <- forall env.
HasLogFunc env =>
Path Abs Dir -> RIO env (Path Abs File)
getDefaultUserConfigPath Path Abs Dir
configRoot
    [ConfigMonoid]
extraConfigs0 <- forall env.
HasLogFunc env =>
Path Abs File -> RIO env [Path Abs File]
getExtraConfigs Path Abs File
userConfigPath forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Path Abs File
file -> forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env a
loadConfigYaml (Path Abs Dir -> Value -> Parser (WithJSONWarnings ConfigMonoid)
parseConfigMonoid (forall b t. Path b t -> Path b Dir
parent Path Abs File
file)) Path Abs File
file)
    let extraConfigs :: [ConfigMonoid]
extraConfigs =
          -- non-project config files' existence of a docker section should never default docker

          -- to enabled, so make it look like they didn't exist

          forall a b. (a -> b) -> [a] -> [b]
map (\ConfigMonoid
c -> ConfigMonoid
c {configMonoidDockerOpts :: DockerOptsMonoid
configMonoidDockerOpts =
                            (ConfigMonoid -> DockerOptsMonoid
configMonoidDockerOpts ConfigMonoid
c) {dockerMonoidDefaultEnable :: Any
dockerMonoidDefaultEnable = Bool -> Any
Any Bool
False}})
              [ConfigMonoid]
extraConfigs0

    let withConfig :: (Config -> RIO env a) -> RIO env a
withConfig =
          forall env a.
HasRunner env =>
Path Abs Dir
-> Path Abs File
-> Maybe AbstractResolver
-> ProjectConfig (Project, Path Abs File)
-> ConfigMonoid
-> (Config -> RIO env a)
-> RIO env a
configFromConfigMonoid
            Path Abs Dir
stackRoot
            Path Abs File
userConfigPath
            Maybe AbstractResolver
mresolver
            ProjectConfig (Project, Path Abs File)
mproject'
            (forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ ConfigMonoid
configArgs forall a. a -> [a] -> [a]
: [ConfigMonoid] -> [ConfigMonoid]
addConfigMonoid [ConfigMonoid]
extraConfigs)

    (Config -> RIO env a) -> RIO env a
withConfig forall a b. (a -> b) -> a -> b
$ \Config
config -> do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Version
stackVersion Version -> VersionRange -> Bool
`withinRange` Config -> VersionRange
configRequireStackVersion Config
config)
          (forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (VersionRange -> ConfigException
BadStackVersionException (Config -> VersionRange
configRequireStackVersion Config
config)))
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Config -> Bool
configAllowDifferentUser Config
config) forall a b. (a -> b) -> a -> b
$ do
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
userOwnsStackRoot forall a b. (a -> b) -> a -> b
$
              forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Path Abs Dir -> ConfigException
UserDoesn'tOwnDirectory Path Abs Dir
stackRoot)
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Config -> Maybe (Path Abs Dir)
configProjectRoot Config
config) forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir ->
              forall (m :: * -> *). MonadIO m => Path Abs Dir -> m ()
checkOwnership (Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Config -> Path Rel Dir
configWorkDir Config
config)
      Config -> RIO env a
inner Config
config

-- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@.

-- values.

withBuildConfig ::
     RIO BuildConfig a
  -> RIO Config a
withBuildConfig :: forall a. RIO BuildConfig a -> RIO Config a
withBuildConfig RIO BuildConfig a
inner = do
    Config
config <- forall r (m :: * -> *). MonadReader r m => m r
ask

    -- If provided, turn the AbstractResolver from the command line

    -- into a Resolver that can be used below.


    -- The configResolver and mcompiler are provided on the command

    -- line. In order to properly deal with an AbstractResolver, we

    -- need a base directory (to deal with custom snapshot relative

    -- paths). We consider the current working directory to be the

    -- correct base. Let's calculate the mresolver first.

    Maybe RawSnapshotLocation
mresolver <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Config -> Maybe AbstractResolver
configResolver Config
config) forall a b. (a -> b) -> a -> b
$ \AbstractResolver
aresolver -> do
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Using resolver: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display AbstractResolver
aresolver forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" specified on command line")
      forall env.
HasConfig env =>
AbstractResolver -> RIO env RawSnapshotLocation
makeConcreteResolver AbstractResolver
aresolver

    (Project
project', Path Abs File
stackYamlFP) <- case Config -> ProjectConfig (Project, Path Abs File)
configProject Config
config of
      PCProject (Project
project, Path Abs File
fp) -> do
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Project -> Maybe String
projectUserMsg Project
project) (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (Project
project, Path Abs File
fp)
      PCNoProject [PackageIdentifierRevision]
extraDeps -> do
          Project
p <-
            case Maybe RawSnapshotLocation
mresolver of
              Maybe RawSnapshotLocation
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ConfigException
NoResolverWhenUsingNoProject
              Just RawSnapshotLocation
_ -> Maybe RawSnapshotLocation
-> [PackageIdentifierRevision] -> RIO Config Project
getEmptyProject Maybe RawSnapshotLocation
mresolver [PackageIdentifierRevision]
extraDeps
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (Project
p, Config -> Path Abs File
configUserConfigPath Config
config)
      ProjectConfig (Project, Path Abs File)
PCGlobalProject -> do
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Run from outside a project, using implicit global project config"
            Path Abs Dir
destDir <- forall env. HasLogFunc env => Config -> RIO env (Path Abs Dir)
getImplicitGlobalProjectDir Config
config
            let dest :: Path Abs File
                dest :: Path Abs File
dest = Path Abs Dir
destDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
stackDotYaml
                dest' :: FilePath
                dest' :: String
dest' = forall b t. Path b t -> String
toFilePath Path Abs File
dest
            forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
destDir
            Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
dest
            if Bool
exists
               then do
                   IO ProjectAndConfigMonoid
iopc <- forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env a
loadConfigYaml (Path Abs Dir
-> Value -> Parser (WithJSONWarnings (IO ProjectAndConfigMonoid))
parseProjectAndConfigMonoid Path Abs Dir
destDir) Path Abs File
dest
                   ProjectAndConfigMonoid Project
project ConfigMonoid
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ProjectAndConfigMonoid
iopc
                   forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasRunner env => Lens' env Bool
terminalL Config
config) forall a b. (a -> b) -> a -> b
$
                       case Config -> Maybe AbstractResolver
configResolver Config
config of
                           Maybe AbstractResolver
Nothing ->
                               forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$
                                 Utf8Builder
"Using resolver: " forall a. Semigroup a => a -> a -> a
<>
                                 forall a. Display a => a -> Utf8Builder
display (Project -> RawSnapshotLocation
projectResolver Project
project) forall a. Semigroup a => a -> a -> a
<>
                                 Utf8Builder
" from implicit global project's config file: " forall a. Semigroup a => a -> a -> a
<>
                                 forall a. IsString a => String -> a
fromString String
dest'
                           Just AbstractResolver
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                   forall (f :: * -> *) a. Applicative f => a -> f a
pure (Project
project, Path Abs File
dest)
               else do
                   forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder
"Writing implicit global project config file to: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString String
dest')
                   forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Note: You can change the snapshot via the resolver field there."
                   Project
p <- Maybe RawSnapshotLocation
-> [PackageIdentifierRevision] -> RIO Config Project
getEmptyProject Maybe RawSnapshotLocation
mresolver []
                   forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                       forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
dest forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S.concat
                           [ ByteString
"# This is the implicit global project's config file, which is only used when\n"
                           , ByteString
"# 'stack' is run outside of a real project. Settings here do _not_ act as\n"
                           , ByteString
"# defaults for all projects. To change Stack's default settings, edit\n"
                           , ByteString
"# '", Text -> ByteString
encodeUtf8 (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> String
toFilePath forall a b. (a -> b) -> a -> b
$ Config -> Path Abs File
configUserConfigPath Config
config), ByteString
"' instead.\n"
                           , ByteString
"#\n"
                           , ByteString
"# For more information about Stack's configuration, see\n"
                           , ByteString
"# http://docs.haskellstack.org/en/stable/yaml_configuration/\n"
                           , ByteString
"#\n"
                           , forall a. ToJSON a => a -> ByteString
Yaml.encode Project
p]
                       forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic (forall b t. Path b t -> Path b Dir
parent Path Abs File
dest forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileReadmeTxt) forall a b. (a -> b) -> a -> b
$
                           Builder
"This is the implicit global project, which is " forall a. Semigroup a => a -> a -> a
<>
                           Builder
"used only when 'stack' is run\noutside of a " forall a. Semigroup a => a -> a -> a
<>
                           Builder
"real project.\n"
                   forall (f :: * -> *) a. Applicative f => a -> f a
pure (Project
p, Path Abs File
dest)
    Maybe WantedCompiler
mcompiler <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasRunner env => Lens' env GlobalOpts
globalOptsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to GlobalOpts -> Maybe WantedCompiler
globalCompiler
    let project :: Project
project = Project
project'
            { projectCompiler :: Maybe WantedCompiler
projectCompiler = Maybe WantedCompiler
mcompiler forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Project -> Maybe WantedCompiler
projectCompiler Project
project'
            , projectResolver :: RawSnapshotLocation
projectResolver = forall a. a -> Maybe a -> a
fromMaybe (Project -> RawSnapshotLocation
projectResolver Project
project') Maybe RawSnapshotLocation
mresolver
            }
    [Path Abs Dir]
extraPackageDBs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' (Project -> [String]
projectExtraPackageDBs Project
project)

    SMWanted
wanted <- forall env.
(HasPantryConfig env, HasRunner env) =>
Path Abs File
-> RawSnapshotLocation
-> (Map RawPackageLocationImmutable PackageLocationImmutable
    -> WantedCompiler
    -> Map PackageName (Bool -> RIO env DepPackage)
    -> RIO env (SMWanted, [CompletedPLI]))
-> RIO env SMWanted
lockCachedWanted Path Abs File
stackYamlFP (Project -> RawSnapshotLocation
projectResolver Project
project) forall a b. (a -> b) -> a -> b
$
        forall env t.
(HasProcessContext env, HasLogFunc env, HasPantryConfig env) =>
Path Abs t
-> Config
-> Project
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO env DepPackage)
-> RIO env (SMWanted, [CompletedPLI])
fillProjectWanted Path Abs File
stackYamlFP Config
config Project
project

    -- Unfortunately redoes getProjectWorkDir, since we don't have a BuildConfig yet

    Path Rel Dir
workDir <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env (Path Rel Dir)
workDirL
    let projectStorageFile :: Path Abs File
projectStorageFile = forall b t. Path b t -> Path b Dir
parent Path Abs File
stackYamlFP forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
workDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileStorage

    forall env a.
HasLogFunc env =>
Path Abs File -> (ProjectStorage -> RIO env a) -> RIO env a
initProjectStorage Path Abs File
projectStorageFile forall a b. (a -> b) -> a -> b
$ \ProjectStorage
projectStorage -> do
      let bc :: BuildConfig
bc = BuildConfig
            { bcConfig :: Config
bcConfig = Config
config
            , bcSMWanted :: SMWanted
bcSMWanted = SMWanted
wanted
            , bcExtraPackageDBs :: [Path Abs Dir]
bcExtraPackageDBs = [Path Abs Dir]
extraPackageDBs
            , bcStackYaml :: Path Abs File
bcStackYaml = Path Abs File
stackYamlFP
            , bcCurator :: Maybe Curator
bcCurator = Project -> Maybe Curator
projectCurator Project
project
            , bcProjectStorage :: ProjectStorage
bcProjectStorage = ProjectStorage
projectStorage
            }
      forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO BuildConfig
bc RIO BuildConfig a
inner
  where
    getEmptyProject :: Maybe RawSnapshotLocation -> [PackageIdentifierRevision] -> RIO Config Project
    getEmptyProject :: Maybe RawSnapshotLocation
-> [PackageIdentifierRevision] -> RIO Config Project
getEmptyProject Maybe RawSnapshotLocation
mresolver [PackageIdentifierRevision]
extraDeps = do
      RawSnapshotLocation
r <- case Maybe RawSnapshotLocation
mresolver of
            Just RawSnapshotLocation
resolver -> do
                forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder
"Using resolver: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
resolver forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" specified on command line")
                forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshotLocation
resolver
            Maybe RawSnapshotLocation
Nothing -> do
                RawSnapshotLocation
r'' <- forall env. HasConfig env => RIO env RawSnapshotLocation
getLatestResolver
                forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder
"Using latest snapshot resolver: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
r'')
                forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshotLocation
r''
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Project
        { projectUserMsg :: Maybe String
projectUserMsg = forall a. Maybe a
Nothing
        , projectPackages :: [RelFilePath]
projectPackages = []
        , projectDependencies :: [RawPackageLocation]
projectDependencies = forall a b. (a -> b) -> [a] -> [b]
map (RawPackageLocationImmutable -> RawPackageLocation
RPLImmutable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip PackageIdentifierRevision
-> Maybe TreeKey -> RawPackageLocationImmutable
RPLIHackage forall a. Maybe a
Nothing) [PackageIdentifierRevision]
extraDeps
        , projectFlags :: Map PackageName (Map FlagName Bool)
projectFlags = forall a. Monoid a => a
mempty
        , projectResolver :: RawSnapshotLocation
projectResolver = RawSnapshotLocation
r
        , projectCompiler :: Maybe WantedCompiler
projectCompiler = forall a. Maybe a
Nothing
        , projectExtraPackageDBs :: [String]
projectExtraPackageDBs = []
        , projectCurator :: Maybe Curator
projectCurator = forall a. Maybe a
Nothing
        , projectDropPackages :: Set PackageName
projectDropPackages = forall a. Monoid a => a
mempty
        }

fillProjectWanted ::
       (HasProcessContext env, HasLogFunc env, HasPantryConfig env)
    => Path Abs t
    -> Config
    -> Project
    -> Map RawPackageLocationImmutable PackageLocationImmutable
    -> WantedCompiler
    -> Map PackageName (Bool -> RIO env DepPackage)
    -> RIO env (SMWanted, [CompletedPLI])
fillProjectWanted :: forall env t.
(HasProcessContext env, HasLogFunc env, HasPantryConfig env) =>
Path Abs t
-> Config
-> Project
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO env DepPackage)
-> RIO env (SMWanted, [CompletedPLI])
fillProjectWanted Path Abs t
stackYamlFP Config
config Project
project Map RawPackageLocationImmutable PackageLocationImmutable
locCache WantedCompiler
snapCompiler Map PackageName (Bool -> RIO env DepPackage)
snapPackages = do
    let bopts :: BuildOpts
bopts = Config -> BuildOpts
configBuild Config
config

    [(PackageName, ProjectPackage)]
packages0 <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Project -> [RelFilePath]
projectPackages Project
project) forall a b. (a -> b) -> a -> b
$ \fp :: RelFilePath
fp@(RelFilePath Text
t) -> do
      Path Abs Dir
abs' <- forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Path Abs Dir)
resolveDir (forall b t. Path b t -> Path b Dir
parent Path Abs t
stackYamlFP) (Text -> String
T.unpack Text
t)
      let resolved :: ResolvedPath Dir
resolved = forall t. RelFilePath -> Path Abs t -> ResolvedPath t
ResolvedPath RelFilePath
fp Path Abs Dir
abs'
      ProjectPackage
pp <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PrintWarnings -> ResolvedPath Dir -> Bool -> RIO env ProjectPackage
mkProjectPackage PrintWarnings
YesPrintWarnings ResolvedPath Dir
resolved (BuildOpts -> Bool
boptsHaddock BuildOpts
bopts)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommonPackage -> PackageName
cpName forall a b. (a -> b) -> a -> b
$ ProjectPackage -> CommonPackage
ppCommon ProjectPackage
pp, ProjectPackage
pp)

    -- prefetch git repos to avoid cloning per subdirectory

    -- see https://github.com/commercialhaskell/stack/issues/5411

    let gitRepos :: [(Repo, RawPackageMetadata)]
gitRepos = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case
                              (RPLImmutable (RPLIRepo Repo
repo RawPackageMetadata
rpm)) -> forall a. a -> Maybe a
Just (Repo
repo, RawPackageMetadata
rpm)
                              RawPackageLocation
_ -> forall a. Maybe a
Nothing) (Project -> [RawPackageLocation]
projectDependencies Project
project)
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Prefetching git repos: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (String -> Text
T.pack (forall a. Show a => a -> String
show [(Repo, RawPackageMetadata)]
gitRepos)))
    forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[(Repo, RawPackageMetadata)] -> RIO env ()
fetchReposRaw [(Repo, RawPackageMetadata)]
gitRepos

    ([(PackageName, DepPackage)]
deps0, [Maybe CompletedPLI]
mcompleted) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Project -> [RawPackageLocation]
projectDependencies Project
project) forall a b. (a -> b) -> a -> b
$ \RawPackageLocation
rpl -> do
      (PackageLocation
pl, Maybe CompletedPLI
mCompleted) <- case RawPackageLocation
rpl of
         RPLImmutable RawPackageLocationImmutable
rpli -> do
           (PackageLocationImmutable
compl, Maybe PackageLocationImmutable
mcompl) <-
             case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RawPackageLocationImmutable
rpli Map RawPackageLocationImmutable PackageLocationImmutable
locCache of
               Just PackageLocationImmutable
compl -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageLocationImmutable
compl, forall a. a -> Maybe a
Just PackageLocationImmutable
compl)
               Maybe PackageLocationImmutable
Nothing -> do
                 CompletePackageLocation
cpl <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env CompletePackageLocation
completePackageLocation RawPackageLocationImmutable
rpli
                 if CompletePackageLocation -> Bool
cplHasCabalFile CompletePackageLocation
cpl
                   then forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompletePackageLocation -> PackageLocationImmutable
cplComplete CompletePackageLocation
cpl, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ CompletePackageLocation -> PackageLocationImmutable
cplComplete CompletePackageLocation
cpl)
                   else do
                     forall env.
HasLogFunc env =>
RawPackageLocationImmutable -> RIO env ()
warnMissingCabalFile RawPackageLocationImmutable
rpli
                     forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompletePackageLocation -> PackageLocationImmutable
cplComplete CompletePackageLocation
cpl, forall a. Maybe a
Nothing)
           forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageLocationImmutable -> PackageLocation
PLImmutable PackageLocationImmutable
compl, RawPackageLocationImmutable
-> PackageLocationImmutable -> CompletedPLI
CompletedPLI RawPackageLocationImmutable
rpli forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PackageLocationImmutable
mcompl)
         RPLMutable ResolvedPath Dir
p ->
           forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResolvedPath Dir -> PackageLocation
PLMutable ResolvedPath Dir
p, forall a. Maybe a
Nothing)
      DepPackage
dp <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool -> PackageLocation -> RIO env DepPackage
additionalDepPackage (BuildOpts -> Bool
shouldHaddockDeps BuildOpts
bopts) PackageLocation
pl
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ((CommonPackage -> PackageName
cpName forall a b. (a -> b) -> a -> b
$ DepPackage -> CommonPackage
dpCommon DepPackage
dp, DepPackage
dp), Maybe CompletedPLI
mCompleted)

    forall (m :: * -> *).
MonadThrow m =>
[(PackageName, PackageLocation)] -> m ()
checkDuplicateNames forall a b. (a -> b) -> a -> b
$
      forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (ResolvedPath Dir -> PackageLocation
PLMutable forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> ResolvedPath Dir
ppResolvedDir)) [(PackageName, ProjectPackage)]
packages0 forall a. [a] -> [a] -> [a]
++
      forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second DepPackage -> PackageLocation
dpLocation) [(PackageName, DepPackage)]
deps0

    let packages1 :: Map PackageName ProjectPackage
packages1 = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName, ProjectPackage)]
packages0
        snPackages :: Map PackageName (Bool -> RIO env DepPackage)
snPackages = Map PackageName (Bool -> RIO env DepPackage)
snapPackages
          forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map PackageName ProjectPackage
packages1
          forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName, DepPackage)]
deps0
          forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.withoutKeys` Project -> Set PackageName
projectDropPackages Project
project

    Map PackageName DepPackage
snDeps <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Map PackageName (Bool -> RIO env DepPackage)
snPackages forall a b. (a -> b) -> a -> b
$ \Bool -> RIO env DepPackage
getDep -> Bool -> RIO env DepPackage
getDep (BuildOpts -> Bool
shouldHaddockDeps BuildOpts
bopts)

    let deps1 :: Map PackageName DepPackage
deps1 = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName, DepPackage)]
deps0 forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map PackageName DepPackage
snDeps

    let mergeApply :: Map k c -> Map k b -> (k -> c -> b -> c) -> Map k c
mergeApply Map k c
m1 Map k b
m2 k -> c -> b -> c
f =
          forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
MS.merge forall (f :: * -> *) k x. Applicative f => WhenMissing f k x x
MS.preserveMissing forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
MS.dropMissing (forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
MS.zipWithMatched k -> c -> b -> c
f) Map k c
m1 Map k b
m2
        pFlags :: Map PackageName (Map FlagName Bool)
pFlags = Project -> Map PackageName (Map FlagName Bool)
projectFlags Project
project
        packages2 :: Map PackageName ProjectPackage
packages2 = forall {k} {c} {b}.
Ord k =>
Map k c -> Map k b -> (k -> c -> b -> c) -> Map k c
mergeApply Map PackageName ProjectPackage
packages1 Map PackageName (Map FlagName Bool)
pFlags forall a b. (a -> b) -> a -> b
$
          \PackageName
_ ProjectPackage
p Map FlagName Bool
flags -> ProjectPackage
p{ppCommon :: CommonPackage
ppCommon=(ProjectPackage -> CommonPackage
ppCommon ProjectPackage
p){cpFlags :: Map FlagName Bool
cpFlags=Map FlagName Bool
flags}}
        deps2 :: Map PackageName DepPackage
deps2 = forall {k} {c} {b}.
Ord k =>
Map k c -> Map k b -> (k -> c -> b -> c) -> Map k c
mergeApply Map PackageName DepPackage
deps1 Map PackageName (Map FlagName Bool)
pFlags forall a b. (a -> b) -> a -> b
$
          \PackageName
_ DepPackage
d Map FlagName Bool
flags -> DepPackage
d{dpCommon :: CommonPackage
dpCommon=(DepPackage -> CommonPackage
dpCommon DepPackage
d){cpFlags :: Map FlagName Bool
cpFlags=Map FlagName Bool
flags}}

    forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Map PackageName (Map FlagName Bool)
-> FlagSource
-> Map PackageName ProjectPackage
-> Map PackageName DepPackage
-> m ()
checkFlagsUsedThrowing Map PackageName (Map FlagName Bool)
pFlags FlagSource
FSStackYaml Map PackageName ProjectPackage
packages1 Map PackageName DepPackage
deps1

    let pkgGhcOptions :: Map PackageName [Text]
pkgGhcOptions = Config -> Map PackageName [Text]
configGhcOptionsByName Config
config
        deps :: Map PackageName DepPackage
deps = forall {k} {c} {b}.
Ord k =>
Map k c -> Map k b -> (k -> c -> b -> c) -> Map k c
mergeApply Map PackageName DepPackage
deps2 Map PackageName [Text]
pkgGhcOptions forall a b. (a -> b) -> a -> b
$
          \PackageName
_ DepPackage
d [Text]
options -> DepPackage
d{dpCommon :: CommonPackage
dpCommon=(DepPackage -> CommonPackage
dpCommon DepPackage
d){cpGhcOptions :: [Text]
cpGhcOptions=[Text]
options}}
        packages :: Map PackageName ProjectPackage
packages = forall {k} {c} {b}.
Ord k =>
Map k c -> Map k b -> (k -> c -> b -> c) -> Map k c
mergeApply Map PackageName ProjectPackage
packages2 Map PackageName [Text]
pkgGhcOptions forall a b. (a -> b) -> a -> b
$
          \PackageName
_ ProjectPackage
p [Text]
options -> ProjectPackage
p{ppCommon :: CommonPackage
ppCommon=(ProjectPackage -> CommonPackage
ppCommon ProjectPackage
p){cpGhcOptions :: [Text]
cpGhcOptions=[Text]
options}}
        unusedPkgGhcOptions :: Map PackageName [Text]
unusedPkgGhcOptions = Map PackageName [Text]
pkgGhcOptions forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` forall k a. Map k a -> Set k
Map.keysSet Map PackageName ProjectPackage
packages2
          forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` forall k a. Map k a -> Set k
Map.keysSet Map PackageName DepPackage
deps2

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall k a. Map k a -> Bool
Map.null Map PackageName [Text]
unusedPkgGhcOptions) forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ [PackageName] -> BuildException
InvalidGhcOptionsSpecification (forall k a. Map k a -> [k]
Map.keys Map PackageName [Text]
unusedPkgGhcOptions)

    let wanted :: SMWanted
wanted = SMWanted
          { smwCompiler :: WantedCompiler
smwCompiler = forall a. a -> Maybe a -> a
fromMaybe WantedCompiler
snapCompiler (Project -> Maybe WantedCompiler
projectCompiler Project
project)
          , smwProject :: Map PackageName ProjectPackage
smwProject = Map PackageName ProjectPackage
packages
          , smwDeps :: Map PackageName DepPackage
smwDeps = Map PackageName DepPackage
deps
          , smwSnapshotLocation :: RawSnapshotLocation
smwSnapshotLocation = Project -> RawSnapshotLocation
projectResolver Project
project
          }

    forall (f :: * -> *) a. Applicative f => a -> f a
pure (SMWanted
wanted, forall a. [Maybe a] -> [a]
catMaybes [Maybe CompletedPLI]
mcompleted)


-- | Check if there are any duplicate package names and, if so, throw an

-- exception.

checkDuplicateNames :: MonadThrow m => [(PackageName, PackageLocation)] -> m ()
checkDuplicateNames :: forall (m :: * -> *).
MonadThrow m =>
[(PackageName, PackageLocation)] -> m ()
checkDuplicateNames [(PackageName, PackageLocation)]
locals =
    case forall a. (a -> Bool) -> [a] -> [a]
filter forall {a} {a}. (a, [a]) -> Bool
hasMultiples forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall (f :: * -> *) a. Applicative f => a -> f a
pure) [(PackageName, PackageLocation)]
locals of
        [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        [(PackageName, [PackageLocation])]
x -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ [(PackageName, [PackageLocation])] -> ConfigException
DuplicateLocalPackageNames [(PackageName, [PackageLocation])]
x
  where
    hasMultiples :: (a, [a]) -> Bool
hasMultiples (a
_, a
_:a
_:[a]
_) = Bool
True
    hasMultiples (a, [a])
_ = Bool
False


-- | Get the Stack root, e.g. @~/.stack@, and determine whether the user owns it.

--

-- On Windows, the second value is always 'True'.

determineStackRootAndOwnership
    :: (MonadIO m)
    => ConfigMonoid
    -- ^ Parsed command-line arguments

    -> m (Path Abs Dir, Path Abs Dir, Bool)
determineStackRootAndOwnership :: forall (m :: * -> *).
MonadIO m =>
ConfigMonoid -> m (Path Abs Dir, Path Abs Dir, Bool)
determineStackRootAndOwnership ConfigMonoid
clArgs = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    (Path Abs Dir
configRoot, Path Abs Dir
stackRoot) <- do
        case forall a. First a -> Maybe a
getFirst (ConfigMonoid -> First (Path Abs Dir)
configMonoidStackRoot ConfigMonoid
clArgs) of
            Just Path Abs Dir
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir
x, Path Abs Dir
x)
            Maybe (Path Abs Dir)
Nothing -> do
                Maybe String
mstackRoot <- String -> IO (Maybe String)
lookupEnv String
stackRootEnvVar
                case Maybe String
mstackRoot of
                    Maybe String
Nothing -> do
                      String
wantXdg <- forall a. a -> Maybe a -> a
fromMaybe String
"" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
stackXdgEnvVar
                      if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
wantXdg)
                        then do
                          Path Rel Dir
xdgRelDir <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir String
stackProgName
                          (,)
                            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadIO m =>
XdgDirectory -> Maybe (Path Rel Dir) -> m (Path Abs Dir)
getXdgDir XdgDirectory
XdgConfig (forall a. a -> Maybe a
Just Path Rel Dir
xdgRelDir)
                            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *).
MonadIO m =>
XdgDirectory -> Maybe (Path Rel Dir) -> m (Path Abs Dir)
getXdgDir XdgDirectory
XdgData (forall a. a -> Maybe a
Just Path Rel Dir
xdgRelDir)
                        else do
                          Path Abs Dir
oldStyleRoot <- forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
getAppUserDataDir String
stackProgName
                          forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir
oldStyleRoot, Path Abs Dir
oldStyleRoot)
                    Just String
x -> case forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir String
x of
                        Maybe (Path Abs Dir)
Nothing ->
                            forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ String -> String -> ParseAbsolutePathException
ParseAbsolutePathException String
stackRootEnvVar String
x
                        Just Path Abs Dir
parsed -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir
parsed, Path Abs Dir
parsed)

    (Path Abs Dir
existingStackRootOrParentDir, Bool
userOwnsIt) <- do
        Maybe (Path Abs Dir, Bool)
mdirAndOwnership <- forall (m :: * -> *) a.
MonadIO m =>
(Path Abs Dir -> m (Maybe a)) -> Path Abs Dir -> m (Maybe a)
findInParents forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> m (Maybe (Path Abs Dir, Bool))
getDirAndOwnership Path Abs Dir
stackRoot
        case Maybe (Path Abs Dir, Bool)
mdirAndOwnership of
            Just (Path Abs Dir, Bool)
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir, Bool)
x
            Maybe (Path Abs Dir, Bool)
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Path Abs Dir -> ConfigException
BadStackRoot Path Abs Dir
stackRoot)

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Path Abs Dir
existingStackRootOrParentDir forall a. Eq a => a -> a -> Bool
/= Path Abs Dir
stackRoot) forall a b. (a -> b) -> a -> b
$
        if Bool
userOwnsIt
            then forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
stackRoot
            else forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$
                Path Abs Dir -> Path Abs Dir -> ConfigException
Won'tCreateStackRootInDirectoryOwnedByDifferentUser
                    Path Abs Dir
stackRoot
                    Path Abs Dir
existingStackRootOrParentDir

    Path Abs Dir
configRoot' <- forall path (m :: * -> *).
(AnyPath path, MonadIO m) =>
path -> m (AbsPath path)
canonicalizePath Path Abs Dir
configRoot
    Path Abs Dir
stackRoot' <- forall path (m :: * -> *).
(AnyPath path, MonadIO m) =>
path -> m (AbsPath path)
canonicalizePath Path Abs Dir
stackRoot
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir
configRoot', Path Abs Dir
stackRoot', Bool
userOwnsIt)

-- | @'checkOwnership' dir@ throws 'UserDoesn'tOwnDirectory' if @dir@

-- isn't owned by the current user.

--

-- If @dir@ doesn't exist, its parent directory is checked instead.

-- If the parent directory doesn't exist either, @'NoSuchDirectory' ('parent' dir)@

-- is thrown.

checkOwnership :: (MonadIO m) => Path Abs Dir -> m ()
checkOwnership :: forall (m :: * -> *). MonadIO m => Path Abs Dir -> m ()
checkOwnership Path Abs Dir
dir = do
    Maybe (Path Abs Dir, Bool)
mdirAndOwnership <- forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m (Maybe b)
firstJustM forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> m (Maybe (Path Abs Dir, Bool))
getDirAndOwnership [Path Abs Dir
dir, forall b t. Path b t -> Path b Dir
parent Path Abs Dir
dir]
    case Maybe (Path Abs Dir, Bool)
mdirAndOwnership of
        Just (Path Abs Dir
_, Bool
True) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just (Path Abs Dir
dir', Bool
False) -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Path Abs Dir -> ConfigException
UserDoesn'tOwnDirectory Path Abs Dir
dir')
        Maybe (Path Abs Dir, Bool)
Nothing ->
            (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ConfigException
NoSuchDirectory) forall a b. (a -> b) -> a -> b
$ (forall loc. Path loc Dir -> String
toFilePathNoTrailingSep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> Path b Dir
parent) Path Abs Dir
dir

-- | @'getDirAndOwnership' dir@ returns @'Just' (dir, 'True')@ when @dir@

-- exists and the current user owns it in the sense of 'isOwnedByUser'.

getDirAndOwnership ::
       (MonadIO m)
    => Path Abs Dir
    -> m (Maybe (Path Abs Dir, Bool))
getDirAndOwnership :: forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> m (Maybe (Path Abs Dir, Bool))
getDirAndOwnership Path Abs Dir
dir = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
m a -> m (Maybe a)
forgivingAbsence forall a b. (a -> b) -> a -> b
$ do
    Bool
ownership <- forall (m :: * -> *) t. MonadIO m => Path Abs t -> m Bool
isOwnedByUser Path Abs Dir
dir
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir
dir, Bool
ownership)

-- | Check whether the current user (determined with 'getEffectiveUserId') is

-- the owner for the given path.

--

-- Will always pure 'True' on Windows.

isOwnedByUser :: MonadIO m => Path Abs t -> m Bool
isOwnedByUser :: forall (m :: * -> *) t. MonadIO m => Path Abs t -> m Bool
isOwnedByUser Path Abs t
path = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    if Bool
osIsWindows
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        else do
            FileStatus
fileStatus <- String -> IO FileStatus
getFileStatus (forall b t. Path b t -> String
toFilePath Path Abs t
path)
            UserID
user <- IO UserID
getEffectiveUserID
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (UserID
user forall a. Eq a => a -> a -> Bool
== FileStatus -> UserID
fileOwner FileStatus
fileStatus)

-- | 'True' if we are currently running inside a Docker container.

getInContainer :: (MonadIO m) => m Bool
getInContainer :: forall (m :: * -> *). MonadIO m => m Bool
getInContainer = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
inContainerEnvVar)

-- | 'True' if we are currently running inside a Nix.

getInNixShell :: (MonadIO m) => m Bool
getInNixShell :: forall (m :: * -> *). MonadIO m => m Bool
getInNixShell = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
inNixShellEnvVar)

-- | Determine the extra config file locations which exist.

--

-- Returns most local first

getExtraConfigs :: HasLogFunc env
                => Path Abs File -- ^ use config path

                -> RIO env [Path Abs File]
getExtraConfigs :: forall env.
HasLogFunc env =>
Path Abs File -> RIO env [Path Abs File]
getExtraConfigs Path Abs File
userConfigPath = do
  Maybe (Path Abs File)
defaultStackGlobalConfigPath <- forall env. HasLogFunc env => RIO env (Maybe (Path Abs File))
getDefaultGlobalConfigPath
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    [(String, String)]
env <- IO [(String, String)]
getEnvironment
    Maybe (Path Abs File)
mstackConfig <-
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile)
      forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"STACK_CONFIG" [(String, String)]
env
    Maybe (Path Abs File)
mstackGlobalConfig <-
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile)
      forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"STACK_GLOBAL_CONFIG" [(String, String)]
env
    forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist
        forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Path Abs File
userConfigPath Maybe (Path Abs File)
mstackConfig
        forall a. a -> [a] -> [a]
: forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Path Abs File)
mstackGlobalConfig forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Path Abs File)
defaultStackGlobalConfigPath)

-- | Load and parse YAML from the given config file. Throws

-- 'ParseConfigFileException' when there's a decoding error.

loadConfigYaml ::
       HasLogFunc env
    => (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> RIO env a
loadConfigYaml :: forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env a
loadConfigYaml Value -> Parser (WithJSONWarnings a)
parser Path Abs File
path = do
    Either ParseException a
eres <- forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env (Either ParseException a)
loadYaml Value -> Parser (WithJSONWarnings a)
parser Path Abs File
path
    case Either ParseException a
eres of
        Left ParseException
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException (Path Abs File -> ParseException -> ConfigPrettyException
ParseConfigFileException Path Abs File
path ParseException
err)
        Right a
res -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res

-- | Load and parse YAML from the given file.

loadYaml ::
       HasLogFunc env
    => (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> RIO env (Either Yaml.ParseException a)
loadYaml :: forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env (Either ParseException a)
loadYaml Value -> Parser (WithJSONWarnings a)
parser Path Abs File
path = do
    Either ParseException Value
eres <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => String -> IO (Either ParseException a)
Yaml.decodeFileEither (forall b t. Path b t -> String
toFilePath Path Abs File
path)
    case Either ParseException Value
eres  of
        Left ParseException
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left ParseException
err)
        Right Value
val ->
            case forall a b. (a -> Parser b) -> a -> Either String b
Yaml.parseEither Value -> Parser (WithJSONWarnings a)
parser Value
val of
                Left String
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left (String -> ParseException
Yaml.AesonException String
err))
                Right (WithJSONWarnings a
res [JSONWarning]
warnings) -> do
                    forall env (m :: * -> *).
(MonadReader env m, HasLogFunc env, HasCallStack, MonadIO m) =>
String -> [JSONWarning] -> m ()
logJSONWarnings (forall b t. Path b t -> String
toFilePath Path Abs File
path) [JSONWarning]
warnings
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right a
res)

-- | Get the location of the project config file, if it exists.

getProjectConfig :: HasLogFunc env
                 => StackYamlLoc
                 -- ^ Override stack.yaml

                 -> RIO env (ProjectConfig (Path Abs File))
getProjectConfig :: forall env.
HasLogFunc env =>
StackYamlLoc -> RIO env (ProjectConfig (Path Abs File))
getProjectConfig (SYLOverride Path Abs File
stackYaml) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> ProjectConfig a
PCProject Path Abs File
stackYaml
getProjectConfig StackYamlLoc
SYLGlobalProject = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. ProjectConfig a
PCGlobalProject
getProjectConfig StackYamlLoc
SYLDefault = do
    [(String, String)]
env <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(String, String)]
getEnvironment
    case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"STACK_YAML" [(String, String)]
env of
        Just String
fp -> do
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Getting project config file from STACK_YAML environment"
            forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. a -> ProjectConfig a
PCProject forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => String -> m (Path Abs File)
resolveFile' String
fp
        Maybe String
Nothing -> do
            Path Abs Dir
currDir <- forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. ProjectConfig a
PCGlobalProject forall a. a -> ProjectConfig a
PCProject forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
MonadIO m =>
(Path Abs Dir -> m (Maybe a)) -> Path Abs Dir -> m (Maybe a)
findInParents forall {m :: * -> *} {env} {b}.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
Path b Dir -> m (Maybe (Path b File))
getStackDotYaml Path Abs Dir
currDir
  where
    getStackDotYaml :: Path b Dir -> m (Maybe (Path b File))
getStackDotYaml Path b Dir
dir = do
        let fp :: Path b File
fp = Path b Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
stackDotYaml
            fp' :: String
fp' = forall b t. Path b t -> String
toFilePath Path b File
fp
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Checking for project config at: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString String
fp'
        Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path b File
fp
        if Bool
exists
            then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Path b File
fp
            else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
getProjectConfig (SYLNoProject [PackageIdentifierRevision]
extraDeps) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [PackageIdentifierRevision] -> ProjectConfig a
PCNoProject [PackageIdentifierRevision]
extraDeps

-- | Find the project config file location, respecting environment variables

-- and otherwise traversing parents. If no config is found, we supply a default

-- based on current directory.

loadProjectConfig :: HasLogFunc env
                  => StackYamlLoc
                  -- ^ Override stack.yaml

                  -> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid))
loadProjectConfig :: forall env.
HasLogFunc env =>
StackYamlLoc
-> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid))
loadProjectConfig StackYamlLoc
mstackYaml = do
    ProjectConfig (Path Abs File)
mfp <- forall env.
HasLogFunc env =>
StackYamlLoc -> RIO env (ProjectConfig (Path Abs File))
getProjectConfig StackYamlLoc
mstackYaml
    case ProjectConfig (Path Abs File)
mfp of
        PCProject Path Abs File
fp -> do
            Path Abs Dir
currDir <- forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Loading project config file " forall a. Semigroup a => a -> a -> a
<>
                        forall a. IsString a => String -> a
fromString (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall b t. Path b t -> String
toFilePath Path Abs File
fp) forall b t. Path b t -> String
toFilePath (forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix Path Abs Dir
currDir Path Abs File
fp))
            forall a. a -> ProjectConfig a
PCProject forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {env}.
HasLogFunc env =>
Path Abs File -> RIO env (Project, Path Abs File, ConfigMonoid)
load Path Abs File
fp
        ProjectConfig (Path Abs File)
PCGlobalProject -> do
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"No project config file found, using defaults."
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. ProjectConfig a
PCGlobalProject
        PCNoProject [PackageIdentifierRevision]
extraDeps -> do
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Ignoring config files"
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [PackageIdentifierRevision] -> ProjectConfig a
PCNoProject [PackageIdentifierRevision]
extraDeps
  where
    load :: Path Abs File -> RIO env (Project, Path Abs File, ConfigMonoid)
load Path Abs File
fp = do
        IO ProjectAndConfigMonoid
iopc <- forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env a
loadConfigYaml (Path Abs Dir
-> Value -> Parser (WithJSONWarnings (IO ProjectAndConfigMonoid))
parseProjectAndConfigMonoid (forall b t. Path b t -> Path b Dir
parent Path Abs File
fp)) Path Abs File
fp
        ProjectAndConfigMonoid Project
project ConfigMonoid
config <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ProjectAndConfigMonoid
iopc
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Project
project, Path Abs File
fp, ConfigMonoid
config)

-- | Get the location of the default Stack configuration file.

-- If a file already exists at the deprecated location, its location is returned.

-- Otherwise, the new location is returned.

getDefaultGlobalConfigPath ::
       HasLogFunc env
    => RIO env (Maybe (Path Abs File))
getDefaultGlobalConfigPath :: forall env. HasLogFunc env => RIO env (Maybe (Path Abs File))
getDefaultGlobalConfigPath =
    case (Maybe (Path Abs File)
defaultGlobalConfigPath, Maybe (Path Abs File)
defaultGlobalConfigPathDeprecated) of
        (Just Path Abs File
new,Just Path Abs File
old) ->
            forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst ) forall a b. (a -> b) -> a -> b
$
            forall env a.
HasLogFunc env =>
Maybe Text
-> (Path Abs a -> RIO env Bool)
-> Path Abs a
-> Path Abs a
-> RIO env (Path Abs a, Bool)
tryDeprecatedPath
                (forall a. a -> Maybe a
Just Text
"non-project global configuration file")
                forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist
                Path Abs File
new
                Path Abs File
old
        (Just Path Abs File
new,Maybe (Path Abs File)
Nothing) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Path Abs File
new)
        (Maybe (Path Abs File), Maybe (Path Abs File))
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

-- | Get the location of the default user configuration file.

-- If a file already exists at the deprecated location, its location is returned.

-- Otherwise, the new location is returned.

getDefaultUserConfigPath ::
       HasLogFunc env
    => Path Abs Dir -> RIO env (Path Abs File)
getDefaultUserConfigPath :: forall env.
HasLogFunc env =>
Path Abs Dir -> RIO env (Path Abs File)
getDefaultUserConfigPath Path Abs Dir
stackRoot = do
    (Path Abs File
path, Bool
exists) <- forall env a.
HasLogFunc env =>
Maybe Text
-> (Path Abs a -> RIO env Bool)
-> Path Abs a
-> Path Abs a
-> RIO env (Path Abs a, Bool)
tryDeprecatedPath
        (forall a. a -> Maybe a
Just Text
"non-project configuration file")
        forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist
        (Path Abs Dir -> Path Abs File
defaultUserConfigPath Path Abs Dir
stackRoot)
        (Path Abs Dir -> Path Abs File
defaultUserConfigPathDeprecated Path Abs Dir
stackRoot)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (forall b t. Path b t -> Path b Dir
parent Path Abs File
path)
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
path forall s. (IsString s, Semigroup s) => s
defaultConfigYaml
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
path

packagesParser :: Parser [String]
packagesParser :: Parser [String]
packagesParser = forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall s. IsString s => Mod OptionFields s -> Parser s
strOption
                   (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"package" forall a. Semigroup a => a -> a -> a
<>
                     forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"PACKAGE" forall a. Semigroup a => a -> a -> a
<>
                     forall (f :: * -> *) a. String -> Mod f a
help String
"Add a package (can be specified multiple times)"))

defaultConfigYaml :: (IsString s, Semigroup s) => s
defaultConfigYaml :: forall s. (IsString s, Semigroup s) => s
defaultConfigYaml =
  s
"# This file contains default non-project-specific settings for Stack, used\n" forall a. Semigroup a => a -> a -> a
<>
  s
"# in all projects. For more information about Stack's configuration, see\n" forall a. Semigroup a => a -> a -> a
<>
  s
"# http://docs.haskellstack.org/en/stable/yaml_configuration/\n" forall a. Semigroup a => a -> a -> a
<>
  s
"\n" forall a. Semigroup a => a -> a -> a
<>
  s
"# The following parameters are used by 'stack new' to automatically fill fields\n" forall a. Semigroup a => a -> a -> a
<>
  s
"# in the Cabal file. We recommend uncommenting them and filling them out if\n" forall a. Semigroup a => a -> a -> a
<>
  s
"# you intend to use 'stack new'.\n" forall a. Semigroup a => a -> a -> a
<>
  s
"# See https://docs.haskellstack.org/en/stable/yaml_configuration/#templates\n" forall a. Semigroup a => a -> a -> a
<>
  s
"templates:\n" forall a. Semigroup a => a -> a -> a
<>
  s
"  params:\n" forall a. Semigroup a => a -> a -> a
<>
  s
"#    author-name:\n" forall a. Semigroup a => a -> a -> a
<>
  s
"#    author-email:\n" forall a. Semigroup a => a -> a -> a
<>
  s
"#    copyright:\n" forall a. Semigroup a => a -> a -> a
<>
  s
"#    github-username:\n" forall a. Semigroup a => a -> a -> a
<>
  s
"\n" forall a. Semigroup a => a -> a -> a
<>
  s
"# The following parameter specifies Stack's output styles; STYLES is a\n" forall a. Semigroup a => a -> a -> a
<>
  s
"# colon-delimited sequence of key=value, where 'key' is a style name and\n" forall a. Semigroup a => a -> a -> a
<>
  s
"# 'value' is a semicolon-delimited list of 'ANSI' SGR (Select Graphic\n" forall a. Semigroup a => a -> a -> a
<>
  s
"# Rendition) control codes (in decimal). Use 'stack ls stack-colors --basic'\n" forall a. Semigroup a => a -> a -> a
<>
  s
"# to see the current sequence.\n" forall a. Semigroup a => a -> a -> a
<>
  s
"# stack-colors: STYLES\n"