{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE TypeFamilies        #-}

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

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

-- whatever files are available.

--

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

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

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

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

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

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

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

import           Control.Monad.Extra ( firstJustM )
import           Data.Aeson.Types ( Value )
import           Data.Aeson.WarningParser
                    ( WithJSONWarnings (..), logJSONWarnings )
import           Data.Array.IArray ( (!), (//) )
import qualified Data.ByteString as S
import           Data.ByteString.Builder ( byteString )
import           Data.Coerce ( coerce )
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import qualified Data.Map.Merge.Strict as MS
import qualified Data.Monoid
import           Data.Monoid.Map ( MonoidMap (..) )
import qualified Data.Text as T
import qualified Data.Yaml as Yaml
import           Distribution.System
                   ( Arch (OtherArch), OS (..), Platform (..), buildPlatform )
import qualified Distribution.Text ( simpleParse )
import           Distribution.Version ( simplifyVersionRange )
import           GHC.Conc ( getNumProcessors )
import           Network.HTTP.StackClient
                   ( httpJSON, parseUrlThrow, getResponseBody )
import           Options.Applicative ( Parser, help, long, metavar, strOption )
import           Path
                   ( PathException (..), (</>), parent, parseAbsDir
                   , parseAbsFile, parseRelDir, stripProperPrefix
                   )
import           Path.Extra ( toFilePathNoTrailingSep )
import           Path.Find ( findInParents )
import           Path.IO
                   ( XdgDirectory (..), canonicalizePath, doesDirExist
                   , doesFileExist, ensureDir, forgivingAbsence
                   , getAppUserDataDir, getCurrentDir, getXdgDir, resolveDir
                   , resolveDir', resolveFile'
                   )
import           RIO.List ( unzip )
import           RIO.Process
                   ( HasProcessContext (..), ProcessContext, augmentPathMap
                   , envVarsL
                   , mkProcessContext
                   )
import           RIO.Time ( toGregorian )
import           Stack.Build.Haddock ( shouldHaddockDeps )
import           Stack.Config.Build ( buildOptsFromMonoid )
import           Stack.Config.Docker ( dockerOptsFromMonoid )
import           Stack.Config.Nix ( nixOptsFromMonoid )
import           Stack.Constants
                   ( defaultGlobalConfigPath, defaultGlobalConfigPathDeprecated
                   , defaultUserConfigPath, defaultUserConfigPathDeprecated
                   , implicitGlobalProjectDir
                   , implicitGlobalProjectDirDeprecated, inContainerEnvVar
                   , inNixShellEnvVar, osIsWindows, pantryRootEnvVar
                   , platformVariantEnvVar, relDirBin, relDirStackWork
                   , relFileReadmeTxt, relFileStorage, relDirPantry
                   , relDirPrograms, relDirStackProgName, relDirUpperPrograms
                   , stackDeveloperModeDefault, stackDotYaml, stackProgName
                   , stackRootEnvVar, stackWorkEnvVar, stackXdgEnvVar
                   )
import           Stack.Lock ( lockCachedWanted )
import           Stack.Prelude
import           Stack.SourceMap
                   ( additionalDepPackage, checkFlagsUsedThrowing
                   , mkProjectPackage
                   )
import           Stack.Storage.Project ( initProjectStorage )
import           Stack.Storage.User ( initUserStorage )
import           Stack.Storage.Util ( handleMigrationException )
import           Stack.Types.AllowNewerDeps ( AllowNewerDeps (..) )
import           Stack.Types.ApplyGhcOptions ( ApplyGhcOptions (..) )
import           Stack.Types.ApplyProgOptions ( ApplyProgOptions (..) )
import           Stack.Types.Build.Exception ( BuildException (..) )
import           Stack.Types.BuildConfig ( BuildConfig (..) )
import           Stack.Types.BuildOpts ( BuildOpts (..) )
import           Stack.Types.ColorWhen ( ColorWhen (..) )
import           Stack.Types.Compiler ( defaultCompilerRepository )
import           Stack.Types.Config
                   ( Config (..), HasConfig (..), askLatestSnapshotUrl
                   , configProjectRoot, stackRootL, workDirL
                   )
import           Stack.Types.Config.Exception
                   ( ConfigException (..), ConfigPrettyException (..)
                   , ParseAbsolutePathException (..), packageIndicesWarning )
import           Stack.Types.ConfigMonoid
                   ( ConfigMonoid (..), parseConfigMonoid )
import           Stack.Types.Casa ( CasaOptsMonoid (..) )
import           Stack.Types.Docker ( DockerOptsMonoid (..), dockerEnable )
import           Stack.Types.DumpLogs ( DumpLogs (..) )
import           Stack.Types.GlobalOpts (  GlobalOpts (..) )
import           Stack.Types.Nix ( nixEnable )
import           Stack.Types.Platform
                   ( PlatformVariant (..), platformOnlyRelDir )
import           Stack.Types.Project ( Project (..) )
import           Stack.Types.ProjectAndConfigMonoid
                   ( ProjectAndConfigMonoid (..), parseProjectAndConfigMonoid )
import           Stack.Types.ProjectConfig ( ProjectConfig (..) )
import           Stack.Types.PvpBounds ( PvpBounds (..), PvpBoundsType (..) )
import           Stack.Types.Resolver ( AbstractResolver (..), Snapshots (..) )
import           Stack.Types.Runner
                   ( HasRunner (..), Runner (..), globalOptsL, terminalL )
import           Stack.Types.SourceMap
                   ( CommonPackage (..), DepPackage (..), ProjectPackage (..)
                   , SMWanted (..)
                   )
import           Stack.Types.StackYamlLoc ( StackYamlLoc (..) )
import           Stack.Types.UnusedFlags ( FlagSource (..) )
import           Stack.Types.Version
                   ( IntersectingVersionRange (..), VersionCheck (..)
                   , stackVersion, withinRange
                   )
import           System.Console.ANSI ( hSupportsANSI, setSGRCode )
import           System.Environment ( getEnvironment, lookupEnv )
import           System.Info.ShortPathName ( getShortPathName )
import           System.PosixCompat.Files ( fileOwner, getFileStatus )
import           System.Posix.User ( getEffectiveUserID )

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

-- the new path.

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

     -- displayed)

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

  -> Path Abs a
     -- ^ New path

  -> Path Abs a
     -- ^ Deprecated path

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

tryDeprecatedPath :: forall env a.
HasTerm env =>
Maybe Text
-> (Path Abs a -> RIO env Bool)
-> Path Abs a
-> Path Abs a
-> RIO env (Path Abs a, Bool)
tryDeprecatedPath Maybe Text
mWarningDesc Path Abs a -> RIO env Bool
exists Path Abs a
new Path Abs a
old = do
  Bool
newExists <- Path Abs a -> RIO env Bool
exists Path Abs a
new
  if Bool
newExists
    then (Path Abs a, Bool) -> RIO env (Path Abs a, Bool)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs a
new, Bool
True)
    else do
      Bool
oldExists <- Path Abs a -> RIO env Bool
exists Path Abs a
old
      if Bool
oldExists
        then do
          case Maybe Text
mWarningDesc of
            Maybe Text
Nothing -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just Text
desc ->
              [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
                [ String -> StyleDoc
flow String
"Location of"
                , String -> StyleDoc
flow (Text -> String
T.unpack Text
desc)
                , StyleDoc
"at"
                , Style -> StyleDoc -> StyleDoc
style Style
Dir (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Path Abs a -> String
forall b t. Path b t -> String
toFilePath Path Abs a
old)
                , String -> StyleDoc
flow String
"is deprecated; rename it to"
                , Style -> StyleDoc -> StyleDoc
style Style
Dir (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Path Abs a -> String
forall b t. Path b t -> String
toFilePath Path Abs a
new)
                , StyleDoc
"instead."
                ]
          (Path Abs a, Bool) -> RIO env (Path Abs a, Bool)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs a
old, Bool
True)
        else (Path Abs a, Bool) -> RIO env (Path Abs a, Bool)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs a
new, Bool
False)

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

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

-- Otherwise, the new location is returned.

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

  (Path Abs Dir, Bool) -> Path Abs Dir
forall a b. (a, b) -> a
fst ((Path Abs Dir, Bool) -> Path Abs Dir)
-> RIO env (Path Abs Dir, Bool) -> RIO env (Path Abs Dir)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
-> (Path Abs Dir -> RIO env Bool)
-> Path Abs Dir
-> Path Abs Dir
-> RIO env (Path Abs Dir, Bool)
forall env a.
HasTerm 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)
Lens' Config (Path Abs Dir)
stackRootL Config
config

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

getSnapshots :: HasConfig env => RIO env Snapshots
getSnapshots :: forall env. HasConfig env => RIO env Snapshots
getSnapshots = do
  Text
latestUrlText <- 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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 :: forall env.
HasConfig env =>
AbstractResolver -> RIO env RawSnapshotLocation
makeConcreteResolver (ARResolver RawSnapshotLocation
r) = RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshotLocation
r
makeConcreteResolver AbstractResolver
ar = do
  RawSnapshotLocation
r <-
    case AbstractResolver
ar of
      AbstractResolver
ARGlobal -> do
        Config
config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL
        Path Abs Dir
implicitGlobalDir <- Config -> RIO env (Path Abs Dir)
forall env. HasTerm 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 a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ProjectAndConfigMonoid
iopc
        RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 -> ConfigException -> RIO env RawSnapshotLocation
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (ConfigException -> RIO env RawSnapshotLocation)
-> ConfigException -> RIO env RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ Int -> ConfigException
NoLTSWithMajorVersion Int
x
          Just Int
y -> RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a. a -> RIO env a
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
$ 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 ConfigException -> RIO env RawSnapshotLocation
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ConfigException
NoLTSFound
          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 a. a -> RIO env a
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
$ Int -> Int -> SnapName
LTS Int
x Int
y
  [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
    [ String -> StyleDoc
flow String
"Selected resolver:"
    , Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> Text
forall a. Display a => a -> Text
textDisplay RawSnapshotLocation
r) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
    ]
  RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshotLocation
r

-- | Get the latest snapshot resolver available.

getLatestResolver :: HasConfig env => RIO env RawSnapshotLocation
getLatestResolver :: forall env. HasConfig env => RIO env RawSnapshotLocation
getLatestResolver = do
  Snapshots
snapshots <- 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 a. a -> RIO env a
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, HasTerm env)
  => Path Abs Dir -- ^ Stack root, e.g. ~/.stack

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

  -> Maybe AbstractResolver
  -> ProjectConfig (Project, Path Abs File)
  -> ConfigMonoid
  -> (Config -> RIO env a)
  -> RIO env a
configFromConfigMonoid :: forall env a.
(HasRunner env, HasTerm env) =>
Path Abs Dir
-> Path Abs File
-> Maybe AbstractResolver
-> ProjectConfig (Project, Path Abs File)
-> ConfigMonoid
-> (Config -> RIO env a)
-> RIO env a
configFromConfigMonoid
  Path Abs Dir
configStackRoot
  Path Abs File
configUserConfigPath
  Maybe AbstractResolver
configResolver
  ProjectConfig (Project, Path Abs File)
configProject
  ConfigMonoid{[String]
[Text]
[Path Abs Dir]
Maybe AllowNewerDeps
Map Text Text
First Bool
First Int
First String
First [PackageIndexConfig]
First Text
First CasaRepoPrefix
First PackageIndexConfig
First (Path Rel Dir)
First (Path Abs Dir)
First (Path Abs File)
First ApplyGhcOptions
First ApplyProgOptions
First ColorWhen
First CompilerBuild
First DumpLogs
First GHCVariant
First PvpBounds
First SCM
First TemplateName
First VersionCheck
First CompilerRepository
StylesUpdate
FirstFalse
FirstTrue
MonoidMap PackageName (Dual [Text])
MonoidMap ApplyGhcOptions (Dual [Text])
MonoidMap CabalConfigKey (Dual [Text])
BuildOptsMonoid
CasaOptsMonoid
NixOptsMonoid
IntersectingVersionRange
SetupInfo
DockerOptsMonoid
configMonoidStackRoot :: First (Path Abs Dir)
configMonoidWorkDir :: First (Path Rel Dir)
configMonoidBuildOpts :: BuildOptsMonoid
configMonoidDockerOpts :: DockerOptsMonoid
configMonoidNixOpts :: NixOptsMonoid
configMonoidConnectionCount :: First Int
configMonoidHideTHLoading :: FirstTrue
configMonoidPrefixTimestamps :: First Bool
configMonoidLatestSnapshot :: First Text
configMonoidPackageIndex :: First PackageIndexConfig
configMonoidPackageIndices :: First [PackageIndexConfig]
configMonoidSystemGHC :: First Bool
configMonoidInstallGHC :: FirstTrue
configMonoidSkipGHCCheck :: FirstFalse
configMonoidSkipMsys :: FirstFalse
configMonoidCompilerCheck :: First VersionCheck
configMonoidCompilerRepository :: First CompilerRepository
configMonoidRequireStackVersion :: IntersectingVersionRange
configMonoidArch :: First String
configMonoidGHCVariant :: First GHCVariant
configMonoidGHCBuild :: First CompilerBuild
configMonoidJobs :: First Int
configMonoidExtraIncludeDirs :: [String]
configMonoidExtraLibDirs :: [String]
configMonoidCustomPreprocessorExts :: [Text]
configMonoidOverrideGccPath :: First (Path Abs File)
configMonoidOverrideHpack :: First String
configMonoidConcurrentTests :: First Bool
configMonoidLocalBinPath :: First String
configMonoidTemplateParameters :: Map Text Text
configMonoidScmInit :: First SCM
configMonoidGhcOptionsByName :: MonoidMap PackageName (Dual [Text])
configMonoidGhcOptionsByCat :: MonoidMap ApplyGhcOptions (Dual [Text])
configMonoidCabalConfigOpts :: MonoidMap CabalConfigKey (Dual [Text])
configMonoidExtraPath :: [Path Abs Dir]
configMonoidSetupInfoLocations :: [String]
configMonoidSetupInfoInline :: SetupInfo
configMonoidLocalProgramsBase :: First (Path Abs Dir)
configMonoidPvpBounds :: First PvpBounds
configMonoidModifyCodePage :: FirstTrue
configMonoidRebuildGhcOptions :: FirstFalse
configMonoidApplyGhcOptions :: First ApplyGhcOptions
configMonoidApplyProgOptions :: First ApplyProgOptions
configMonoidAllowNewer :: First Bool
configMonoidAllowNewerDeps :: Maybe AllowNewerDeps
configMonoidDefaultTemplate :: First TemplateName
configMonoidAllowDifferentUser :: First Bool
configMonoidDumpLogs :: First DumpLogs
configMonoidSaveHackageCreds :: First Bool
configMonoidHackageBaseUrl :: First Text
configMonoidColorWhen :: First ColorWhen
configMonoidStyles :: StylesUpdate
configMonoidHideSourcePaths :: FirstTrue
configMonoidRecommendUpgrade :: FirstTrue
configMonoidNotifyIfNixOnPath :: FirstTrue
configMonoidCasaOpts :: CasaOptsMonoid
configMonoidCasaRepoPrefix :: First CasaRepoPrefix
configMonoidSnapshotLocation :: First Text
configMonoidNoRunCompile :: FirstFalse
configMonoidStackDeveloperMode :: First Bool
configMonoidStackRoot :: ConfigMonoid -> First (Path Abs Dir)
configMonoidWorkDir :: ConfigMonoid -> First (Path Rel Dir)
configMonoidBuildOpts :: ConfigMonoid -> BuildOptsMonoid
configMonoidDockerOpts :: ConfigMonoid -> DockerOptsMonoid
configMonoidNixOpts :: ConfigMonoid -> NixOptsMonoid
configMonoidConnectionCount :: ConfigMonoid -> First Int
configMonoidHideTHLoading :: ConfigMonoid -> FirstTrue
configMonoidPrefixTimestamps :: ConfigMonoid -> First Bool
configMonoidLatestSnapshot :: ConfigMonoid -> First Text
configMonoidPackageIndex :: ConfigMonoid -> First PackageIndexConfig
configMonoidPackageIndices :: ConfigMonoid -> First [PackageIndexConfig]
configMonoidSystemGHC :: ConfigMonoid -> First Bool
configMonoidInstallGHC :: ConfigMonoid -> FirstTrue
configMonoidSkipGHCCheck :: ConfigMonoid -> FirstFalse
configMonoidSkipMsys :: ConfigMonoid -> FirstFalse
configMonoidCompilerCheck :: ConfigMonoid -> First VersionCheck
configMonoidCompilerRepository :: ConfigMonoid -> First CompilerRepository
configMonoidRequireStackVersion :: ConfigMonoid -> IntersectingVersionRange
configMonoidArch :: ConfigMonoid -> First String
configMonoidGHCVariant :: ConfigMonoid -> First GHCVariant
configMonoidGHCBuild :: ConfigMonoid -> First CompilerBuild
configMonoidJobs :: ConfigMonoid -> First Int
configMonoidExtraIncludeDirs :: ConfigMonoid -> [String]
configMonoidExtraLibDirs :: ConfigMonoid -> [String]
configMonoidCustomPreprocessorExts :: ConfigMonoid -> [Text]
configMonoidOverrideGccPath :: ConfigMonoid -> First (Path Abs File)
configMonoidOverrideHpack :: ConfigMonoid -> First String
configMonoidConcurrentTests :: ConfigMonoid -> First Bool
configMonoidLocalBinPath :: ConfigMonoid -> First String
configMonoidTemplateParameters :: ConfigMonoid -> Map Text Text
configMonoidScmInit :: ConfigMonoid -> First SCM
configMonoidGhcOptionsByName :: ConfigMonoid -> MonoidMap PackageName (Dual [Text])
configMonoidGhcOptionsByCat :: ConfigMonoid -> MonoidMap ApplyGhcOptions (Dual [Text])
configMonoidCabalConfigOpts :: ConfigMonoid -> MonoidMap CabalConfigKey (Dual [Text])
configMonoidExtraPath :: ConfigMonoid -> [Path Abs Dir]
configMonoidSetupInfoLocations :: ConfigMonoid -> [String]
configMonoidSetupInfoInline :: ConfigMonoid -> SetupInfo
configMonoidLocalProgramsBase :: ConfigMonoid -> First (Path Abs Dir)
configMonoidPvpBounds :: ConfigMonoid -> First PvpBounds
configMonoidModifyCodePage :: ConfigMonoid -> FirstTrue
configMonoidRebuildGhcOptions :: ConfigMonoid -> FirstFalse
configMonoidApplyGhcOptions :: ConfigMonoid -> First ApplyGhcOptions
configMonoidApplyProgOptions :: ConfigMonoid -> First ApplyProgOptions
configMonoidAllowNewer :: ConfigMonoid -> First Bool
configMonoidAllowNewerDeps :: ConfigMonoid -> Maybe AllowNewerDeps
configMonoidDefaultTemplate :: ConfigMonoid -> First TemplateName
configMonoidAllowDifferentUser :: ConfigMonoid -> First Bool
configMonoidDumpLogs :: ConfigMonoid -> First DumpLogs
configMonoidSaveHackageCreds :: ConfigMonoid -> First Bool
configMonoidHackageBaseUrl :: ConfigMonoid -> First Text
configMonoidColorWhen :: ConfigMonoid -> First ColorWhen
configMonoidStyles :: ConfigMonoid -> StylesUpdate
configMonoidHideSourcePaths :: ConfigMonoid -> FirstTrue
configMonoidRecommendUpgrade :: ConfigMonoid -> FirstTrue
configMonoidNotifyIfNixOnPath :: ConfigMonoid -> FirstTrue
configMonoidCasaOpts :: ConfigMonoid -> CasaOptsMonoid
configMonoidCasaRepoPrefix :: ConfigMonoid -> First CasaRepoPrefix
configMonoidSnapshotLocation :: ConfigMonoid -> First Text
configMonoidNoRunCompile :: ConfigMonoid -> FirstFalse
configMonoidStackDeveloperMode :: ConfigMonoid -> First Bool
..}
  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 a. IO a -> RIO env a
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 <-
      let parseStackWorkEnv :: String -> m (Path Rel Dir)
parseStackWorkEnv String
x =
            m (Path Rel Dir)
-> (PathException -> m (Path Rel Dir)) -> m (Path Rel Dir)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
              (String -> m (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir String
x)
              ( \PathException
e -> case PathException
e of
                  InvalidRelDir String
_ ->
                    ConfigPrettyException -> m (Path Rel Dir)
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (ConfigPrettyException -> m (Path Rel Dir))
-> ConfigPrettyException -> m (Path Rel Dir)
forall a b. (a -> b) -> a -> b
$ String -> ConfigPrettyException
StackWorkEnvNotRelativeDir String
x
                  PathException
_ -> PathException -> m (Path Rel Dir)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PathException
e
              )
      in  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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Rel Dir
relDirStackWork) (IO (Path Rel Dir) -> RIO env (Path Rel Dir)
forall a. IO a -> RIO env a
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 :: * -> *}.
(MonadUnliftIO m, MonadThrow m) =>
String -> m (Path Rel Dir)
parseStackWorkEnv) 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
        configCustomPreprocessorExts :: [Text]
configCustomPreprocessorExts = [Text]
configMonoidCustomPreprocessorExts
        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 a b. Maybe a -> (a -> Maybe b) -> Maybe b
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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      OtherArch String
unk ->
        [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
          [ String -> StyleDoc
flow String
"Unknown value for architecture setting:"
          , Style -> StyleDoc -> StyleDoc
style Style
Shell (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
unk) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
          ]
      Arch
_ -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    PlatformVariant
configPlatformVariant <- IO PlatformVariant -> RIO env PlatformVariant
forall a. IO a -> RIO env a
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 a b. (a -> b) -> Maybe a -> Maybe b
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, HasTerm 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 e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ConfigException
NixRequiresSystemGhc
        (Maybe Bool, Bool)
_ ->
          Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            (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 e a. Exception e => e -> RIO env a
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 a. IO a -> RIO env a
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 e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM Map Text Text -> RIO env (Map Text Text)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Either ProcessException (Map Text Text)
 -> RIO env (Map Text Text))
-> Either ProcessException (Map Text Text)
-> RIO env (Map Text Text)
forall a b. (a -> b) -> a -> b
$ [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 b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 a. Eq a => a -> [a] -> 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 a. IO a -> RIO env a
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 a. Eq a => a -> [a] -> 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
$
        StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
          StyleDoc
"[S-8432]"
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
               [ String -> StyleDoc
flow String
"Stack's 'programs' path contains a space character and \
                      \has no alternative short ('8 dot 3') name. This will \
                      \cause problems with packages that use the GNU project's \
                      \'configure' shell script. Use the"
               , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"local-programs-path"
               , String -> StyleDoc
flow String
"configuration option to specify an alternative path. \
                      \The current path is:"
               , Style -> StyleDoc -> StyleDoc
style Style
File (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
localProgramsFilePath) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
               ]
    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 a. a -> RIO env a
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
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 a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumProcessors
        Just Int
i -> Int -> RIO env Int
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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]
forall a b. Coercible a b => a -> b
coerce MonoidMap CabalConfigKey (Dual [Text])
configMonoidCabalConfigOpts
        configGhcOptionsByName :: Map PackageName [Text]
configGhcOptionsByName = MonoidMap PackageName (Dual [Text]) -> Map PackageName [Text]
forall a b. Coercible a b => a -> b
coerce MonoidMap PackageName (Dual [Text])
configMonoidGhcOptionsByName
        configGhcOptionsByCat :: Map ApplyGhcOptions [Text]
configGhcOptionsByCat = MonoidMap ApplyGhcOptions (Dual [Text])
-> Map ApplyGhcOptions [Text]
forall a b. Coercible a b => a -> b
coerce MonoidMap ApplyGhcOptions (Dual [Text])
configMonoidGhcOptionsByCat
        configSetupInfoLocations :: [String]
configSetupInfoLocations = [String]
configMonoidSetupInfoLocations
        configSetupInfoInline :: SetupInfo
configSetupInfoInline = SetupInfo
configMonoidSetupInfoInline
        configPvpBounds :: PvpBounds
configPvpBounds =
          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
        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
        configApplyProgOptions :: ApplyProgOptions
configApplyProgOptions = ApplyProgOptions -> First ApplyProgOptions -> ApplyProgOptions
forall a. a -> First a -> a
fromFirst ApplyProgOptions
APOLocals First ApplyProgOptions
configMonoidApplyProgOptions
        configAllowNewer :: Bool
configAllowNewer = Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst Bool
False First Bool
configMonoidAllowNewer
        configAllowNewerDeps :: Maybe [PackageName]
configAllowNewerDeps = Maybe AllowNewerDeps -> Maybe [PackageName]
forall a b. Coercible a b => a -> b
coerce Maybe AllowNewerDeps
configMonoidAllowNewerDeps
        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
        configNotifyIfNixOnPath :: Bool
configNotifyIfNixOnPath = FirstTrue -> Bool
fromFirstTrue FirstTrue
configMonoidNotifyIfNixOnPath
        configNoRunCompile :: Bool
configNoRunCompile = FirstFalse -> Bool
fromFirstFalse FirstFalse
configMonoidNoRunCompile
    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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
Lens' env Runner
runnerL
    Bool
useAnsi <- IO Bool -> RIO env Bool
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RIO env Bool) -> IO Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hSupportsANSI 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
Lens' Runner 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 a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
Lens' Runner 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
Lens' Runner 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
Lens' Runner 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'
    PackageIndexConfig
pic <-
      case First PackageIndexConfig -> Maybe PackageIndexConfig
forall a. First a -> Maybe a
getFirst First PackageIndexConfig
configMonoidPackageIndex of
        Maybe PackageIndexConfig
Nothing ->
          case First [PackageIndexConfig] -> Maybe [PackageIndexConfig]
forall a. First a -> Maybe a
getFirst First [PackageIndexConfig]
configMonoidPackageIndices of
            Maybe [PackageIndexConfig]
Nothing -> PackageIndexConfig -> RIO env PackageIndexConfig
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIndexConfig
defaultPackageIndexConfig
            Just [PackageIndexConfig
pic] -> do
              StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn StyleDoc
packageIndicesWarning
              PackageIndexConfig -> RIO env PackageIndexConfig
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIndexConfig
pic
            Just [PackageIndexConfig]
x -> ConfigPrettyException -> RIO env PackageIndexConfig
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (ConfigPrettyException -> RIO env PackageIndexConfig)
-> ConfigPrettyException -> RIO env PackageIndexConfig
forall a b. (a -> b) -> a -> b
$ [PackageIndexConfig] -> ConfigPrettyException
MultiplePackageIndices [PackageIndexConfig]
x
        Just PackageIndexConfig
pic -> PackageIndexConfig -> RIO env PackageIndexConfig
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIndexConfig
pic
    Maybe String
mpantryRoot <- IO (Maybe String) -> RIO env (Maybe String)
forall a. IO a -> RIO env a
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
pantryRootEnvVar
    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 -> ParseAbsolutePathException -> RIO env (Path Abs Dir)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (ParseAbsolutePathException -> RIO env (Path Abs Dir))
-> ParseAbsolutePathException -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ String -> String -> ParseAbsolutePathException
ParseAbsolutePathException String
pantryRootEnvVar String
dir
            Just Path Abs Dir
x -> Path Abs Dir -> RIO env (Path Abs Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
x
        Maybe String
Nothing -> Path Abs Dir -> RIO env (Path Abs Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir -> 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 (Year
year, Int
month, Int
day) = Day -> (Year, 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
<> Year -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Year
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
        configCasa :: Maybe (CasaRepoPrefix, Int)
configCasa = if FirstTrue -> Bool
fromFirstTrue (FirstTrue -> Bool) -> FirstTrue -> Bool
forall a b. (a -> b) -> a -> b
$ CasaOptsMonoid -> FirstTrue
casaMonoidEnable CasaOptsMonoid
configMonoidCasaOpts
          then
            let casaRepoPrefix :: CasaRepoPrefix
casaRepoPrefix = CasaRepoPrefix -> First CasaRepoPrefix -> CasaRepoPrefix
forall a. a -> First a -> a
fromFirst
                  (CasaRepoPrefix -> First CasaRepoPrefix -> CasaRepoPrefix
forall a. a -> First a -> a
fromFirst CasaRepoPrefix
defaultCasaRepoPrefix First CasaRepoPrefix
configMonoidCasaRepoPrefix)
                  (CasaOptsMonoid -> First CasaRepoPrefix
casaMonoidRepoPrefix CasaOptsMonoid
configMonoidCasaOpts)
                casaMaxKeysPerRequest :: Int
casaMaxKeysPerRequest = Int -> First Int -> Int
forall a. a -> First a -> a
fromFirst
                  Int
defaultCasaMaxPerRequest
                  (CasaOptsMonoid -> First Int
casaMonoidMaxKeysPerRequest CasaOptsMonoid
configMonoidCasaOpts)
            in  (CasaRepoPrefix, Int) -> Maybe (CasaRepoPrefix, Int)
forall a. a -> Maybe a
Just (CasaRepoPrefix
casaRepoPrefix, Int
casaMaxKeysPerRequest)
          else Maybe (CasaRepoPrefix, Int)
forall a. Maybe a
Nothing
    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
Lens' Runner 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
$ RIO env a -> RIO env a
forall env a. HasLogFunc env => RIO env a -> RIO env a
handleMigrationException (RIO env a -> RIO env a) -> RIO env a -> RIO env a
forall a b. (a -> b) -> a -> b
$ do
        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ case Maybe (CasaRepoPrefix, Int)
configCasa of
          Maybe (CasaRepoPrefix, Int)
Nothing -> Utf8Builder
"Use of Casa server disabled."
          Just (CasaRepoPrefix
repoPrefix, Int
maxKeys) ->
               Utf8Builder
"Use of Casa server enabled: ("
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (CasaRepoPrefix -> String
forall a. Show a => a -> String
show CasaRepoPrefix
repoPrefix)
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", "
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Int -> String
forall a. Show a => a -> String
show Int
maxKeys)
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")."
        Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
forall env a.
HasLogFunc env =>
Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig'
          Path Abs Dir
pantryRoot
          PackageIndexConfig
pic
          (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
          Maybe (CasaRepoPrefix, Int)
configCasa
          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 {Bool
Int
[String]
[Text]
Maybe [PackageName]
Maybe (CasaRepoPrefix, Int)
Maybe (Path Abs File)
Maybe CompilerBuild
Maybe GHCVariant
Maybe AbstractResolver
Maybe SCM
Maybe TemplateName
Map PackageName [Text]
Map Text Text
Map ApplyGhcOptions [Text]
Map CabalConfigKey [Text]
Platform
VersionRange
Text
PantryConfig
Path Rel Dir
Path Abs Dir
Path Abs File
ApplyGhcOptions
ApplyProgOptions
BuildOpts
DumpLogs
NixOpts
PlatformVariant
ProjectConfig (Project, Path Abs File)
PvpBounds
UserStorage
VersionCheck
CompilerRepository
SetupInfo
DockerOpts
Runner
EnvSettings -> IO ProcessContext
configStackRoot :: Path Abs Dir
configUserConfigPath :: Path Abs File
configResolver :: Maybe AbstractResolver
configProject :: ProjectConfig (Project, Path Abs File)
configAllowLocals :: Bool
configWorkDir :: Path Rel Dir
configLatestSnapshot :: Text
configHideTHLoading :: Bool
configPrefixTimestamps :: Bool
configGHCVariant :: Maybe GHCVariant
configCompilerRepository :: CompilerRepository
configGHCBuild :: Maybe CompilerBuild
configInstallGHC :: Bool
configSkipGHCCheck :: Bool
configSkipMsys :: Bool
configExtraIncludeDirs :: [String]
configExtraLibDirs :: [String]
configCustomPreprocessorExts :: [Text]
configOverrideGccPath :: Maybe (Path Abs File)
configPlatform :: Platform
configRequireStackVersion :: VersionRange
configCompilerCheck :: VersionCheck
configPlatformVariant :: PlatformVariant
configBuild :: BuildOpts
configDocker :: DockerOpts
configNix :: NixOpts
configSystemGHC :: Bool
configProcessContextSettings :: EnvSettings -> IO ProcessContext
configLocalProgramsBase :: Path Abs Dir
configLocalPrograms :: Path Abs Dir
configLocalBin :: Path Abs Dir
configJobs :: Int
configConcurrentTests :: Bool
configTemplateParams :: Map Text Text
configScmInit :: Maybe SCM
configCabalConfigOpts :: Map CabalConfigKey [Text]
configGhcOptionsByName :: Map PackageName [Text]
configGhcOptionsByCat :: Map ApplyGhcOptions [Text]
configSetupInfoLocations :: [String]
configSetupInfoInline :: SetupInfo
configPvpBounds :: PvpBounds
configModifyCodePage :: Bool
configRebuildGhcOptions :: Bool
configApplyGhcOptions :: ApplyGhcOptions
configApplyProgOptions :: ApplyProgOptions
configAllowNewer :: Bool
configAllowNewerDeps :: Maybe [PackageName]
configDefaultTemplate :: Maybe TemplateName
configDumpLogs :: DumpLogs
configSaveHackageCreds :: Bool
configHackageBaseUrl :: Text
configHideSourcePaths :: Bool
configRecommendUpgrade :: Bool
configNotifyIfNixOnPath :: Bool
configNoRunCompile :: Bool
configAllowDifferentUser :: Bool
configStackDeveloperMode :: Bool
configCasa :: Maybe (CasaRepoPrefix, Int)
configRunner :: Runner
configPantryConfig :: PantryConfig
configUserStorage :: UserStorage
configWorkDir :: Path Rel Dir
configUserConfigPath :: Path Abs File
configBuild :: BuildOpts
configDocker :: DockerOpts
configNix :: NixOpts
configProcessContextSettings :: EnvSettings -> IO ProcessContext
configLocalProgramsBase :: Path Abs Dir
configLocalPrograms :: Path Abs Dir
configHideTHLoading :: Bool
configPrefixTimestamps :: Bool
configPlatform :: Platform
configPlatformVariant :: PlatformVariant
configGHCVariant :: Maybe GHCVariant
configGHCBuild :: Maybe CompilerBuild
configLatestSnapshot :: Text
configSystemGHC :: Bool
configInstallGHC :: Bool
configSkipGHCCheck :: Bool
configSkipMsys :: Bool
configCompilerCheck :: VersionCheck
configCompilerRepository :: CompilerRepository
configLocalBin :: Path Abs Dir
configRequireStackVersion :: VersionRange
configJobs :: Int
configOverrideGccPath :: Maybe (Path Abs File)
configExtraIncludeDirs :: [String]
configExtraLibDirs :: [String]
configCustomPreprocessorExts :: [Text]
configConcurrentTests :: Bool
configTemplateParams :: Map Text Text
configScmInit :: Maybe SCM
configGhcOptionsByName :: Map PackageName [Text]
configGhcOptionsByCat :: Map ApplyGhcOptions [Text]
configCabalConfigOpts :: Map CabalConfigKey [Text]
configSetupInfoLocations :: [String]
configSetupInfoInline :: SetupInfo
configPvpBounds :: PvpBounds
configModifyCodePage :: Bool
configRebuildGhcOptions :: Bool
configApplyGhcOptions :: ApplyGhcOptions
configApplyProgOptions :: ApplyProgOptions
configAllowNewer :: Bool
configAllowNewerDeps :: Maybe [PackageName]
configDefaultTemplate :: Maybe TemplateName
configAllowDifferentUser :: Bool
configDumpLogs :: DumpLogs
configProject :: ProjectConfig (Project, Path Abs File)
configAllowLocals :: Bool
configSaveHackageCreds :: Bool
configHackageBaseUrl :: Text
configRunner :: Runner
configPantryConfig :: PantryConfig
configStackRoot :: Path Abs Dir
configResolver :: Maybe AbstractResolver
configUserStorage :: UserStorage
configHideSourcePaths :: Bool
configRecommendUpgrade :: Bool
configNotifyIfNixOnPath :: Bool
configNoRunCompile :: Bool
configStackDeveloperMode :: Bool
configCasa :: Maybe (CasaRepoPrefix, Int)
..}))

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

withLocalLogFunc :: HasLogFunc env => LogFunc -> RIO env a -> RIO env a
withLocalLogFunc :: forall env a. HasLogFunc env => LogFunc -> RIO env a -> RIO env a
withLocalLogFunc LogFunc
logFunc = (env -> env) -> RIO env a -> RIO env a
forall a. (env -> env) -> RIO env a -> RIO env a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter env env 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
Lens' env LogFunc
logFuncL LogFunc
logFunc)

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

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

               -> StylesUpdate
               -> (LogFunc -> m a)
               -> m a
withNewLogFunc :: forall (m :: * -> *) a.
MonadUnliftIO m =>
GlobalOpts -> Bool -> StylesUpdate -> (LogFunc -> m a) -> m a
withNewLogFunc GlobalOpts
go Bool
useColor (StylesUpdate [(Style, StyleSpec)]
update) LogFunc -> m a
inner = do
  LogOptions
logOptions0 <- 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 :: forall (m :: * -> *).
MonadThrow m =>
Path Abs Dir -> Platform -> ProcessContext -> m (Path Abs Dir)
getDefaultLocalProgramsBase Path Abs Dir
configStackRoot Platform
configPlatform ProcessContext
override =
  case Platform
configPlatform of
    -- For historical reasons, on Windows a subdirectory of LOCALAPPDATA is

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

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

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

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

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

-- and defaults as necessary.

loadConfig ::
     (HasRunner env, HasTerm env)
  => (Config -> RIO env a)
  -> RIO env a
loadConfig :: forall env a.
(HasRunner env, HasTerm env) =>
(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
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.
HasTerm 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
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
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
configRoot, Path Abs Dir
stackRoot, Bool
userOwnsStackRoot) <-
    ConfigMonoid -> RIO env (Path Abs Dir, Path Abs Dir, Bool)
forall (m :: * -> *).
MonadIO m =>
ConfigMonoid -> m (Path Abs Dir, Path Abs Dir, Bool)
determineStackRootAndOwnership ConfigMonoid
configArgs

  let (ProjectConfig (Project, Path Abs File)
mproject', [ConfigMonoid] -> [ConfigMonoid]
addConfigMonoid) =
        case ProjectConfig (Project, Path Abs File, ConfigMonoid)
mproject of
          PCProject (Project
proj, Path Abs File
fp, ConfigMonoid
cm) -> ((Project, Path Abs File) -> ProjectConfig (Project, Path Abs File)
forall a. a -> ProjectConfig a
PCProject (Project
proj, Path Abs File
fp), (ConfigMonoid
cm:))
          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. HasTerm env => Path Abs Dir -> RIO env (Path Abs File)
getDefaultUserConfigPath Path Abs Dir
configRoot
  [ConfigMonoid]
extraConfigs0 <- Path Abs File -> RIO env [Path Abs File]
forall env. HasTerm 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 a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    (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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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, HasTerm 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
stackVersion Version -> VersionRange -> Bool
`withinRange` Config -> VersionRange
configRequireStackVersion Config
config)
      (ConfigException -> RIO env ()
forall e a. Exception e => e -> RIO env a
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 e a. Exception e => e -> RIO env a
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 :: forall a. 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) String -> RIO Config ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
String -> m ()
prettyWarnS
      (Project, Path Abs File) -> RIO Config (Project, Path Abs File)
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Project
project, Path Abs File
fp)
    PCNoProject [PackageIdentifierRevision]
extraDeps -> do
      Project
p <-
        case Maybe RawSnapshotLocation
mresolver of
          Maybe RawSnapshotLocation
Nothing -> 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 a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Project
p, Config -> Path Abs File
configUserConfigPath Config
config)
    ProjectConfig (Project, Path Abs File)
PCGlobalProject -> do
      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. HasTerm 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 a. IO a -> RIO Config a
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
Lens' Config 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 a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          (Project, Path Abs File) -> RIO Config (Project, Path Abs File)
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Project
project, Path Abs File
dest)
        else do
          [StyleDoc] -> RIO Config ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
            [ String -> StyleDoc
flow String
"Writing the configuration file for the implicit \
                   \global project to:"
            , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
dest StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
            , String -> StyleDoc
flow String
"Note: You can change the snapshot via the"
            , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"resolver"
            , String -> StyleDoc
flow String
"field there."
            ]
          Project
p <- Maybe RawSnapshotLocation
-> [PackageIdentifierRevision] -> RIO Config Project
getEmptyProject Maybe RawSnapshotLocation
mresolver []
          IO () -> RIO Config ()
forall a. IO a -> RIO Config a
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 -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$
              Builder
"This is the implicit global project, which is " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
              Builder
"used only when 'stack' is run\noutside of a " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
              Builder
"real project.\n"
          (Project, Path Abs File) -> RIO Config (Project, Path Abs File)
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
Lens' Config 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 a. Maybe a -> Maybe a -> Maybe a
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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.
(HasLogFunc env, HasPantryConfig env, HasProcessContext 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)
Lens' Config (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
          { 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
        [StyleDoc] -> RIO Config ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
          [ String -> StyleDoc
flow String
"Using the snapshot"
          , Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> Text
forall a. Display a => a -> Text
textDisplay RawSnapshotLocation
resolver)
          , String -> StyleDoc
flow String
"specified on the command line."
          ]
        RawSnapshotLocation -> RIO Config RawSnapshotLocation
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshotLocation
resolver
      Maybe RawSnapshotLocation
Nothing -> do
        RawSnapshotLocation
r'' <- RIO Config RawSnapshotLocation
forall env. HasConfig env => RIO env RawSnapshotLocation
getLatestResolver
        [StyleDoc] -> RIO Config ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
          [ String -> StyleDoc
flow String
"Using the latest snapshot"
          , Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> Text
forall a. Display a => a -> Text
textDisplay RawSnapshotLocation
r'') StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
          ]
        RawSnapshotLocation -> RIO Config RawSnapshotLocation
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshotLocation
r''
    Project -> RIO Config Project
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 ::
     (HasLogFunc env, HasPantryConfig env, HasProcessContext env)
  => Path Abs t
  -> Config
  -> Project
  -> Map RawPackageLocationImmutable PackageLocationImmutable
  -> WantedCompiler
  -> Map PackageName (Bool -> RIO env DepPackage)
  -> RIO env (SMWanted, [CompletedPLI])
fillProjectWanted :: forall env t.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
Path Abs t
-> Config
-> Project
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO env DepPackage)
-> RIO env (SMWanted, [CompletedPLI])
fillProjectWanted Path Abs t
stackYamlFP Config
config Project
project Map RawPackageLocationImmutable PackageLocationImmutable
locCache WantedCompiler
snapCompiler Map PackageName (Bool -> RIO env DepPackage)
snapPackages = do
  let bopts :: BuildOpts
bopts = Config -> BuildOpts
configBuild Config
config

  [(PackageName, ProjectPackage)]
packages0 <- [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 a. a -> RIO env a
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)

  -- prefetch git repos to avoid cloning per subdirectory

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

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

  ([(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 a b. (a -> b) -> RIO env a -> RIO env b
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 a. a -> RIO env a
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 a. a -> RIO env a
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 a. a -> RIO env a
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 a. a -> RIO env a
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 a. a -> RIO env a
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 a. a -> RIO env a
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 b c a. (b -> c) -> (a, b) -> (a, c)
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 b c a. (b -> c) -> (a, b) -> (a, c)
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
$
    BuildException -> RIO env ()
forall e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (BuildException -> RIO env ()) -> BuildException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [PackageName] -> BuildException
InvalidGhcOptionsSpecification (Map PackageName [Text] -> [PackageName]
forall k a. Map k a -> [k]
Map.keys Map PackageName [Text]
unusedPkgGhcOptions)

  let wanted :: SMWanted
wanted = 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 a. a -> RIO env a
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 :: forall (m :: * -> *).
MonadThrow m =>
[(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 b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second PackageLocation -> [PackageLocation]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure) [(PackageName, PackageLocation)]
locals of
    [] -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [(PackageName, [PackageLocation])]
x -> ConfigPrettyException -> m ()
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (ConfigPrettyException -> m ()) -> ConfigPrettyException -> m ()
forall a b. (a -> b) -> a -> b
$ [(PackageName, [PackageLocation])] -> ConfigPrettyException
DuplicateLocalPackageNames [(PackageName, [PackageLocation])]
x
 where
  hasMultiples :: (a, [a]) -> Bool
hasMultiples (a
_, a
_:a
_:[a]
_) = Bool
True
  hasMultiples (a, [a])
_ = Bool
False


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

--

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

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

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

  (Path Abs Dir
existingStackRootOrParentDir, Bool
userOwnsIt) <- do
    Maybe (Path Abs Dir, Bool)
mdirAndOwnership <- (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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
configRoot' <- Path Abs Dir -> IO (AbsPath (Path Abs Dir))
forall path (m :: * -> *).
(AnyPath path, MonadIO m) =>
path -> m (AbsPath path)
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> m (AbsPath (Path Abs Dir))
canonicalizePath Path Abs Dir
configRoot
  Path Abs Dir
stackRoot' <- Path Abs Dir -> IO (AbsPath (Path Abs Dir))
forall path (m :: * -> *).
(AnyPath path, MonadIO m) =>
path -> m (AbsPath path)
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> m (AbsPath (Path Abs Dir))
canonicalizePath Path Abs Dir
stackRoot
  (Path Abs Dir, Path Abs Dir, Bool)
-> IO (Path Abs Dir, Path Abs Dir, Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir
configRoot', Path Abs Dir
stackRoot', Bool
userOwnsIt)

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

-- owned by the current user.

--

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

-- If the parent directory doesn't exist either,

-- @'NoSuchDirectory' ('parent' dir)@ is thrown.

checkOwnership :: MonadIO m => Path Abs Dir -> m ()
checkOwnership :: forall (m :: * -> *). MonadIO m => Path Abs Dir -> m ()
checkOwnership Path Abs Dir
dir = do
  Maybe (Path Abs Dir, Bool)
mdirAndOwnership <- (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 a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    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 :: forall (m :: * -> *).
MonadIO m =>
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 a. IO a -> m a
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir
dir, Bool
ownership)

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

-- the owner for the given path.

--

-- Will always pure 'True' on Windows.

isOwnedByUser :: MonadIO m => Path Abs t -> m Bool
isOwnedByUser :: forall (m :: * -> *) t. MonadIO m => Path Abs t -> m Bool
isOwnedByUser Path Abs t
path = IO Bool -> m Bool
forall a. IO a -> m a
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
$
  if Bool
osIsWindows
    then Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 :: forall (m :: * -> *). MonadIO m => m Bool
getInContainer = IO Bool -> m Bool
forall a. IO a -> m a
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 :: forall (m :: * -> *). MonadIO m => m Bool
getInNixShell = IO Bool -> m Bool
forall a. IO a -> m a
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 :: HasTerm env
                => Path Abs File -- ^ use config path

                -> RIO env [Path Abs File]
getExtraConfigs :: forall env. HasTerm env => 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. HasTerm env => RIO env (Maybe (Path Abs File))
getDefaultGlobalConfigPath
  IO [Path Abs File] -> RIO env [Path Abs File]
forall a. IO a -> RIO env a
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 a b. (a -> b) -> IO a -> IO b
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 a b. (a -> b) -> IO a -> IO b
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 a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Path Abs File)
mstackGlobalConfig Maybe (Path Abs File)
-> Maybe (Path Abs File) -> Maybe (Path Abs File)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Path Abs File)
defaultStackGlobalConfigPath)

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

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

loadConfigYaml ::
     HasLogFunc env
  => (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> RIO env a
loadConfigYaml :: forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env a
loadConfigYaml Value -> Parser (WithJSONWarnings a)
parser Path Abs File
path = do
  Either ParseException a
eres <- (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 -> ConfigPrettyException -> RIO env a
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (Path Abs File -> ParseException -> ConfigPrettyException
ParseConfigFileException Path Abs File
path ParseException
err)
    Right a
res -> a -> RIO env a
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res

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

loadYaml ::
     HasLogFunc env
  => (Value -> Yaml.Parser (WithJSONWarnings a))
  -> Path Abs File
  -> RIO env (Either Yaml.ParseException a)
loadYaml :: forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env (Either ParseException a)
loadYaml Value -> Parser (WithJSONWarnings a)
parser Path Abs File
path = do
  Either ParseException Value
eres <- IO (Either ParseException Value)
-> RIO env (Either ParseException Value)
forall a. IO a -> RIO env a
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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 :: HasTerm env
                 => StackYamlLoc
                 -- ^ Override stack.yaml

                 -> RIO env (ProjectConfig (Path Abs File))
getProjectConfig :: forall env.
HasTerm env =>
StackYamlLoc -> RIO env (ProjectConfig (Path Abs File))
getProjectConfig (SYLOverride Path Abs File
stackYaml) = ProjectConfig (Path Abs File)
-> RIO env (ProjectConfig (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectConfig (Path Abs File)
forall a. ProjectConfig a
PCGlobalProject
getProjectConfig StackYamlLoc
SYLDefault = do
  [(String, String)]
env <- IO [(String, String)] -> RIO env [(String, String)]
forall a. IO a -> RIO env a
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
      String -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
String -> m ()
prettyInfoS
        String
"Getting the project-level configuration file from the \
        \STACK_YAML environment variable."
      Path Abs File -> ProjectConfig (Path Abs File)
forall a. a -> ProjectConfig a
PCProject (Path Abs File -> ProjectConfig (Path Abs File))
-> RIO env (Path Abs File)
-> RIO env (ProjectConfig (Path Abs File))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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 a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path b File)
forall a. Maybe a
Nothing
getProjectConfig (SYLNoProject [PackageIdentifierRevision]
extraDeps) = ProjectConfig (Path Abs File)
-> RIO env (ProjectConfig (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 ::
     HasTerm env
  => StackYamlLoc
     -- ^ Override stack.yaml

  -> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid))
loadProjectConfig :: forall env.
HasTerm env =>
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.
HasTerm 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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 a. IO a -> RIO env a
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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Project
project, Path Abs File
fp, ConfigMonoid
config)

-- | Get the location of the default Stack configuration file. If a file already

-- exists at the deprecated location, its location is returned. Otherwise, the

-- new location is returned.

getDefaultGlobalConfigPath ::
     HasTerm env
  => RIO env (Maybe (Path Abs File))
getDefaultGlobalConfigPath :: forall env. HasTerm env => RIO env (Maybe (Path Abs File))
getDefaultGlobalConfigPath =
  case (Maybe (Path Abs File)
defaultGlobalConfigPath, Maybe (Path Abs File)
defaultGlobalConfigPathDeprecated) of
    (Just Path Abs File
new, Just Path Abs File
old) ->
      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 ((Path Abs File, Bool) -> Maybe (Path Abs File))
-> RIO env (Path Abs File, Bool) -> RIO env (Maybe (Path Abs File))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Maybe Text
-> (Path Abs File -> RIO env Bool)
-> Path Abs File
-> Path Abs File
-> RIO env (Path Abs File, Bool)
forall env a.
HasTerm 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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just Path Abs File
new)
    (Maybe (Path Abs File), Maybe (Path Abs File))
_ -> Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs File)
forall a. Maybe a
Nothing

-- | 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 ::
     HasTerm env
  => Path Abs Dir
  -> RIO env (Path Abs File)
getDefaultUserConfigPath :: forall env. HasTerm env => 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.
HasTerm 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 a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ 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, Semigroup s) => s
defaultConfigYaml
  Path Abs File -> RIO env (Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
path

packagesParser :: Parser [String]
packagesParser :: Parser [String]
packagesParser = Parser String -> Parser [String]
forall a. Parser a -> Parser [a]
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" 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
"Add a package (can be specified multiple times)"))

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