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

-- | The general Stack configuration that starts everything off. This should
-- be smart to falback 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           Stack.Prelude
import           Pantry.Internal.AesonExtended
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 (OS (..), Platform (..), buildPlatform, Arch(OtherArch))
import qualified Distribution.Text
import           Distribution.Version (simplifyVersionRange, mkVersion')
import           GHC.Conc (getNumProcessors)
import           Lens.Micro ((.~))
import           Network.HTTP.StackClient (httpJSON, parseUrlThrow, getResponseBody)
import           Options.Applicative (Parser, help, long, metavar, strOption)
import           Path
import           Path.Extra (toFilePathNoTrailingSep)
import           Path.Find (findInParents)
import           Path.IO
import qualified Paths_stack as Meta
import           Stack.Config.Build
import           Stack.Config.Docker
import           Stack.Config.Nix
import           Stack.Constants
import           Stack.Build.Haddock (shouldHaddockDeps)
import           Stack.Lock (lockCachedWanted)
import           Stack.Storage.Project (initProjectStorage)
import           Stack.Storage.User (initUserStorage)
import           Stack.SourceMap
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
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)
import           RIO.List (unzip)
import           RIO.PrettyPrint (Style (Highlight, Secondary),
                   logLevelToStyle, stylesUpdateL, useColorL)
import           RIO.PrettyPrint.StylesUpdate (StylesUpdate (..))
import           RIO.PrettyPrint.DefaultStyles (defaultStyles)
import           RIO.Process
import           RIO.Time (toGregorian)

-- | 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 :: 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 (Path Abs a, Bool) -> RIO env (Path Abs a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (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 -> () -> RIO env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        Just Text
desc ->
                            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                                Utf8Builder
"Warning: Location of " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
desc Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" at '" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                                String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs a -> String
forall b t. Path b t -> String
toFilePath Path Abs a
old) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                                Utf8Builder
"' is deprecated; rename it to '" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                                String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs a -> String
forall b t. Path b t -> String
toFilePath Path Abs a
new) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                                Utf8Builder
"' instead"
                    (Path Abs a, Bool) -> RIO env (Path Abs a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Path Abs a
old, Bool
True)
                else (Path Abs a, Bool) -> RIO env (Path Abs a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (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 :: Config -> RIO env (Path Abs Dir)
getImplicitGlobalProjectDir Config
config =
    --TEST no warning printed
    ((Path Abs Dir, Bool) -> Path Abs Dir)
-> RIO env (Path Abs Dir, Bool) -> RIO env (Path Abs Dir)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Path Abs Dir, Bool) -> Path Abs Dir
forall a b. (a, b) -> a
fst (RIO env (Path Abs Dir, Bool) -> RIO env (Path Abs Dir))
-> RIO env (Path Abs Dir, Bool) -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Maybe Text
-> (Path Abs Dir -> RIO env Bool)
-> Path Abs Dir
-> Path Abs Dir
-> RIO env (Path Abs Dir, Bool)
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
forall a. Maybe a
Nothing
        Path Abs Dir -> RIO env Bool
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 = Getting (Path Abs Dir) Config (Path Abs Dir)
-> Config -> Path Abs Dir
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) Config (Path Abs Dir)
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 :: RIO env Snapshots
getSnapshots = do
    Text
latestUrlText <- RIO env Text
forall env (m :: * -> *).
(MonadReader env m, HasConfig env) =>
m Text
askLatestSnapshotUrl
    Request
latestUrl <- String -> RIO env Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (Text -> String
T.unpack Text
latestUrlText)
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Downloading snapshot versions file from " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
latestUrlText
    Response Snapshots
result <- Request -> RIO env (Response Snapshots)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON Request
latestUrl
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Done downloading and parsing snapshot versions file"
    Snapshots -> RIO env Snapshots
forall (m :: * -> *) a. Monad m => a -> m a
return (Snapshots -> RIO env Snapshots) -> Snapshots -> RIO env Snapshots
forall a b. (a -> b) -> a -> b
$ Response Snapshots -> Snapshots
forall a. Response a -> a
getResponseBody Response Snapshots
result

-- | Turn an 'AbstractResolver' into a 'Resolver'.
makeConcreteResolver
    :: HasConfig env
    => AbstractResolver
    -> RIO env RawSnapshotLocation
makeConcreteResolver :: AbstractResolver -> RIO env RawSnapshotLocation
makeConcreteResolver (ARResolver RawSnapshotLocation
r) = RawSnapshotLocation -> RIO env RawSnapshotLocation
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshotLocation
r
makeConcreteResolver AbstractResolver
ar = do
    RawSnapshotLocation
r <-
        case AbstractResolver
ar of
            ARResolver RawSnapshotLocation
r -> Bool -> RIO env RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a. HasCallStack => Bool -> a -> a
assert Bool
False (RIO env RawSnapshotLocation -> RIO env RawSnapshotLocation)
-> RIO env RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ AbstractResolver -> RIO env RawSnapshotLocation
forall env.
HasConfig env =>
AbstractResolver -> RIO env RawSnapshotLocation
makeConcreteResolver (RawSnapshotLocation -> AbstractResolver
ARResolver RawSnapshotLocation
r)
            AbstractResolver
ARGlobal -> do
                Config
config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
configL
                Path Abs Dir
implicitGlobalDir <- Config -> RIO env (Path Abs Dir)
forall env. HasLogFunc env => Config -> RIO env (Path Abs Dir)
getImplicitGlobalProjectDir Config
config
                let fp :: Path Abs File
fp = Path Abs Dir
implicitGlobalDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
stackDotYaml
                IO ProjectAndConfigMonoid
iopc <- (Value -> Parser (WithJSONWarnings (IO ProjectAndConfigMonoid)))
-> Path Abs File -> RIO env (IO ProjectAndConfigMonoid)
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 File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
fp)) Path Abs File
fp
                ProjectAndConfigMonoid Project
project ConfigMonoid
_ <- IO ProjectAndConfigMonoid -> RIO env ProjectAndConfigMonoid
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ProjectAndConfigMonoid
iopc
                RawSnapshotLocation -> RIO env RawSnapshotLocation
forall (m :: * -> *) a. Monad m => a -> m a
return (RawSnapshotLocation -> RIO env RawSnapshotLocation)
-> RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ Project -> RawSnapshotLocation
projectResolver Project
project
            AbstractResolver
ARLatestNightly -> SnapName -> RawSnapshotLocation
RSLSynonym (SnapName -> RawSnapshotLocation)
-> (Snapshots -> SnapName) -> Snapshots -> RawSnapshotLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> SnapName
Nightly (Day -> SnapName) -> (Snapshots -> Day) -> Snapshots -> SnapName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Snapshots -> Day
snapshotsNightly (Snapshots -> RawSnapshotLocation)
-> RIO env Snapshots -> RIO env RawSnapshotLocation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RIO env Snapshots
forall env. HasConfig env => RIO env Snapshots
getSnapshots
            ARLatestLTSMajor Int
x -> do
                Snapshots
snapshots <- RIO env Snapshots
forall env. HasConfig env => RIO env Snapshots
getSnapshots
                case Int -> IntMap Int -> Maybe Int
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
x (IntMap Int -> Maybe Int) -> IntMap Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Snapshots -> IntMap Int
snapshotsLts Snapshots
snapshots of
                    Maybe Int
Nothing -> String -> RIO env RawSnapshotLocation
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (String -> RIO env RawSnapshotLocation)
-> String -> RIO env RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ String
"No LTS release found with major version " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
x
                    Just Int
y -> RawSnapshotLocation -> RIO env RawSnapshotLocation
forall (m :: * -> *) a. Monad m => a -> m a
return (RawSnapshotLocation -> RIO env RawSnapshotLocation)
-> RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ SnapName -> RawSnapshotLocation
RSLSynonym (SnapName -> RawSnapshotLocation)
-> SnapName -> RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ Int -> Int -> SnapName
LTS Int
x Int
y
            AbstractResolver
ARLatestLTS -> do
                Snapshots
snapshots <- RIO env Snapshots
forall env. HasConfig env => RIO env Snapshots
getSnapshots
                if IntMap Int -> Bool
forall a. IntMap a -> Bool
IntMap.null (IntMap Int -> Bool) -> IntMap Int -> Bool
forall a b. (a -> b) -> a -> b
$ Snapshots -> IntMap Int
snapshotsLts Snapshots
snapshots
                   then String -> RIO env RawSnapshotLocation
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"No LTS releases found"
                   else let (Int
x, Int
y) = IntMap Int -> (Int, Int)
forall a. IntMap a -> (Int, a)
IntMap.findMax (IntMap Int -> (Int, Int)) -> IntMap Int -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ Snapshots -> IntMap Int
snapshotsLts Snapshots
snapshots
                        in RawSnapshotLocation -> RIO env RawSnapshotLocation
forall (m :: * -> *) a. Monad m => a -> m a
return (RawSnapshotLocation -> RIO env RawSnapshotLocation)
-> RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ SnapName -> RawSnapshotLocation
RSLSynonym (SnapName -> RawSnapshotLocation)
-> SnapName -> RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ Int -> Int -> SnapName
LTS Int
x Int
y
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Selected resolver: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
r
    RawSnapshotLocation -> RIO env RawSnapshotLocation
forall (m :: * -> *) a. Monad m => a -> m a
return RawSnapshotLocation
r

-- | Get the latest snapshot resolver available.
getLatestResolver :: HasConfig env => RIO env RawSnapshotLocation
getLatestResolver :: RIO env RawSnapshotLocation
getLatestResolver = do
    Snapshots
snapshots <- RIO env Snapshots
forall env. HasConfig env => RIO env Snapshots
getSnapshots
    let mlts :: Maybe SnapName
mlts = (Int -> Int -> SnapName) -> (Int, Int) -> SnapName
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> SnapName
LTS ((Int, Int) -> SnapName) -> Maybe (Int, Int) -> Maybe SnapName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
               [(Int, Int)] -> Maybe (Int, Int)
forall a. [a] -> Maybe a
listToMaybe ([(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a]
reverse (IntMap Int -> [(Int, Int)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList (Snapshots -> IntMap Int
snapshotsLts Snapshots
snapshots)))
    RawSnapshotLocation -> RIO env RawSnapshotLocation
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawSnapshotLocation -> RIO env RawSnapshotLocation)
-> RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ SnapName -> RawSnapshotLocation
RSLSynonym (SnapName -> RawSnapshotLocation)
-> SnapName -> RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ SnapName -> Maybe SnapName -> SnapName
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 :: 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]
[Path Abs Dir]
Map (Maybe PackageName) Bool
Map Text Text
First Bool
First Int
First String
First [HackageSecurityConfig]
First Text
First CasaRepoPrefix
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
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
configMonoidAllowNewer :: ConfigMonoid -> First Bool
configMonoidApplyGhcOptions :: ConfigMonoid -> First ApplyGhcOptions
configMonoidRebuildGhcOptions :: ConfigMonoid -> FirstFalse
configMonoidExplicitSetupDeps :: ConfigMonoid -> Map (Maybe PackageName) Bool
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)
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 [HackageSecurityConfig]
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
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
configMonoidAllowNewer :: First Bool
configMonoidApplyGhcOptions :: First ApplyGhcOptions
configMonoidRebuildGhcOptions :: FirstFalse
configMonoidExplicitSetupDeps :: Map (Maybe PackageName) Bool
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)
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 [HackageSecurityConfig]
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 <- IO (Maybe String) -> RIO env (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> RIO env (Maybe String))
-> IO (Maybe String) -> RIO env (Maybe String)
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 -> (Project, Path Abs File) -> Maybe (Project, Path Abs File)
forall a. a -> Maybe a
Just (Project, Path Abs File)
pair
             ProjectConfig (Project, Path Abs File)
PCGlobalProject -> Maybe (Project, Path Abs File)
forall a. Maybe a
Nothing
             PCNoProject [PackageIdentifierRevision]
_deps -> Maybe (Project, Path Abs File)
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 <- RIO env (Path Rel Dir)
-> (String -> RIO env (Path Rel Dir))
-> Maybe String
-> RIO env (Path Rel Dir)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Path Rel Dir -> RIO env (Path Rel Dir)
forall (m :: * -> *) a. Monad m => a -> m a
return Path Rel Dir
relDirStackWork) (IO (Path Rel Dir) -> RIO env (Path Rel Dir)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Path Rel Dir) -> RIO env (Path Rel Dir))
-> (String -> IO (Path Rel Dir))
-> String
-> RIO env (Path Rel Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir) Maybe String
mstackWorkEnv
     let configWorkDir :: Path Rel Dir
configWorkDir = Path Rel Dir -> First (Path Rel Dir) -> Path Rel Dir
forall a. a -> First a -> a
fromFirst Path Rel Dir
configWorkDir0 First (Path Rel Dir)
configMonoidWorkDir
         configLatestSnapshot :: Text
configLatestSnapshot = Text -> First Text -> Text
forall a. a -> First a -> a
fromFirst
           Text
"https://s3.amazonaws.com/haddock.stackage.org/snapshots.json"
           First Text
configMonoidLatestSnapshot
         clConnectionCount :: Int
clConnectionCount = Int -> First Int -> Int
forall a. a -> First a -> a
fromFirst Int
8 First Int
configMonoidConnectionCount
         configHideTHLoading :: Bool
configHideTHLoading = FirstTrue -> Bool
fromFirstTrue FirstTrue
configMonoidHideTHLoading
         configPrefixTimestamps :: Bool
configPrefixTimestamps = Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst Bool
False First Bool
configMonoidPrefixTimestamps

         configGHCVariant :: Maybe GHCVariant
configGHCVariant = First GHCVariant -> Maybe GHCVariant
forall a. First a -> Maybe a
getFirst First GHCVariant
configMonoidGHCVariant
         configCompilerRepository :: CompilerRepository
configCompilerRepository = CompilerRepository
-> First CompilerRepository -> CompilerRepository
forall a. a -> First a -> a
fromFirst
            CompilerRepository
defaultCompilerRepository
            First CompilerRepository
configMonoidCompilerRepository
         configGHCBuild :: Maybe CompilerBuild
configGHCBuild = First CompilerBuild -> Maybe CompilerBuild
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
         configOverrideGccPath :: Maybe (Path Abs File)
configOverrideGccPath = First (Path Abs File) -> Maybe (Path Abs File)
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 = Arch -> Maybe Arch -> Arch
forall a. a -> Maybe a -> a
fromMaybe Arch
defArch
              (Maybe Arch -> Arch) -> Maybe Arch -> Arch
forall a b. (a -> b) -> a -> b
$ First String -> Maybe String
forall a. First a -> Maybe a
getFirst First String
configMonoidArch Maybe String -> (String -> Maybe Arch) -> Maybe Arch
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Arch
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 = VersionCheck -> First VersionCheck -> VersionCheck
forall a. a -> First a -> a
fromFirst VersionCheck
MatchMinor First VersionCheck
configMonoidCompilerCheck

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

     PlatformVariant
configPlatformVariant <- IO PlatformVariant -> RIO env PlatformVariant
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PlatformVariant -> RIO env PlatformVariant)
-> IO PlatformVariant -> RIO env PlatformVariant
forall a b. (a -> b) -> a -> b
$
         PlatformVariant
-> (String -> PlatformVariant) -> Maybe String -> PlatformVariant
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PlatformVariant
PlatformVariantNone String -> PlatformVariant
PlatformVariant (Maybe String -> PlatformVariant)
-> IO (Maybe String) -> IO 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 <-
         Maybe Project
-> Maybe AbstractResolver -> DockerOptsMonoid -> RIO env DockerOpts
forall (m :: * -> *).
MonadThrow m =>
Maybe Project
-> Maybe AbstractResolver -> DockerOptsMonoid -> m DockerOpts
dockerOptsFromMonoid (((Project, Path Abs File) -> Project)
-> Maybe (Project, Path Abs File) -> Maybe Project
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Project, Path Abs File) -> Project
forall a b. (a, b) -> a
fst Maybe (Project, Path Abs File)
mproject) Maybe AbstractResolver
configResolver DockerOptsMonoid
configMonoidDockerOpts
     NixOpts
configNix <- NixOptsMonoid -> OS -> RIO env NixOpts
forall env. HasRunner env => NixOptsMonoid -> OS -> RIO env NixOpts
nixOptsFromMonoid NixOptsMonoid
configMonoidNixOpts OS
os

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

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

     [(String, String)]
rawEnv <- IO [(String, String)] -> RIO env [(String, String)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(String, String)]
getEnvironment
     Map Text Text
pathsEnv <- (ProcessException -> RIO env (Map Text Text))
-> (Map Text Text -> RIO env (Map Text Text))
-> Either ProcessException (Map Text Text)
-> RIO env (Map Text Text)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ProcessException -> RIO env (Map Text Text)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM Map Text Text -> RIO env (Map Text Text)
forall (m :: * -> *) a. Monad m => a -> m a
return
               (Either ProcessException (Map Text Text)
 -> RIO env (Map Text Text))
-> Either ProcessException (Map Text Text)
-> RIO env (Map Text Text)
forall a b. (a -> b) -> a -> b
$ [String]
-> Map Text Text -> Either ProcessException (Map Text Text)
augmentPathMap ((Path Abs Dir -> String) -> [Path Abs Dir] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath [Path Abs Dir]
configMonoidExtraPath)
                                ([(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (((String, String) -> (Text, Text))
-> [(String, String)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text)
-> (String -> Text) -> (String, String) -> (Text, Text)
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 <- Map Text Text -> RIO env ProcessContext
forall (m :: * -> *).
MonadIO m =>
Map Text Text -> m ProcessContext
mkProcessContext Map Text Text
pathsEnv
     let configProcessContextSettings :: EnvSettings -> IO ProcessContext
configProcessContextSettings EnvSettings
_ = ProcessContext -> IO ProcessContext
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessContext
origEnv

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

     Path Abs Dir
configLocalBin <-
         case First String -> Maybe String
forall a. First a -> Maybe a
getFirst First String
configMonoidLocalBinPath of
             Maybe String
Nothing -> do
                 Path Abs Dir
localDir <- String -> RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
getAppUserDataDir String
"local"
                 Path Abs Dir -> RIO env (Path Abs Dir)
forall (m :: * -> *) a. Monad m => a -> m a
return (Path Abs Dir -> RIO env (Path Abs Dir))
-> Path Abs Dir -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
localDir Path Abs Dir -> Path Rel Dir -> Path Abs Dir
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 -> String -> RIO env (Path Abs Dir)
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) -> Path Abs Dir -> String -> RIO env (Path Abs Dir)
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Path Abs Dir)
resolveDir (Path Abs File -> Path Abs Dir
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.
                 RIO env (Path Abs Dir)
-> (SomeException -> RIO env (Path Abs Dir))
-> RIO env (Path Abs Dir)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny`
                 RIO env (Path Abs Dir) -> SomeException -> RIO env (Path Abs Dir)
forall a b. a -> b -> a
const (ConfigException -> RIO env (Path Abs Dir)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (String -> ConfigException
NoSuchDirectory String
userPath))

     Int
configJobs <-
        case First Int -> Maybe Int
forall a. First a -> Maybe a
getFirst First Int
configMonoidJobs of
            Maybe Int
Nothing -> IO Int -> RIO env Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumProcessors
            Just Int
i -> Int -> RIO env Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
i
     let configConcurrentTests :: Bool
configConcurrentTests = Bool -> First Bool -> Bool
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 = First SCM -> Maybe SCM
forall a. First a -> Maybe a
getFirst First SCM
configMonoidScmInit
         configCabalConfigOpts :: Map CabalConfigKey [Text]
configCabalConfigOpts = MonoidMap CabalConfigKey (Dual [Text]) -> Map CabalConfigKey [Text]
coerce MonoidMap CabalConfigKey (Dual [Text])
configMonoidCabalConfigOpts
         configGhcOptionsByName :: Map PackageName [Text]
configGhcOptionsByName = MonoidMap PackageName (Dual [Text]) -> Map PackageName [Text]
coerce MonoidMap PackageName (Dual [Text])
configMonoidGhcOptionsByName
         configGhcOptionsByCat :: Map ApplyGhcOptions [Text]
configGhcOptionsByCat = MonoidMap ApplyGhcOptions (Dual [Text])
-> Map ApplyGhcOptions [Text]
coerce MonoidMap ApplyGhcOptions (Dual [Text])
configMonoidGhcOptionsByCat
         configSetupInfoLocations :: [String]
configSetupInfoLocations = [String]
configMonoidSetupInfoLocations
         configSetupInfoInline :: SetupInfo
configSetupInfoInline = SetupInfo
configMonoidSetupInfoInline
         configPvpBounds :: PvpBounds
configPvpBounds = PvpBounds -> First PvpBounds -> PvpBounds
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
         configExplicitSetupDeps :: Map (Maybe PackageName) Bool
configExplicitSetupDeps = Map (Maybe PackageName) Bool
configMonoidExplicitSetupDeps
         configRebuildGhcOptions :: Bool
configRebuildGhcOptions = FirstFalse -> Bool
fromFirstFalse FirstFalse
configMonoidRebuildGhcOptions
         configApplyGhcOptions :: ApplyGhcOptions
configApplyGhcOptions = ApplyGhcOptions -> First ApplyGhcOptions -> ApplyGhcOptions
forall a. a -> First a -> a
fromFirst ApplyGhcOptions
AGOLocals First ApplyGhcOptions
configMonoidApplyGhcOptions
         configAllowNewer :: Bool
configAllowNewer = Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst Bool
False First Bool
configMonoidAllowNewer
         configDefaultTemplate :: Maybe TemplateName
configDefaultTemplate = First TemplateName -> Maybe TemplateName
forall a. First a -> Maybe a
getFirst First TemplateName
configMonoidDefaultTemplate
         configDumpLogs :: DumpLogs
configDumpLogs = DumpLogs -> First DumpLogs -> DumpLogs
forall a. a -> First a -> a
fromFirst DumpLogs
DumpWarningLogs First DumpLogs
configMonoidDumpLogs
         configSaveHackageCreds :: Bool
configSaveHackageCreds = Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst Bool
True First Bool
configMonoidSaveHackageCreds
         configHackageBaseUrl :: Text
configHackageBaseUrl = Text -> First Text -> Text
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

     Bool
configAllowDifferentUser <-
        case First Bool -> Maybe Bool
forall a. First a -> Maybe a
getFirst First Bool
configMonoidAllowDifferentUser of
            Just Bool
True -> Bool -> RIO env Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            Maybe Bool
_ -> RIO env Bool
forall (m :: * -> *). MonadIO m => m Bool
getInContainer

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

     Bool
useAnsi <- IO Bool -> RIO env Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RIO env Bool) -> IO Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (Maybe Bool -> Bool) -> IO (Maybe Bool) -> IO Bool
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' Runner -> Getting StylesUpdate Runner StylesUpdate -> StylesUpdate
forall s a. s -> Getting a s a -> a
^. Getting StylesUpdate Runner StylesUpdate
forall env. HasStylesUpdate env => Lens' env StylesUpdate
stylesUpdateL) StylesUpdate -> StylesUpdate -> StylesUpdate
forall a. Semigroup a => a -> a -> a
<>
           StylesUpdate
configMonoidStyles
         useColor' :: Bool
useColor' = Runner -> Bool
runnerUseColor Runner
configRunner'
         mUseColor :: Maybe Bool
mUseColor = do
            ColorWhen
colorWhen <- First ColorWhen -> Maybe ColorWhen
forall a. First a -> Maybe a
getFirst First ColorWhen
configMonoidColorWhen
            Bool -> Maybe Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool) -> Bool -> Maybe Bool
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'' = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
useColor' Maybe Bool
mUseColor
         configRunner'' :: Runner
configRunner'' = Runner
configRunner'
               Runner -> (Runner -> Runner) -> Runner
forall a b. a -> (a -> b) -> b
& (ProcessContext -> Identity ProcessContext)
-> Runner -> Identity Runner
forall env. HasProcessContext env => Lens' env ProcessContext
processContextL ((ProcessContext -> Identity ProcessContext)
 -> Runner -> Identity Runner)
-> ProcessContext -> Runner -> Runner
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ProcessContext
origEnv
               Runner -> (Runner -> Runner) -> Runner
forall a b. a -> (a -> b) -> b
& (StylesUpdate -> Identity StylesUpdate)
-> Runner -> Identity Runner
forall env. HasStylesUpdate env => Lens' env StylesUpdate
stylesUpdateL ((StylesUpdate -> Identity StylesUpdate)
 -> Runner -> Identity Runner)
-> StylesUpdate -> Runner -> Runner
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StylesUpdate
stylesUpdate'
               Runner -> (Runner -> Runner) -> Runner
forall a b. a -> (a -> b) -> b
& (Bool -> Identity Bool) -> Runner -> Identity Runner
forall env. HasTerm env => Lens' env Bool
useColorL ((Bool -> Identity Bool) -> Runner -> Identity Runner)
-> Bool -> Runner -> Runner
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
useColor''
         go :: GlobalOpts
go = Runner -> GlobalOpts
runnerGlobalOpts Runner
configRunner'

     HackageSecurityConfig
hsc <-
       case First [HackageSecurityConfig] -> Maybe [HackageSecurityConfig]
forall a. First a -> Maybe a
getFirst First [HackageSecurityConfig]
configMonoidPackageIndices of
         Maybe [HackageSecurityConfig]
Nothing -> HackageSecurityConfig -> RIO env HackageSecurityConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure HackageSecurityConfig
defaultHackageSecurityConfig
         Just [HackageSecurityConfig
hsc] -> HackageSecurityConfig -> RIO env HackageSecurityConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure HackageSecurityConfig
hsc
         Just [HackageSecurityConfig]
x -> String -> RIO env HackageSecurityConfig
forall a. HasCallStack => String -> a
error (String -> RIO env HackageSecurityConfig)
-> String -> RIO env HackageSecurityConfig
forall a b. (a -> b) -> a -> b
$ String
"When overriding the default package index, you must provide exactly one value, received: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [HackageSecurityConfig] -> String
forall a. Show a => a -> String
show [HackageSecurityConfig]
x
     Maybe String
mpantryRoot <- IO (Maybe String) -> RIO env (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> RIO env (Maybe String))
-> IO (Maybe String) -> RIO env (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
"PANTRY_ROOT"
     Path Abs Dir
pantryRoot <-
       case Maybe String
mpantryRoot of
         Just String
dir ->
           case String -> Maybe (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir String
dir of
             Maybe (Path Abs Dir)
Nothing -> String -> RIO env (Path Abs Dir)
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (String -> RIO env (Path Abs Dir))
-> String -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ String
"Failed to parse PANTRY_ROOT environment variable (expected absolute directory): " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
dir
             Just Path Abs Dir
x -> Path Abs Dir -> RIO env (Path Abs Dir)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
x
         Maybe String
Nothing -> Path Abs Dir -> RIO env (Path Abs Dir)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir -> RIO env (Path Abs Dir))
-> Path Abs Dir -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
configStackRoot Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirPantry

     let snapLoc :: SnapName -> RawSnapshotLocation
snapLoc =
            case First Text -> Maybe Text
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 (Utf8Builder -> RawSnapshotLocation)
-> Utf8Builder -> RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ Utf8Builder
addr'
                            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/lts/" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
x
                            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
y Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".yaml"
                    customSnapshotLocation (Nightly Day
date) =
                        let (Integer
year, Int
month, Int
day) = Day -> (Integer, Int, Int)
toGregorian Day
date
                        in Utf8Builder -> RawSnapshotLocation
mkRSLUrl (Utf8Builder -> RawSnapshotLocation)
-> Utf8Builder -> RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ Utf8Builder
addr'
                            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/nightly/"
                            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Integer -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Integer
year
                            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
month
                            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
day Utf8Builder -> Utf8Builder -> Utf8Builder
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) Maybe BlobKey
forall a. Maybe a
Nothing
                    addr' :: Utf8Builder
addr' = Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Text -> Utf8Builder) -> Text -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/') Text
addr

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

     GlobalOpts
-> Bool -> StylesUpdate -> (LogFunc -> RIO env a) -> RIO env a
forall (m :: * -> *) a.
MonadUnliftIO m =>
GlobalOpts -> Bool -> StylesUpdate -> (LogFunc -> m a) -> m a
withNewLogFunc GlobalOpts
go Bool
useColor'' StylesUpdate
stylesUpdate' ((LogFunc -> RIO env a) -> RIO env a)
-> (LogFunc -> RIO env a) -> RIO env a
forall a b. (a -> b) -> a -> b
$ \LogFunc
logFunc -> do
       let configRunner :: Runner
configRunner = Runner
configRunner'' Runner -> (Runner -> Runner) -> Runner
forall a b. a -> (a -> b) -> b
& (LogFunc -> Identity LogFunc) -> Runner -> Identity Runner
forall env. HasLogFunc env => Lens' env LogFunc
logFuncL ((LogFunc -> Identity LogFunc) -> Runner -> Identity Runner)
-> LogFunc -> Runner -> Runner
forall s t a b. ASetter s t a b -> b -> s -> t
.~ LogFunc
logFunc
       LogFunc -> RIO env a -> RIO env a
forall env a. HasLogFunc env => LogFunc -> RIO env a -> RIO env a
withLocalLogFunc LogFunc
logFunc (RIO env a -> RIO env a) -> RIO env a -> RIO env a
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
-> HackageSecurityConfig
-> HpackExecutable
-> Int
-> CasaRepoPrefix
-> Int
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
forall env a.
HasLogFunc env =>
Path Abs Dir
-> HackageSecurityConfig
-> HpackExecutable
-> Int
-> CasaRepoPrefix
-> Int
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig
         Path Abs Dir
pantryRoot
         HackageSecurityConfig
hsc
         (HpackExecutable
-> (String -> HpackExecutable) -> Maybe String -> HpackExecutable
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HpackExecutable
HpackBundled String -> HpackExecutable
HpackCommand (Maybe String -> HpackExecutable)
-> Maybe String -> HpackExecutable
forall a b. (a -> b) -> a -> b
$ First String -> Maybe String
forall a. First a -> Maybe a
getFirst First String
configMonoidOverrideHpack)
         Int
clConnectionCount
         (CasaRepoPrefix -> First CasaRepoPrefix -> CasaRepoPrefix
forall a. a -> First a -> a
fromFirst CasaRepoPrefix
defaultCasaRepoPrefix First CasaRepoPrefix
configMonoidCasaRepoPrefix)
         Int
defaultCasaMaxPerRequest
         SnapName -> RawSnapshotLocation
snapLoc
         (\PantryConfig
configPantryConfig -> Path Abs File -> (UserStorage -> RIO env a) -> RIO env a
forall env a.
HasLogFunc env =>
Path Abs File -> (UserStorage -> RIO env a) -> RIO env a
initUserStorage
           (Path Abs Dir
configStackRoot Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileStorage)
           (\UserStorage
configUserStorage -> Config -> RIO env a
inner Config :: Path Rel Dir
-> Path Abs File
-> BuildOpts
-> DockerOpts
-> NixOpts
-> (EnvSettings -> IO ProcessContext)
-> Path Abs Dir
-> Path Abs Dir
-> Bool
-> Bool
-> Platform
-> PlatformVariant
-> Maybe GHCVariant
-> Maybe CompilerBuild
-> Text
-> Bool
-> Bool
-> Bool
-> Bool
-> VersionCheck
-> CompilerRepository
-> Path Abs Dir
-> VersionRange
-> Int
-> Maybe (Path Abs File)
-> [String]
-> [String]
-> Bool
-> Map Text Text
-> Maybe SCM
-> Map PackageName [Text]
-> Map ApplyGhcOptions [Text]
-> Map CabalConfigKey [Text]
-> [String]
-> SetupInfo
-> PvpBounds
-> Bool
-> Map (Maybe PackageName) Bool
-> Bool
-> ApplyGhcOptions
-> Bool
-> Maybe TemplateName
-> Bool
-> DumpLogs
-> ProjectConfig (Project, Path Abs File)
-> Bool
-> Bool
-> Text
-> Runner
-> PantryConfig
-> Path Abs Dir
-> Maybe AbstractResolver
-> UserStorage
-> Bool
-> Bool
-> Bool
-> Config
Config {Bool
Int
[String]
Maybe (Path Abs File)
Maybe CompilerBuild
Maybe AbstractResolver
Maybe TemplateName
Maybe GHCVariant
Maybe SCM
Platform
VersionRange
Map (Maybe PackageName) Bool
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
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
configAllowNewer :: Bool
configApplyGhcOptions :: ApplyGhcOptions
configRebuildGhcOptions :: Bool
configExplicitSetupDeps :: Map (Maybe PackageName) 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
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
configRecommendUpgrade :: Bool
configHideSourcePaths :: Bool
configHackageBaseUrl :: Text
configSaveHackageCreds :: Bool
configDumpLogs :: DumpLogs
configDefaultTemplate :: Maybe TemplateName
configAllowNewer :: Bool
configApplyGhcOptions :: ApplyGhcOptions
configRebuildGhcOptions :: Bool
configExplicitSetupDeps :: Map (Maybe PackageName) 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)
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 :: LogFunc -> RIO env a -> RIO env a
withLocalLogFunc LogFunc
logFunc = (env -> env) -> RIO env a -> RIO env a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter env env LogFunc LogFunc -> LogFunc -> env -> env
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter env env LogFunc LogFunc
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 :: GlobalOpts -> Bool -> StylesUpdate -> (LogFunc -> m a) -> m a
withNewLogFunc GlobalOpts
go Bool
useColor (StylesUpdate [(Style, StyleSpec)]
update) LogFunc -> m a
inner = do
  LogOptions
logOptions0 <- Handle -> Bool -> m LogOptions
forall (m :: * -> *). MonadIO m => Handle -> Bool -> m LogOptions
logOptionsHandle Handle
stderr Bool
False
  let logOptions :: LogOptions
logOptions
        = Bool -> LogOptions -> LogOptions
setLogUseColor Bool
useColor
        (LogOptions -> LogOptions) -> LogOptions -> LogOptions
forall a b. (a -> b) -> a -> b
$ (LogLevel -> Utf8Builder) -> LogOptions -> LogOptions
setLogLevelColors LogLevel -> Utf8Builder
logLevelColors
        (LogOptions -> LogOptions) -> LogOptions -> LogOptions
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> LogOptions -> LogOptions
setLogSecondaryColor Utf8Builder
secondaryColor
        (LogOptions -> LogOptions) -> LogOptions -> LogOptions
forall a b. (a -> b) -> a -> b
$ (Int -> Utf8Builder) -> LogOptions -> LogOptions
setLogAccentColors (Utf8Builder -> Int -> Utf8Builder
forall a b. a -> b -> a
const Utf8Builder
highlightColor)
        (LogOptions -> LogOptions) -> LogOptions -> LogOptions
forall a b. (a -> b) -> a -> b
$ Bool -> LogOptions -> LogOptions
setLogUseTime (GlobalOpts -> Bool
globalTimeInLog GlobalOpts
go)
        (LogOptions -> LogOptions) -> LogOptions -> LogOptions
forall a b. (a -> b) -> a -> b
$ LogLevel -> LogOptions -> LogOptions
setLogMinLevel (GlobalOpts -> LogLevel
globalLogLevel GlobalOpts
go)
        (LogOptions -> LogOptions) -> LogOptions -> LogOptions
forall a b. (a -> b) -> a -> b
$ Bool -> LogOptions -> LogOptions
setLogVerboseFormat (GlobalOpts -> LogLevel
globalLogLevel GlobalOpts
go LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
<= LogLevel
LevelDebug)
        (LogOptions -> LogOptions) -> LogOptions -> LogOptions
forall a b. (a -> b) -> a -> b
$ Bool -> LogOptions -> LogOptions
setLogTerminal (GlobalOpts -> Bool
globalTerminal GlobalOpts
go)
          LogOptions
logOptions0
  LogOptions -> (LogFunc -> m a) -> m a
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 Array Style StyleSpec
-> [(Style, StyleSpec)] -> Array Style StyleSpec
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 =
    String -> Utf8Builder
forall a. IsString a => String -> a
fromString (String -> Utf8Builder) -> String -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode ([SGR] -> String) -> [SGR] -> String
forall a b. (a -> b) -> a -> b
$ StyleSpec -> [SGR]
forall a b. (a, b) -> b
snd (StyleSpec -> [SGR]) -> StyleSpec -> [SGR]
forall a b. (a -> b) -> a -> b
$ Array Style StyleSpec
styles Array Style StyleSpec -> Style -> StyleSpec
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! LogLevel -> Style
logLevelToStyle LogLevel
level
  secondaryColor :: Utf8Builder
secondaryColor = String -> Utf8Builder
forall a. IsString a => String -> a
fromString (String -> Utf8Builder) -> String -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode ([SGR] -> String) -> [SGR] -> String
forall a b. (a -> b) -> a -> b
$ StyleSpec -> [SGR]
forall a b. (a, b) -> b
snd (StyleSpec -> [SGR]) -> StyleSpec -> [SGR]
forall a b. (a -> b) -> a -> b
$ Array Style StyleSpec
styles Array Style StyleSpec -> Style -> StyleSpec
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Style
Secondary
  highlightColor :: Utf8Builder
highlightColor = String -> Utf8Builder
forall a. IsString a => String -> a
fromString (String -> Utf8Builder) -> String -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode ([SGR] -> String) -> [SGR] -> String
forall a b. (a -> b) -> a -> b
$ StyleSpec -> [SGR]
forall a b. (a, b) -> b
snd (StyleSpec -> [SGR]) -> StyleSpec -> [SGR]
forall a b. (a -> b) -> a -> b
$ Array Style StyleSpec
styles Array Style StyleSpec -> Style -> StyleSpec
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 :: Path Abs Dir -> Platform -> ProcessContext -> m (Path Abs Dir)
getDefaultLocalProgramsBase Path Abs Dir
configStackRoot Platform
configPlatform ProcessContext
override =
  let
    defaultBase :: Path Abs Dir
defaultBase = Path Abs Dir
configStackRoot Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirPrograms
  in
    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 ->
        case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"LOCALAPPDATA" (Map Text Text -> Maybe Text) -> Map Text Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Getting (Map Text Text) ProcessContext (Map Text Text)
-> ProcessContext -> Map Text Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Map Text Text) ProcessContext (Map Text Text)
forall env.
HasProcessContext env =>
SimpleGetter env (Map Text Text)
envVarsL ProcessContext
override of
          Just Text
t ->
            case String -> Maybe (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir (String -> Maybe (Path Abs Dir)) -> String -> Maybe (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t of
              Maybe (Path Abs Dir)
Nothing -> StringException -> m (Path Abs Dir)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (StringException -> m (Path Abs Dir))
-> StringException -> m (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> StringException
String -> StringException
stringException (String
"Failed to parse LOCALAPPDATA environment variable (expected absolute directory): " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
t)
              Just Path Abs Dir
lad ->
                Path Abs Dir -> m (Path Abs Dir)
forall (m :: * -> *) a. Monad m => a -> m a
return (Path Abs Dir -> m (Path Abs Dir))
-> Path Abs Dir -> m (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
lad Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirUpperPrograms Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirStackProgName
          Maybe Text
Nothing -> Path Abs Dir -> m (Path Abs Dir)
forall (m :: * -> *) a. Monad m => a -> m a
return Path Abs Dir
defaultBase
      Platform
_ -> Path Abs Dir -> m (Path Abs Dir)
forall (m :: * -> *) a. Monad m => a -> m a
return Path Abs Dir
defaultBase

-- | Load the configuration, using current directory, environment variables,
-- and defaults as necessary.
loadConfig :: HasRunner env => (Config -> RIO env a) -> RIO env a
loadConfig :: (Config -> RIO env a) -> RIO env a
loadConfig Config -> RIO env a
inner = do
    StackYamlLoc
mstackYaml <- Getting StackYamlLoc env StackYamlLoc -> RIO env StackYamlLoc
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting StackYamlLoc env StackYamlLoc -> RIO env StackYamlLoc)
-> Getting StackYamlLoc env StackYamlLoc -> RIO env StackYamlLoc
forall a b. (a -> b) -> a -> b
$ (GlobalOpts -> Const StackYamlLoc GlobalOpts)
-> env -> Const StackYamlLoc env
forall env. HasRunner env => Lens' env GlobalOpts
globalOptsL((GlobalOpts -> Const StackYamlLoc GlobalOpts)
 -> env -> Const StackYamlLoc env)
-> ((StackYamlLoc -> Const StackYamlLoc StackYamlLoc)
    -> GlobalOpts -> Const StackYamlLoc GlobalOpts)
-> Getting StackYamlLoc env StackYamlLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(GlobalOpts -> StackYamlLoc)
-> SimpleGetter GlobalOpts StackYamlLoc
forall s a. (s -> a) -> SimpleGetter s a
to GlobalOpts -> StackYamlLoc
globalStackYaml
    ProjectConfig (Project, Path Abs File, ConfigMonoid)
mproject <- StackYamlLoc
-> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid))
forall env.
HasLogFunc env =>
StackYamlLoc
-> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid))
loadProjectConfig StackYamlLoc
mstackYaml
    Maybe AbstractResolver
mresolver <- Getting (Maybe AbstractResolver) env (Maybe AbstractResolver)
-> RIO env (Maybe AbstractResolver)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Maybe AbstractResolver) env (Maybe AbstractResolver)
 -> RIO env (Maybe AbstractResolver))
-> Getting (Maybe AbstractResolver) env (Maybe AbstractResolver)
-> RIO env (Maybe AbstractResolver)
forall a b. (a -> b) -> a -> b
$ (GlobalOpts -> Const (Maybe AbstractResolver) GlobalOpts)
-> env -> Const (Maybe AbstractResolver) env
forall env. HasRunner env => Lens' env GlobalOpts
globalOptsL((GlobalOpts -> Const (Maybe AbstractResolver) GlobalOpts)
 -> env -> Const (Maybe AbstractResolver) env)
-> ((Maybe AbstractResolver
     -> Const (Maybe AbstractResolver) (Maybe AbstractResolver))
    -> GlobalOpts -> Const (Maybe AbstractResolver) GlobalOpts)
-> Getting (Maybe AbstractResolver) env (Maybe AbstractResolver)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(GlobalOpts -> Maybe AbstractResolver)
-> SimpleGetter GlobalOpts (Maybe AbstractResolver)
forall s a. (s -> a) -> SimpleGetter s a
to GlobalOpts -> Maybe AbstractResolver
globalResolver
    ConfigMonoid
configArgs <- Getting ConfigMonoid env ConfigMonoid -> RIO env ConfigMonoid
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting ConfigMonoid env ConfigMonoid -> RIO env ConfigMonoid)
-> Getting ConfigMonoid env ConfigMonoid -> RIO env ConfigMonoid
forall a b. (a -> b) -> a -> b
$ (GlobalOpts -> Const ConfigMonoid GlobalOpts)
-> env -> Const ConfigMonoid env
forall env. HasRunner env => Lens' env GlobalOpts
globalOptsL((GlobalOpts -> Const ConfigMonoid GlobalOpts)
 -> env -> Const ConfigMonoid env)
-> ((ConfigMonoid -> Const ConfigMonoid ConfigMonoid)
    -> GlobalOpts -> Const ConfigMonoid GlobalOpts)
-> Getting ConfigMonoid env ConfigMonoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(GlobalOpts -> ConfigMonoid)
-> SimpleGetter GlobalOpts ConfigMonoid
forall s a. (s -> a) -> SimpleGetter s a
to GlobalOpts -> ConfigMonoid
globalConfigMonoid
    (Path Abs Dir
stackRoot, Bool
userOwnsStackRoot) <- ConfigMonoid -> RIO env (Path Abs Dir, Bool)
forall (m :: * -> *).
MonadIO m =>
ConfigMonoid -> m (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) -> ((Project, Path Abs File) -> ProjectConfig (Project, Path Abs File)
forall a. a -> ProjectConfig a
PCProject (Project
proj, Path Abs File
fp), (ConfigMonoid
cmConfigMonoid -> [ConfigMonoid] -> [ConfigMonoid]
forall a. a -> [a] -> [a]
:))
            ProjectConfig (Project, Path Abs File, ConfigMonoid)
PCGlobalProject -> (ProjectConfig (Project, Path Abs File)
forall a. ProjectConfig a
PCGlobalProject, [ConfigMonoid] -> [ConfigMonoid]
forall a. a -> a
id)
            PCNoProject [PackageIdentifierRevision]
deps -> ([PackageIdentifierRevision]
-> ProjectConfig (Project, Path Abs File)
forall a. [PackageIdentifierRevision] -> ProjectConfig a
PCNoProject [PackageIdentifierRevision]
deps, [ConfigMonoid] -> [ConfigMonoid]
forall a. a -> a
id)

    Path Abs File
userConfigPath <- Path Abs Dir -> RIO env (Path Abs File)
forall env.
HasLogFunc env =>
Path Abs Dir -> RIO env (Path Abs File)
getDefaultUserConfigPath Path Abs Dir
stackRoot
    [ConfigMonoid]
extraConfigs0 <- Path Abs File -> RIO env [Path Abs File]
forall env.
HasLogFunc env =>
Path Abs File -> RIO env [Path Abs File]
getExtraConfigs Path Abs File
userConfigPath RIO env [Path Abs File]
-> ([Path Abs File] -> RIO env [ConfigMonoid])
-> RIO env [ConfigMonoid]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        (Path Abs File -> RIO env ConfigMonoid)
-> [Path Abs File] -> RIO env [ConfigMonoid]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Path Abs File
file -> (Value -> Parser (WithJSONWarnings ConfigMonoid))
-> Path Abs File -> RIO env ConfigMonoid
forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env a
loadConfigYaml (Path Abs Dir -> Value -> Parser (WithJSONWarnings ConfigMonoid)
parseConfigMonoid (Path Abs File -> Path Abs Dir
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
          (ConfigMonoid -> ConfigMonoid) -> [ConfigMonoid] -> [ConfigMonoid]
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 =
          Path Abs Dir
-> Path Abs File
-> Maybe AbstractResolver
-> ProjectConfig (Project, Path Abs File)
-> ConfigMonoid
-> (Config -> RIO env a)
-> RIO env a
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'
            ([ConfigMonoid] -> ConfigMonoid
forall a. Monoid a => [a] -> a
mconcat ([ConfigMonoid] -> ConfigMonoid) -> [ConfigMonoid] -> ConfigMonoid
forall a b. (a -> b) -> a -> b
$ ConfigMonoid
configArgs ConfigMonoid -> [ConfigMonoid] -> [ConfigMonoid]
forall a. a -> [a] -> [a]
: [ConfigMonoid] -> [ConfigMonoid]
addConfigMonoid [ConfigMonoid]
extraConfigs)

    (Config -> RIO env a) -> RIO env a
withConfig ((Config -> RIO env a) -> RIO env a)
-> (Config -> RIO env a) -> RIO env a
forall a b. (a -> b) -> a -> b
$ \Config
config -> do
      Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Version -> Version
mkVersion' Version
Meta.version Version -> VersionRange -> Bool
`withinRange` Config -> VersionRange
configRequireStackVersion Config
config)
          (ConfigException -> RIO env ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (VersionRange -> ConfigException
BadStackVersionException (Config -> VersionRange
configRequireStackVersion Config
config)))
      Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Config -> Bool
configAllowDifferentUser Config
config) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
          Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
userOwnsStackRoot (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
              ConfigException -> RIO env ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Path Abs Dir -> ConfigException
UserDoesn'tOwnDirectory Path Abs Dir
stackRoot)
          Maybe (Path Abs Dir) -> (Path Abs Dir -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Config -> Maybe (Path Abs Dir)
configProjectRoot Config
config) ((Path Abs Dir -> RIO env ()) -> RIO env ())
-> (Path Abs Dir -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir ->
              Path Abs Dir -> RIO env ()
forall (m :: * -> *). MonadIO m => Path Abs Dir -> m ()
checkOwnership (Path Abs Dir
dir Path Abs Dir -> Path Rel Dir -> Path Abs 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 :: RIO BuildConfig a -> RIO Config a
withBuildConfig RIO BuildConfig a
inner = do
    Config
config <- RIO 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 <- Maybe AbstractResolver
-> (AbstractResolver -> RIO Config RawSnapshotLocation)
-> RIO Config (Maybe RawSnapshotLocation)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Config -> Maybe AbstractResolver
configResolver Config
config) ((AbstractResolver -> RIO Config RawSnapshotLocation)
 -> RIO Config (Maybe RawSnapshotLocation))
-> (AbstractResolver -> RIO Config RawSnapshotLocation)
-> RIO Config (Maybe RawSnapshotLocation)
forall a b. (a -> b) -> a -> b
$ \AbstractResolver
aresolver -> do
      Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Using resolver: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> AbstractResolver -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display AbstractResolver
aresolver Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" specified on command line")
      AbstractResolver -> RIO Config RawSnapshotLocation
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
          Maybe String -> (String -> RIO Config ()) -> RIO Config ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Project -> Maybe String
projectUserMsg Project
project) (Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO Config ())
-> (String -> Utf8Builder) -> String -> RIO Config ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Utf8Builder
forall a. IsString a => String -> a
fromString)
          (Project, Path Abs File) -> RIO Config (Project, Path Abs File)
forall (m :: * -> *) a. Monad m => a -> m a
return (Project
project, Path Abs File
fp)
      PCNoProject [PackageIdentifierRevision]
extraDeps -> do
          Project
p <-
            case Maybe RawSnapshotLocation
mresolver of
              Maybe RawSnapshotLocation
Nothing -> ConfigException -> RIO Config Project
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
          (Project, Path Abs File) -> RIO Config (Project, Path Abs File)
forall (m :: * -> *) a. Monad m => a -> m a
return (Project
p, Config -> Path Abs File
configUserConfigPath Config
config)
      ProjectConfig (Project, Path Abs File)
PCGlobalProject -> do
            Utf8Builder -> RIO Config ()
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 <- Config -> RIO Config (Path Abs Dir)
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 Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
stackDotYaml
                dest' :: FilePath
                dest' :: String
dest' = Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
dest
            Path Abs Dir -> RIO Config ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
destDir
            Bool
exists <- Path Abs File -> RIO Config Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
dest
            if Bool
exists
               then do
                   IO ProjectAndConfigMonoid
iopc <- (Value -> Parser (WithJSONWarnings (IO ProjectAndConfigMonoid)))
-> Path Abs File -> RIO Config (IO ProjectAndConfigMonoid)
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
_ <- IO ProjectAndConfigMonoid -> RIO Config ProjectAndConfigMonoid
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ProjectAndConfigMonoid
iopc
                   Bool -> RIO Config () -> RIO Config ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Getting Bool Config Bool -> Config -> Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool Config Bool
forall env. HasRunner env => Lens' env Bool
terminalL Config
config) (RIO Config () -> RIO Config ()) -> RIO Config () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$
                       case Config -> Maybe AbstractResolver
configResolver Config
config of
                           Maybe AbstractResolver
Nothing ->
                               Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO Config ()) -> Utf8Builder -> RIO Config ()
forall a b. (a -> b) -> a -> b
$
                                 Utf8Builder
"Using resolver: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                                 RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Project -> RawSnapshotLocation
projectResolver Project
project) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                                 Utf8Builder
" from implicit global project's config file: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                                 String -> Utf8Builder
forall a. IsString a => String -> a
fromString String
dest'
                           Just AbstractResolver
_ -> () -> RIO Config ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   (Project, Path Abs File) -> RIO Config (Project, Path Abs File)
forall (m :: * -> *) a. Monad m => a -> m a
return (Project
project, Path Abs File
dest)
               else do
                   Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder
"Writing implicit global project config file to: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString String
dest')
                   Utf8Builder -> RIO Config ()
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 []
                   IO () -> RIO Config ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO Config ()) -> IO () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ do
                       Path Abs File -> Builder -> IO ()
forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
dest (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString (ByteString -> Builder) -> ByteString -> Builder
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 (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> String) -> Path Abs File -> String
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"
                           , Project -> ByteString
forall a. ToJSON a => a -> ByteString
Yaml.encode Project
p]
                       Path Abs File -> Builder -> IO ()
forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
dest Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileReadmeTxt)
                           Builder
"This is the implicit global project, which is used only when 'stack' is run\n\
                           \outside of a real project.\n"
                   (Project, Path Abs File) -> RIO Config (Project, Path Abs File)
forall (m :: * -> *) a. Monad m => a -> m a
return (Project
p, Path Abs File
dest)
    Maybe WantedCompiler
mcompiler <- Getting (Maybe WantedCompiler) Config (Maybe WantedCompiler)
-> RIO Config (Maybe WantedCompiler)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Maybe WantedCompiler) Config (Maybe WantedCompiler)
 -> RIO Config (Maybe WantedCompiler))
-> Getting (Maybe WantedCompiler) Config (Maybe WantedCompiler)
-> RIO Config (Maybe WantedCompiler)
forall a b. (a -> b) -> a -> b
$ (GlobalOpts -> Const (Maybe WantedCompiler) GlobalOpts)
-> Config -> Const (Maybe WantedCompiler) Config
forall env. HasRunner env => Lens' env GlobalOpts
globalOptsL((GlobalOpts -> Const (Maybe WantedCompiler) GlobalOpts)
 -> Config -> Const (Maybe WantedCompiler) Config)
-> ((Maybe WantedCompiler
     -> Const (Maybe WantedCompiler) (Maybe WantedCompiler))
    -> GlobalOpts -> Const (Maybe WantedCompiler) GlobalOpts)
-> Getting (Maybe WantedCompiler) Config (Maybe WantedCompiler)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(GlobalOpts -> Maybe WantedCompiler)
-> SimpleGetter GlobalOpts (Maybe WantedCompiler)
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 Maybe WantedCompiler
-> Maybe WantedCompiler -> Maybe WantedCompiler
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Project -> Maybe WantedCompiler
projectCompiler Project
project'
            , projectResolver :: RawSnapshotLocation
projectResolver = RawSnapshotLocation
-> Maybe RawSnapshotLocation -> RawSnapshotLocation
forall a. a -> Maybe a -> a
fromMaybe (Project -> RawSnapshotLocation
projectResolver Project
project') Maybe RawSnapshotLocation
mresolver
            }
    [Path Abs Dir]
extraPackageDBs <- (String -> RIO Config (Path Abs Dir))
-> [String] -> RIO Config [Path Abs Dir]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> RIO Config (Path Abs Dir)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' (Project -> [String]
projectExtraPackageDBs Project
project)

    SMWanted
wanted <- Path Abs File
-> RawSnapshotLocation
-> (Map RawPackageLocationImmutable PackageLocationImmutable
    -> WantedCompiler
    -> Map PackageName (Bool -> RIO Config DepPackage)
    -> RIO Config (SMWanted, [CompletedPLI]))
-> RIO Config SMWanted
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) ((Map RawPackageLocationImmutable PackageLocationImmutable
  -> WantedCompiler
  -> Map PackageName (Bool -> RIO Config DepPackage)
  -> RIO Config (SMWanted, [CompletedPLI]))
 -> RIO Config SMWanted)
-> (Map RawPackageLocationImmutable PackageLocationImmutable
    -> WantedCompiler
    -> Map PackageName (Bool -> RIO Config DepPackage)
    -> RIO Config (SMWanted, [CompletedPLI]))
-> RIO Config SMWanted
forall a b. (a -> b) -> a -> b
$
        Path Abs File
-> Config
-> Project
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO Config DepPackage)
-> RIO Config (SMWanted, [CompletedPLI])
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 <- Getting (Path Rel Dir) Config (Path Rel Dir)
-> RIO Config (Path Rel Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Rel Dir) Config (Path Rel Dir)
forall env. HasConfig env => Lens' env (Path Rel Dir)
workDirL
    let projectStorageFile :: Path Abs File
projectStorageFile = Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
stackYamlFP Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
workDir Path Rel Dir -> Path Rel File -> Path Rel File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileStorage

    Path Abs File -> (ProjectStorage -> RIO Config a) -> RIO Config a
forall env a.
HasLogFunc env =>
Path Abs File -> (ProjectStorage -> RIO env a) -> RIO env a
initProjectStorage Path Abs File
projectStorageFile ((ProjectStorage -> RIO Config a) -> RIO Config a)
-> (ProjectStorage -> RIO Config a) -> RIO Config a
forall a b. (a -> b) -> a -> b
$ \ProjectStorage
projectStorage -> do
      let bc :: BuildConfig
bc = BuildConfig :: Config
-> SMWanted
-> [Path Abs Dir]
-> Path Abs File
-> ProjectStorage
-> Maybe Curator
-> BuildConfig
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
            }
      BuildConfig -> RIO BuildConfig a -> RIO Config a
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
                Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder
"Using resolver: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
resolver Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" specified on command line")
                RawSnapshotLocation -> RIO Config RawSnapshotLocation
forall (m :: * -> *) a. Monad m => a -> m a
return RawSnapshotLocation
resolver
            Maybe RawSnapshotLocation
Nothing -> do
                RawSnapshotLocation
r'' <- RIO Config RawSnapshotLocation
forall env. HasConfig env => RIO env RawSnapshotLocation
getLatestResolver
                Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder
"Using latest snapshot resolver: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
r'')
                RawSnapshotLocation -> RIO Config RawSnapshotLocation
forall (m :: * -> *) a. Monad m => a -> m a
return RawSnapshotLocation
r''
      Project -> RIO Config Project
forall (m :: * -> *) a. Monad m => a -> m a
return Project :: Maybe String
-> [RelFilePath]
-> [RawPackageLocation]
-> Map PackageName (Map FlagName Bool)
-> RawSnapshotLocation
-> Maybe WantedCompiler
-> [String]
-> Maybe Curator
-> Set PackageName
-> Project
Project
        { projectUserMsg :: Maybe String
projectUserMsg = Maybe String
forall a. Maybe a
Nothing
        , projectPackages :: [RelFilePath]
projectPackages = []
        , projectDependencies :: [RawPackageLocation]
projectDependencies = (PackageIdentifierRevision -> RawPackageLocation)
-> [PackageIdentifierRevision] -> [RawPackageLocation]
forall a b. (a -> b) -> [a] -> [b]
map (RawPackageLocationImmutable -> RawPackageLocation
RPLImmutable (RawPackageLocationImmutable -> RawPackageLocation)
-> (PackageIdentifierRevision -> RawPackageLocationImmutable)
-> PackageIdentifierRevision
-> RawPackageLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageIdentifierRevision
 -> Maybe TreeKey -> RawPackageLocationImmutable)
-> Maybe TreeKey
-> PackageIdentifierRevision
-> RawPackageLocationImmutable
forall a b c. (a -> b -> c) -> b -> a -> c
flip PackageIdentifierRevision
-> Maybe TreeKey -> RawPackageLocationImmutable
RPLIHackage Maybe TreeKey
forall a. Maybe a
Nothing) [PackageIdentifierRevision]
extraDeps
        , projectFlags :: Map PackageName (Map FlagName Bool)
projectFlags = Map PackageName (Map FlagName Bool)
forall a. Monoid a => a
mempty
        , projectResolver :: RawSnapshotLocation
projectResolver = RawSnapshotLocation
r
        , projectCompiler :: Maybe WantedCompiler
projectCompiler = Maybe WantedCompiler
forall a. Maybe a
Nothing
        , projectExtraPackageDBs :: [String]
projectExtraPackageDBs = []
        , projectCurator :: Maybe Curator
projectCurator = Maybe Curator
forall a. Maybe a
Nothing
        , projectDropPackages :: Set PackageName
projectDropPackages = Set PackageName
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 :: 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 <- [RelFilePath]
-> (RelFilePath -> RIO env (PackageName, ProjectPackage))
-> RIO env [(PackageName, ProjectPackage)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Project -> [RelFilePath]
projectPackages Project
project) ((RelFilePath -> RIO env (PackageName, ProjectPackage))
 -> RIO env [(PackageName, ProjectPackage)])
-> (RelFilePath -> RIO env (PackageName, ProjectPackage))
-> RIO env [(PackageName, ProjectPackage)]
forall a b. (a -> b) -> a -> b
$ \fp :: RelFilePath
fp@(RelFilePath Text
t) -> do
      Path Abs Dir
abs' <- Path Abs Dir -> String -> RIO env (Path Abs Dir)
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Path Abs Dir)
resolveDir (Path Abs t -> Path Abs Dir
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 = RelFilePath -> Path Abs Dir -> ResolvedPath Dir
forall t. RelFilePath -> Path Abs t -> ResolvedPath t
ResolvedPath RelFilePath
fp Path Abs Dir
abs'
      ProjectPackage
pp <- PrintWarnings -> ResolvedPath Dir -> Bool -> RIO env ProjectPackage
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)
      (PackageName, ProjectPackage)
-> RIO env (PackageName, ProjectPackage)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommonPackage -> PackageName
cpName (CommonPackage -> PackageName) -> CommonPackage -> PackageName
forall a b. (a -> b) -> a -> b
$ ProjectPackage -> CommonPackage
ppCommon ProjectPackage
pp, ProjectPackage
pp)

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

    [(PackageName, PackageLocation)] -> RIO env ()
forall (m :: * -> *).
MonadThrow m =>
[(PackageName, PackageLocation)] -> m ()
checkDuplicateNames ([(PackageName, PackageLocation)] -> RIO env ())
-> [(PackageName, PackageLocation)] -> RIO env ()
forall a b. (a -> b) -> a -> b
$
      ((PackageName, ProjectPackage) -> (PackageName, PackageLocation))
-> [(PackageName, ProjectPackage)]
-> [(PackageName, PackageLocation)]
forall a b. (a -> b) -> [a] -> [b]
map ((ProjectPackage -> PackageLocation)
-> (PackageName, ProjectPackage) -> (PackageName, PackageLocation)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (ResolvedPath Dir -> PackageLocation
PLMutable (ResolvedPath Dir -> PackageLocation)
-> (ProjectPackage -> ResolvedPath Dir)
-> ProjectPackage
-> PackageLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> ResolvedPath Dir
ppResolvedDir)) [(PackageName, ProjectPackage)]
packages0 [(PackageName, PackageLocation)]
-> [(PackageName, PackageLocation)]
-> [(PackageName, PackageLocation)]
forall a. [a] -> [a] -> [a]
++
      ((PackageName, DepPackage) -> (PackageName, PackageLocation))
-> [(PackageName, DepPackage)] -> [(PackageName, PackageLocation)]
forall a b. (a -> b) -> [a] -> [b]
map ((DepPackage -> PackageLocation)
-> (PackageName, DepPackage) -> (PackageName, PackageLocation)
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 = [(PackageName, ProjectPackage)] -> Map PackageName ProjectPackage
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
          Map PackageName (Bool -> RIO env DepPackage)
-> Map PackageName ProjectPackage
-> Map PackageName (Bool -> RIO env DepPackage)
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map PackageName ProjectPackage
packages1
          Map PackageName (Bool -> RIO env DepPackage)
-> Map PackageName DepPackage
-> Map PackageName (Bool -> RIO env DepPackage)
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` [(PackageName, DepPackage)] -> Map PackageName DepPackage
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName, DepPackage)]
deps0
          Map PackageName (Bool -> RIO env DepPackage)
-> Set PackageName -> Map PackageName (Bool -> RIO env DepPackage)
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 <- Map PackageName (Bool -> RIO env DepPackage)
-> ((Bool -> RIO env DepPackage) -> RIO env DepPackage)
-> RIO env (Map PackageName DepPackage)
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 (((Bool -> RIO env DepPackage) -> RIO env DepPackage)
 -> RIO env (Map PackageName DepPackage))
-> ((Bool -> RIO env DepPackage) -> RIO env DepPackage)
-> RIO env (Map PackageName DepPackage)
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 = [(PackageName, DepPackage)] -> Map PackageName DepPackage
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName, DepPackage)]
deps0 Map PackageName DepPackage
-> Map PackageName DepPackage -> Map PackageName DepPackage
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 =
          SimpleWhenMissing k c c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k c b c
-> Map k c
-> Map k b
-> Map k c
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 SimpleWhenMissing k c c
forall (f :: * -> *) k x. Applicative f => WhenMissing f k x x
MS.preserveMissing SimpleWhenMissing k b c
forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
MS.dropMissing ((k -> c -> b -> c) -> SimpleWhenMatched k c b c
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 = Map PackageName ProjectPackage
-> Map PackageName (Map FlagName Bool)
-> (PackageName
    -> ProjectPackage -> Map FlagName Bool -> ProjectPackage)
-> Map PackageName ProjectPackage
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 ((PackageName
  -> ProjectPackage -> Map FlagName Bool -> ProjectPackage)
 -> Map PackageName ProjectPackage)
-> (PackageName
    -> ProjectPackage -> Map FlagName Bool -> ProjectPackage)
-> Map PackageName ProjectPackage
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 = Map PackageName DepPackage
-> Map PackageName (Map FlagName Bool)
-> (PackageName -> DepPackage -> Map FlagName Bool -> DepPackage)
-> Map PackageName DepPackage
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 ((PackageName -> DepPackage -> Map FlagName Bool -> DepPackage)
 -> Map PackageName DepPackage)
-> (PackageName -> DepPackage -> Map FlagName Bool -> DepPackage)
-> Map PackageName DepPackage
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}}

    Map PackageName (Map FlagName Bool)
-> FlagSource
-> Map PackageName ProjectPackage
-> Map PackageName DepPackage
-> RIO env ()
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 = Map PackageName DepPackage
-> Map PackageName [Text]
-> (PackageName -> DepPackage -> [Text] -> DepPackage)
-> Map PackageName DepPackage
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 ((PackageName -> DepPackage -> [Text] -> DepPackage)
 -> Map PackageName DepPackage)
-> (PackageName -> DepPackage -> [Text] -> DepPackage)
-> Map PackageName DepPackage
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 = Map PackageName ProjectPackage
-> Map PackageName [Text]
-> (PackageName -> ProjectPackage -> [Text] -> ProjectPackage)
-> Map PackageName ProjectPackage
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 ((PackageName -> ProjectPackage -> [Text] -> ProjectPackage)
 -> Map PackageName ProjectPackage)
-> (PackageName -> ProjectPackage -> [Text] -> ProjectPackage)
-> Map PackageName ProjectPackage
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 Map PackageName [Text] -> Set PackageName -> Map PackageName [Text]
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Map PackageName ProjectPackage -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet Map PackageName ProjectPackage
packages2
          Map PackageName [Text] -> Set PackageName -> Map PackageName [Text]
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Map PackageName DepPackage -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet Map PackageName DepPackage
deps2

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

    let wanted :: SMWanted
wanted = SMWanted :: WantedCompiler
-> Map PackageName ProjectPackage
-> Map PackageName DepPackage
-> RawSnapshotLocation
-> SMWanted
SMWanted
          { smwCompiler :: WantedCompiler
smwCompiler = WantedCompiler -> Maybe WantedCompiler -> WantedCompiler
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
          }

    (SMWanted, [CompletedPLI]) -> RIO env (SMWanted, [CompletedPLI])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SMWanted
wanted, [Maybe CompletedPLI] -> [CompletedPLI]
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 :: [(PackageName, PackageLocation)] -> m ()
checkDuplicateNames [(PackageName, PackageLocation)]
locals =
    case ((PackageName, [PackageLocation]) -> Bool)
-> [(PackageName, [PackageLocation])]
-> [(PackageName, [PackageLocation])]
forall a. (a -> Bool) -> [a] -> [a]
filter (PackageName, [PackageLocation]) -> Bool
forall a a. (a, [a]) -> Bool
hasMultiples ([(PackageName, [PackageLocation])]
 -> [(PackageName, [PackageLocation])])
-> [(PackageName, [PackageLocation])]
-> [(PackageName, [PackageLocation])]
forall a b. (a -> b) -> a -> b
$ Map PackageName [PackageLocation]
-> [(PackageName, [PackageLocation])]
forall k a. Map k a -> [(k, a)]
Map.toList (Map PackageName [PackageLocation]
 -> [(PackageName, [PackageLocation])])
-> Map PackageName [PackageLocation]
-> [(PackageName, [PackageLocation])]
forall a b. (a -> b) -> a -> b
$ ([PackageLocation] -> [PackageLocation] -> [PackageLocation])
-> [(PackageName, [PackageLocation])]
-> Map PackageName [PackageLocation]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [PackageLocation] -> [PackageLocation] -> [PackageLocation]
forall a. [a] -> [a] -> [a]
(++) ([(PackageName, [PackageLocation])]
 -> Map PackageName [PackageLocation])
-> [(PackageName, [PackageLocation])]
-> Map PackageName [PackageLocation]
forall a b. (a -> b) -> a -> b
$ ((PackageName, PackageLocation)
 -> (PackageName, [PackageLocation]))
-> [(PackageName, PackageLocation)]
-> [(PackageName, [PackageLocation])]
forall a b. (a -> b) -> [a] -> [b]
map ((PackageLocation -> [PackageLocation])
-> (PackageName, PackageLocation)
-> (PackageName, [PackageLocation])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second PackageLocation -> [PackageLocation]
forall (m :: * -> *) a. Monad m => a -> m a
return) [(PackageName, PackageLocation)]
locals of
        [] -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        [(PackageName, [PackageLocation])]
x -> ConfigException -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ConfigException -> m ()) -> ConfigException -> m ()
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, Bool)
determineStackRootAndOwnership :: ConfigMonoid -> m (Path Abs Dir, Bool)
determineStackRootAndOwnership ConfigMonoid
clArgs = IO (Path Abs Dir, Bool) -> m (Path Abs Dir, Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Path Abs Dir, Bool) -> m (Path Abs Dir, Bool))
-> IO (Path Abs Dir, Bool) -> m (Path Abs Dir, Bool)
forall a b. (a -> b) -> a -> b
$ do
    Path Abs Dir
stackRoot <- do
        case First (Path Abs Dir) -> Maybe (Path Abs Dir)
forall a. First a -> Maybe a
getFirst (ConfigMonoid -> First (Path Abs Dir)
configMonoidStackRoot ConfigMonoid
clArgs) of
            Just Path Abs Dir
x -> Path Abs Dir -> IO (Path Abs Dir)
forall (m :: * -> *) a. Monad m => a -> m a
return 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 -> String -> IO (Path Abs Dir)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
getAppUserDataDir String
stackProgName
                    Just String
x -> case String -> Maybe (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir String
x of
                        Maybe (Path Abs Dir)
Nothing -> String -> IO (Path Abs Dir)
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (String
"Failed to parse STACK_ROOT environment variable (expected absolute directory): " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
x)
                        Just Path Abs Dir
parsed -> Path Abs Dir -> IO (Path Abs Dir)
forall (m :: * -> *) a. Monad m => a -> m a
return Path Abs Dir
parsed

    (Path Abs Dir
existingStackRootOrParentDir, Bool
userOwnsIt) <- do
        Maybe (Path Abs Dir, Bool)
mdirAndOwnership <- (Path Abs Dir -> IO (Maybe (Path Abs Dir, Bool)))
-> Path Abs Dir -> IO (Maybe (Path Abs Dir, Bool))
forall (m :: * -> *) a.
MonadIO m =>
(Path Abs Dir -> m (Maybe a)) -> Path Abs Dir -> m (Maybe a)
findInParents Path Abs Dir -> IO (Maybe (Path Abs Dir, Bool))
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 -> (Path Abs Dir, Bool) -> IO (Path Abs Dir, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Path Abs Dir, Bool)
x
            Maybe (Path Abs Dir, Bool)
Nothing -> ConfigException -> IO (Path Abs Dir, Bool)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Path Abs Dir -> ConfigException
BadStackRoot Path Abs Dir
stackRoot)

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Path Abs Dir
existingStackRootOrParentDir Path Abs Dir -> Path Abs Dir -> Bool
forall a. Eq a => a -> a -> Bool
/= Path Abs Dir
stackRoot) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        if Bool
userOwnsIt
            then Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
stackRoot
            else ConfigException -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (ConfigException -> IO ()) -> ConfigException -> IO ()
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
stackRoot' <- Path Abs Dir -> IO (AbsPath (Path Abs Dir))
forall path (m :: * -> *).
(AnyPath path, MonadIO m) =>
path -> m (AbsPath path)
canonicalizePath Path Abs Dir
stackRoot
    (Path Abs Dir, Bool) -> IO (Path Abs Dir, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (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 :: Path Abs Dir -> m ()
checkOwnership Path Abs Dir
dir = do
    Maybe (Path Abs Dir, Bool)
mdirAndOwnership <- (Path Abs Dir -> m (Maybe (Path Abs Dir, Bool)))
-> [Path Abs Dir] -> m (Maybe (Path Abs Dir, Bool))
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m (Maybe b)
firstJustM Path Abs Dir -> m (Maybe (Path Abs Dir, Bool))
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> m (Maybe (Path Abs Dir, Bool))
getDirAndOwnership [Path Abs Dir
dir, Path Abs Dir -> Path Abs 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) -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just (Path Abs Dir
dir', Bool
False) -> ConfigException -> m ()
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 ->
            (ConfigException -> m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (ConfigException -> m ())
-> (String -> ConfigException) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ConfigException
NoSuchDirectory) (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ (Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep (Path Abs Dir -> String)
-> (Path Abs Dir -> Path Abs Dir) -> Path Abs Dir -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> Path Abs Dir
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 :: Path Abs Dir -> m (Maybe (Path Abs Dir, Bool))
getDirAndOwnership Path Abs Dir
dir = IO (Maybe (Path Abs Dir, Bool)) -> m (Maybe (Path Abs Dir, Bool))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Path Abs Dir, Bool)) -> m (Maybe (Path Abs Dir, Bool)))
-> IO (Maybe (Path Abs Dir, Bool))
-> m (Maybe (Path Abs Dir, Bool))
forall a b. (a -> b) -> a -> b
$ IO (Path Abs Dir, Bool) -> IO (Maybe (Path Abs Dir, Bool))
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
m a -> m (Maybe a)
forgivingAbsence (IO (Path Abs Dir, Bool) -> IO (Maybe (Path Abs Dir, Bool)))
-> IO (Path Abs Dir, Bool) -> IO (Maybe (Path Abs Dir, Bool))
forall a b. (a -> b) -> a -> b
$ do
    Bool
ownership <- Path Abs Dir -> IO Bool
forall (m :: * -> *) t. MonadIO m => Path Abs t -> m Bool
isOwnedByUser Path Abs Dir
dir
    (Path Abs Dir, Bool) -> IO (Path Abs Dir, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Path Abs Dir
dir, Bool
ownership)

-- | Check whether the current user (determined with 'getEffectiveUserId') is
-- the owner for the given path.
--
-- Will always return 'True' on Windows.
isOwnedByUser :: MonadIO m => Path Abs t -> m Bool
isOwnedByUser :: Path Abs t -> m Bool
isOwnedByUser Path Abs t
path = IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
    if Bool
osIsWindows
        then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        else do
            FileStatus
fileStatus <- String -> IO FileStatus
getFileStatus (Path Abs t -> String
forall b t. Path b t -> String
toFilePath Path Abs t
path)
            UserID
user <- IO UserID
getEffectiveUserID
            Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (UserID
user UserID -> UserID -> Bool
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 :: m Bool
getInContainer = IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
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 :: m Bool
getInNixShell = IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
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 :: Path Abs File -> RIO env [Path Abs File]
getExtraConfigs Path Abs File
userConfigPath = do
  Maybe (Path Abs File)
defaultStackGlobalConfigPath <- RIO env (Maybe (Path Abs File))
forall env. HasLogFunc env => RIO env (Maybe (Path Abs File))
getDefaultGlobalConfigPath
  IO [Path Abs File] -> RIO env [Path Abs File]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Path Abs File] -> RIO env [Path Abs File])
-> IO [Path Abs File] -> RIO env [Path Abs File]
forall a b. (a -> b) -> a -> b
$ do
    [(String, String)]
env <- IO [(String, String)]
getEnvironment
    Maybe (Path Abs File)
mstackConfig <-
        IO (Maybe (Path Abs File))
-> (String -> IO (Maybe (Path Abs File)))
-> Maybe String
-> IO (Maybe (Path Abs File))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe (Path Abs File) -> IO (Maybe (Path Abs File))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Path Abs File)
forall a. Maybe a
Nothing) ((Path Abs File -> Maybe (Path Abs File))
-> IO (Path Abs File) -> IO (Maybe (Path Abs File))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just (IO (Path Abs File) -> IO (Maybe (Path Abs File)))
-> (String -> IO (Path Abs File))
-> String
-> IO (Maybe (Path Abs File))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Path Abs File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile)
      (Maybe String -> IO (Maybe (Path Abs File)))
-> Maybe String -> IO (Maybe (Path Abs File))
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"STACK_CONFIG" [(String, String)]
env
    Maybe (Path Abs File)
mstackGlobalConfig <-
        IO (Maybe (Path Abs File))
-> (String -> IO (Maybe (Path Abs File)))
-> Maybe String
-> IO (Maybe (Path Abs File))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe (Path Abs File) -> IO (Maybe (Path Abs File))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Path Abs File)
forall a. Maybe a
Nothing) ((Path Abs File -> Maybe (Path Abs File))
-> IO (Path Abs File) -> IO (Maybe (Path Abs File))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just (IO (Path Abs File) -> IO (Maybe (Path Abs File)))
-> (String -> IO (Path Abs File))
-> String
-> IO (Maybe (Path Abs File))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Path Abs File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile)
      (Maybe String -> IO (Maybe (Path Abs File)))
-> Maybe String -> IO (Maybe (Path Abs File))
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"STACK_GLOBAL_CONFIG" [(String, String)]
env
    (Path Abs File -> IO Bool) -> [Path Abs File] -> IO [Path Abs File]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Path Abs File -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist
        ([Path Abs File] -> IO [Path Abs File])
-> [Path Abs File] -> IO [Path Abs File]
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Maybe (Path Abs File) -> Path Abs File
forall a. a -> Maybe a -> a
fromMaybe Path Abs File
userConfigPath Maybe (Path Abs File)
mstackConfig
        Path Abs File -> [Path Abs File] -> [Path Abs File]
forall a. a -> [a] -> [a]
: [Path Abs File]
-> (Path Abs File -> [Path Abs File])
-> Maybe (Path Abs File)
-> [Path Abs File]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Path Abs File -> [Path Abs File]
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Path Abs File)
mstackGlobalConfig Maybe (Path Abs File)
-> Maybe (Path Abs File) -> Maybe (Path Abs File)
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 :: (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 <- (Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env (Either ParseException a)
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 -> IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> RIO env a) -> IO a -> RIO env a
forall a b. (a -> b) -> a -> b
$ ConfigException -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Path Abs File -> ParseException -> ConfigException
ParseConfigFileException Path Abs File
path ParseException
err)
        Right a
res -> a -> RIO env a
forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: (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 <- IO (Either ParseException Value)
-> RIO env (Either ParseException Value)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ParseException Value)
 -> RIO env (Either ParseException Value))
-> IO (Either ParseException Value)
-> RIO env (Either ParseException Value)
forall a b. (a -> b) -> a -> b
$ String -> IO (Either ParseException Value)
forall a. FromJSON a => String -> IO (Either ParseException a)
Yaml.decodeFileEither (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
path)
    case Either ParseException Value
eres  of
        Left ParseException
err -> Either ParseException a -> RIO env (Either ParseException a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseException -> Either ParseException a
forall a b. a -> Either a b
Left ParseException
err)
        Right Value
val ->
            case (Value -> Parser (WithJSONWarnings a))
-> Value -> Either String (WithJSONWarnings a)
forall a b. (a -> Parser b) -> a -> Either String b
Yaml.parseEither Value -> Parser (WithJSONWarnings a)
parser Value
val of
                Left String
err -> Either ParseException a -> RIO env (Either ParseException a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseException -> Either ParseException a
forall a b. a -> Either a b
Left (String -> ParseException
Yaml.AesonException String
err))
                Right (WithJSONWarnings a
res [JSONWarning]
warnings) -> do
                    String -> [JSONWarning] -> RIO env ()
forall env (m :: * -> *).
(MonadReader env m, HasLogFunc env, HasCallStack, MonadIO m) =>
String -> [JSONWarning] -> m ()
logJSONWarnings (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
path) [JSONWarning]
warnings
                    Either ParseException a -> RIO env (Either ParseException a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either ParseException a
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 :: StackYamlLoc -> RIO env (ProjectConfig (Path Abs File))
getProjectConfig (SYLOverride Path Abs File
stackYaml) = ProjectConfig (Path Abs File)
-> RIO env (ProjectConfig (Path Abs File))
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectConfig (Path Abs File)
 -> RIO env (ProjectConfig (Path Abs File)))
-> ProjectConfig (Path Abs File)
-> RIO env (ProjectConfig (Path Abs File))
forall a b. (a -> b) -> a -> b
$ Path Abs File -> ProjectConfig (Path Abs File)
forall a. a -> ProjectConfig a
PCProject Path Abs File
stackYaml
getProjectConfig StackYamlLoc
SYLGlobalProject = ProjectConfig (Path Abs File)
-> RIO env (ProjectConfig (Path Abs File))
forall (m :: * -> *) a. Monad m => a -> m a
return ProjectConfig (Path Abs File)
forall a. ProjectConfig a
PCGlobalProject
getProjectConfig StackYamlLoc
SYLDefault = do
    [(String, String)]
env <- IO [(String, String)] -> RIO env [(String, String)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(String, String)]
getEnvironment
    case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"STACK_YAML" [(String, String)]
env of
        Just String
fp -> do
            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Getting project config file from STACK_YAML environment"
            (Path Abs File -> ProjectConfig (Path Abs File))
-> RIO env (Path Abs File)
-> RIO env (ProjectConfig (Path Abs File))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Path Abs File -> ProjectConfig (Path Abs File)
forall a. a -> ProjectConfig a
PCProject (RIO env (Path Abs File)
 -> RIO env (ProjectConfig (Path Abs File)))
-> RIO env (Path Abs File)
-> RIO env (ProjectConfig (Path Abs File))
forall a b. (a -> b) -> a -> b
$ String -> RIO env (Path Abs File)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs File)
resolveFile' String
fp
        Maybe String
Nothing -> do
            Path Abs Dir
currDir <- RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
            ProjectConfig (Path Abs File)
-> (Path Abs File -> ProjectConfig (Path Abs File))
-> Maybe (Path Abs File)
-> ProjectConfig (Path Abs File)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ProjectConfig (Path Abs File)
forall a. ProjectConfig a
PCGlobalProject Path Abs File -> ProjectConfig (Path Abs File)
forall a. a -> ProjectConfig a
PCProject (Maybe (Path Abs File) -> ProjectConfig (Path Abs File))
-> RIO env (Maybe (Path Abs File))
-> RIO env (ProjectConfig (Path Abs File))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Path Abs Dir -> RIO env (Maybe (Path Abs File)))
-> Path Abs Dir -> RIO env (Maybe (Path Abs File))
forall (m :: * -> *) a.
MonadIO m =>
(Path Abs Dir -> m (Maybe a)) -> Path Abs Dir -> m (Maybe a)
findInParents Path Abs Dir -> RIO env (Maybe (Path Abs File))
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 Path b Dir -> Path Rel File -> Path b File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
stackDotYaml
            fp' :: String
fp' = Path b File -> String
forall b t. Path b t -> String
toFilePath Path b File
fp
        Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Checking for project config at: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString String
fp'
        Bool
exists <- Path b File -> m Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path b File
fp
        if Bool
exists
            then Maybe (Path b File) -> m (Maybe (Path b File))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Path b File) -> m (Maybe (Path b File)))
-> Maybe (Path b File) -> m (Maybe (Path b File))
forall a b. (a -> b) -> a -> b
$ Path b File -> Maybe (Path b File)
forall a. a -> Maybe a
Just Path b File
fp
            else Maybe (Path b File) -> m (Maybe (Path b File))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Path b File)
forall a. Maybe a
Nothing
getProjectConfig (SYLNoProject [PackageIdentifierRevision]
extraDeps) = ProjectConfig (Path Abs File)
-> RIO env (ProjectConfig (Path Abs File))
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectConfig (Path Abs File)
 -> RIO env (ProjectConfig (Path Abs File)))
-> ProjectConfig (Path Abs File)
-> RIO env (ProjectConfig (Path Abs File))
forall a b. (a -> b) -> a -> b
$ [PackageIdentifierRevision] -> ProjectConfig (Path Abs File)
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 :: StackYamlLoc
-> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid))
loadProjectConfig StackYamlLoc
mstackYaml = do
    ProjectConfig (Path Abs File)
mfp <- StackYamlLoc -> RIO env (ProjectConfig (Path Abs File))
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 <- RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Loading project config file " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                        String -> Utf8Builder
forall a. IsString a => String -> a
fromString (String
-> (Path Rel File -> String) -> Maybe (Path Rel File) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
fp) Path Rel File -> String
forall b t. Path b t -> String
toFilePath (Path Abs Dir -> Path Abs File -> Maybe (Path Rel File)
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))
            (Project, Path Abs File, ConfigMonoid)
-> ProjectConfig (Project, Path Abs File, ConfigMonoid)
forall a. a -> ProjectConfig a
PCProject ((Project, Path Abs File, ConfigMonoid)
 -> ProjectConfig (Project, Path Abs File, ConfigMonoid))
-> RIO env (Project, Path Abs File, ConfigMonoid)
-> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs File -> RIO env (Project, Path Abs File, ConfigMonoid)
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
            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"No project config file found, using defaults."
            ProjectConfig (Project, Path Abs File, ConfigMonoid)
-> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid))
forall (m :: * -> *) a. Monad m => a -> m a
return ProjectConfig (Project, Path Abs File, ConfigMonoid)
forall a. ProjectConfig a
PCGlobalProject
        PCNoProject [PackageIdentifierRevision]
extraDeps -> do
            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Ignoring config files"
            ProjectConfig (Project, Path Abs File, ConfigMonoid)
-> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid))
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectConfig (Project, Path Abs File, ConfigMonoid)
 -> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid)))
-> ProjectConfig (Project, Path Abs File, ConfigMonoid)
-> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid))
forall a b. (a -> b) -> a -> b
$ [PackageIdentifierRevision]
-> ProjectConfig (Project, Path Abs File, ConfigMonoid)
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 <- (Value -> Parser (WithJSONWarnings (IO ProjectAndConfigMonoid)))
-> Path Abs File -> RIO env (IO ProjectAndConfigMonoid)
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 File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
fp)) Path Abs File
fp
        ProjectAndConfigMonoid Project
project ConfigMonoid
config <- IO ProjectAndConfigMonoid -> RIO env ProjectAndConfigMonoid
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ProjectAndConfigMonoid
iopc
        (Project, Path Abs File, ConfigMonoid)
-> RIO env (Project, Path Abs File, ConfigMonoid)
forall (m :: * -> *) a. Monad m => a -> m a
return (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 :: 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) ->
            ((Path Abs File, Bool) -> Maybe (Path Abs File))
-> RIO env (Path Abs File, Bool) -> RIO env (Maybe (Path Abs File))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just (Path Abs File -> Maybe (Path Abs File))
-> ((Path Abs File, Bool) -> Path Abs File)
-> (Path Abs File, Bool)
-> Maybe (Path Abs File)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path Abs File, Bool) -> Path Abs File
forall a b. (a, b) -> a
fst ) (RIO env (Path Abs File, Bool) -> RIO env (Maybe (Path Abs File)))
-> RIO env (Path Abs File, Bool) -> RIO env (Maybe (Path Abs File))
forall a b. (a -> b) -> a -> b
$
            Maybe Text
-> (Path Abs File -> RIO env Bool)
-> Path Abs File
-> Path Abs File
-> RIO env (Path Abs File, Bool)
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
                (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"non-project global configuration file")
                Path Abs File -> RIO env Bool
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) -> Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall (m :: * -> *) a. Monad m => a -> m a
return (Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just Path Abs File
new)
        (Maybe (Path Abs File), Maybe (Path Abs File))
_ -> Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Path Abs File)
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 :: Path Abs Dir -> RIO env (Path Abs File)
getDefaultUserConfigPath Path Abs Dir
stackRoot = do
    (Path Abs File
path, Bool
exists) <- Maybe Text
-> (Path Abs File -> RIO env Bool)
-> Path Abs File
-> Path Abs File
-> RIO env (Path Abs File, Bool)
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
        (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"non-project configuration file")
        Path Abs File -> RIO env Bool
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)
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
        Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
path)
        IO () -> RIO env ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Builder -> IO ()
forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
path Builder
forall s. IsString s => s
defaultConfigYaml
    Path Abs File -> RIO env (Path Abs File)
forall (m :: * -> *) a. Monad m => a -> m a
return Path Abs File
path

packagesParser :: Parser [String]
packagesParser :: Parser [String]
packagesParser = Parser String -> Parser [String]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
                   (String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"package" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<>
                     String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"PACKAGE(S)" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<>
                     String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Additional package(s) that must be installed"))

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