{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE OverloadedRecordDot   #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# 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
  , determineStackRootAndOwnership
  ) 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 (..), 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 qualified Stack.Constants as Constants
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 ( DockerOpts (..), DockerOptsMonoid (..) )
import           Stack.Types.DumpLogs ( DumpLogs (..) )
import           Stack.Types.GlobalOpts (  GlobalOpts (..) )
import           Stack.Types.Nix ( NixOpts (..) )
import           Stack.Types.Platform
                   ( PlatformVariant (..), platformOnlyRelDir )
import           Stack.Types.Project ( Project (..) )
import qualified Stack.Types.Project as 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 ( hNowSupportsANSI, 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 Project
project.resolver
      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
. (.nightly) (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 Snapshots
snapshots.lts 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 Snapshots
snapshots.lts
          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 Snapshots
snapshots.lts
               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
snapshots.lts))
  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
snapshots.nightly) 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
stackRoot
  Path Abs File
userConfigPath
  Maybe AbstractResolver
resolver
  ProjectConfig (Project, Path Abs File)
project
  ConfigMonoid
configMonoid
  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)
project 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
        allowLocals :: Bool
allowLocals =
          case ProjectConfig (Project, Path Abs File)
project 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 workDir :: Path Rel Dir
workDir = Path Rel Dir -> First (Path Rel Dir) -> Path Rel Dir
forall a. a -> First a -> a
fromFirst Path Rel Dir
configWorkDir0 ConfigMonoid
configMonoid.workDir
        latestSnapshot :: Text
latestSnapshot = Text -> First Text -> Text
forall a. a -> First a -> a
fromFirst
          Text
"https://s3.amazonaws.com/haddock.stackage.org/snapshots.json"
          ConfigMonoid
configMonoid.latestSnapshot
        clConnectionCount :: Int
clConnectionCount = Int -> First Int -> Int
forall a. a -> First a -> a
fromFirst Int
8 ConfigMonoid
configMonoid.connectionCount
        hideTHLoading :: Bool
hideTHLoading = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.hideTHLoading
        prefixTimestamps :: Bool
prefixTimestamps = Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst Bool
False ConfigMonoid
configMonoid.prefixTimestamps
        ghcVariant :: Maybe GHCVariant
ghcVariant = First GHCVariant -> Maybe GHCVariant
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.ghcVariant
        compilerRepository :: CompilerRepository
compilerRepository = CompilerRepository
-> First CompilerRepository -> CompilerRepository
forall a. a -> First a -> a
fromFirst
          CompilerRepository
defaultCompilerRepository
          ConfigMonoid
configMonoid.compilerRepository
        ghcBuild :: Maybe CompilerBuild
ghcBuild = First CompilerBuild -> Maybe CompilerBuild
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.ghcBuild
        installGHC :: Bool
installGHC = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.installGHC
        skipGHCCheck :: Bool
skipGHCCheck = FirstFalse -> Bool
fromFirstFalse ConfigMonoid
configMonoid.skipGHCCheck
        skipMsys :: Bool
skipMsys = FirstFalse -> Bool
fromFirstFalse ConfigMonoid
configMonoid.skipMsys
        extraIncludeDirs :: [String]
extraIncludeDirs = ConfigMonoid
configMonoid.extraIncludeDirs
        extraLibDirs :: [String]
extraLibDirs = ConfigMonoid
configMonoid.extraLibDirs
        customPreprocessorExts :: [Text]
customPreprocessorExts = ConfigMonoid
configMonoid.customPreprocessorExts
        overrideGccPath :: Maybe (Path Abs File)
overrideGccPath = First (Path Abs File) -> Maybe (Path Abs File)
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.overrideGccPath
        -- 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 ConfigMonoid
configMonoid.arch 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
        platform :: Platform
platform = Arch -> OS -> Platform
Platform Arch
arch OS
os
        requireStackVersion :: VersionRange
requireStackVersion = VersionRange -> VersionRange
simplifyVersionRange
          ConfigMonoid
configMonoid.requireStackVersion.intersectingVersionRange
        compilerCheck :: VersionCheck
compilerCheck = VersionCheck -> First VersionCheck -> VersionCheck
forall a. a -> First a -> a
fromFirst VersionCheck
MatchMinor ConfigMonoid
configMonoid.compilerCheck
    PlatformVariant
platformVariant <- 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 build :: BuildOpts
build = BuildOptsMonoid -> BuildOpts
buildOptsFromMonoid ConfigMonoid
configMonoid.buildOpts
    DockerOpts
docker <-
      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
resolver ConfigMonoid
configMonoid.dockerOpts
    NixOpts
nix <- NixOptsMonoid -> OS -> RIO env NixOpts
forall env.
(HasRunner env, HasTerm env) =>
NixOptsMonoid -> OS -> RIO env NixOpts
nixOptsFromMonoid ConfigMonoid
configMonoid.nixOpts OS
os
    Bool
systemGHC <-
      case (First Bool -> Maybe Bool
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.systemGHC, NixOpts
nix.enable) of
        (Just Bool
False, Bool
True) ->
          ConfigException -> RIO env Bool
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, 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
docker.enable Bool -> Bool -> Bool
|| NixOpts
nix.enable)
              ConfigMonoid
configMonoid.systemGHC)
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe GHCVariant -> Bool
forall a. Maybe a -> Bool
isJust Maybe GHCVariant
ghcVariant Bool -> Bool -> Bool
&& Bool
systemGHC) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
      ConfigException -> RIO env ()
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, 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. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, 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 ConfigMonoid
configMonoid.extraPath)
                       ([(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 processContextSettings :: EnvSettings -> IO ProcessContext
processContextSettings EnvSettings
_ = ProcessContext -> IO ProcessContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessContext
origEnv
    Path Abs Dir
localProgramsBase <- case First (Path Abs Dir) -> Maybe (Path Abs Dir)
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.localProgramsBase 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
stackRoot Platform
platform 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
localProgramsBase
    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
localProgramsBase
      -- 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
platform, PlatformVariant
platformVariant)
    let localPrograms :: Path Abs Dir
localPrograms = Path Abs Dir
localProgramsBase 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
localBin <-
      case First String -> Maybe String
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.localBinPath 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
jobs <-
      case First Int -> Maybe Int
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.jobs 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 concurrentTests :: Bool
concurrentTests =
          Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst Bool
True ConfigMonoid
configMonoid.concurrentTests
        templateParams :: Map Text Text
templateParams = ConfigMonoid
configMonoid.templateParameters
        scmInit :: Maybe SCM
scmInit = First SCM -> Maybe SCM
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.scmInit
        cabalConfigOpts :: Map CabalConfigKey [Text]
cabalConfigOpts = MonoidMap CabalConfigKey (Dual [Text]) -> Map CabalConfigKey [Text]
forall a b. Coercible a b => a -> b
coerce ConfigMonoid
configMonoid.cabalConfigOpts
        ghcOptionsByName :: Map PackageName [Text]
ghcOptionsByName = MonoidMap PackageName (Dual [Text]) -> Map PackageName [Text]
forall a b. Coercible a b => a -> b
coerce ConfigMonoid
configMonoid.ghcOptionsByName
        ghcOptionsByCat :: Map ApplyGhcOptions [Text]
ghcOptionsByCat = MonoidMap ApplyGhcOptions (Dual [Text])
-> Map ApplyGhcOptions [Text]
forall a b. Coercible a b => a -> b
coerce ConfigMonoid
configMonoid.ghcOptionsByCat
        setupInfoLocations :: [String]
setupInfoLocations = ConfigMonoid
configMonoid.setupInfoLocations
        setupInfoInline :: SetupInfo
setupInfoInline = ConfigMonoid
configMonoid.setupInfoInline
        pvpBounds :: PvpBounds
pvpBounds =
          PvpBounds -> First PvpBounds -> PvpBounds
forall a. a -> First a -> a
fromFirst (PvpBoundsType -> Bool -> PvpBounds
PvpBounds PvpBoundsType
PvpBoundsNone Bool
False) ConfigMonoid
configMonoid.pvpBounds
        modifyCodePage :: Bool
modifyCodePage = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.modifyCodePage
        rebuildGhcOptions :: Bool
rebuildGhcOptions =
          FirstFalse -> Bool
fromFirstFalse ConfigMonoid
configMonoid.rebuildGhcOptions
        applyGhcOptions :: ApplyGhcOptions
applyGhcOptions =
          ApplyGhcOptions -> First ApplyGhcOptions -> ApplyGhcOptions
forall a. a -> First a -> a
fromFirst ApplyGhcOptions
AGOLocals ConfigMonoid
configMonoid.applyGhcOptions
        applyProgOptions :: ApplyProgOptions
applyProgOptions =
          ApplyProgOptions -> First ApplyProgOptions -> ApplyProgOptions
forall a. a -> First a -> a
fromFirst ApplyProgOptions
APOLocals ConfigMonoid
configMonoid.applyProgOptions
        allowNewer :: Bool
allowNewer = Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst Bool
False ConfigMonoid
configMonoid.allowNewer
        allowNewerDeps :: Maybe [PackageName]
allowNewerDeps = Maybe AllowNewerDeps -> Maybe [PackageName]
forall a b. Coercible a b => a -> b
coerce ConfigMonoid
configMonoid.allowNewerDeps
        defaultTemplate :: Maybe TemplateName
defaultTemplate = First TemplateName -> Maybe TemplateName
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.defaultTemplate
        dumpLogs :: DumpLogs
dumpLogs = DumpLogs -> First DumpLogs -> DumpLogs
forall a. a -> First a -> a
fromFirst DumpLogs
DumpWarningLogs ConfigMonoid
configMonoid.dumpLogs
        saveHackageCreds :: Bool
saveHackageCreds =
          Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst Bool
True ConfigMonoid
configMonoid.saveHackageCreds
        hackageBaseUrl :: Text
hackageBaseUrl =
          Text -> First Text -> Text
forall a. a -> First a -> a
fromFirst Text
Constants.hackageBaseUrl ConfigMonoid
configMonoid.hackageBaseUrl
        hideSourcePaths :: Bool
hideSourcePaths = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.hideSourcePaths
        recommendUpgrade :: Bool
recommendUpgrade = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.recommendUpgrade
        notifyIfNixOnPath :: Bool
notifyIfNixOnPath = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.notifyIfNixOnPath
        notifyIfGhcUntested :: Bool
notifyIfGhcUntested = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.notifyIfGhcUntested
        notifyIfCabalUntested :: Bool
notifyIfCabalUntested = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.notifyIfCabalUntested
        notifyIfArchUnknown :: Bool
notifyIfArchUnknown = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.notifyIfArchUnknown
        noRunCompile :: Bool
noRunCompile = FirstFalse -> Bool
fromFirstFalse ConfigMonoid
configMonoid.noRunCompile
    Bool
allowDifferentUser <-
      case First Bool -> Maybe Bool
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.allowDifferentUser 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
hNowSupportsANSI 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
<>
          ConfigMonoid
configMonoid.styles
        useColor' :: Bool
useColor' = Runner
configRunner'.useColor
        mUseColor :: Maybe Bool
mUseColor = do
          ColorWhen
colorWhen <- First ColorWhen -> Maybe ColorWhen
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.colorWhen
          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
configRunner'.globalOpts
    PackageIndexConfig
pic <-
      case First PackageIndexConfig -> Maybe PackageIndexConfig
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.packageIndex of
        Maybe PackageIndexConfig
Nothing ->
          case First [PackageIndexConfig] -> Maybe [PackageIndexConfig]
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.packageIndices 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
stackRoot 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 ConfigMonoid
configMonoid.snapshotLocation 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 stackDeveloperMode :: Bool
stackDeveloperMode = Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst
          Bool
stackDeveloperModeDefault
          ConfigMonoid
configMonoid.stackDeveloperMode
        casa :: Maybe (CasaRepoPrefix, Int)
casa =
          if FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.casaOpts.enable
            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 ConfigMonoid
configMonoid.casaRepoPrefix)
                    ConfigMonoid
configMonoid.casaOpts.repoPrefix
                  casaMaxKeysPerRequest :: Int
casaMaxKeysPerRequest = Int -> First Int -> Int
forall a. a -> First a -> a
fromFirst
                    Int
defaultCasaMaxPerRequest
                    ConfigMonoid
configMonoid.casaOpts.maxKeysPerRequest
              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 runner :: Runner
runner = 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)
casa 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 ConfigMonoid
configMonoid.overrideHpack)
          Int
clConnectionCount
          Maybe (CasaRepoPrefix, Int)
casa
          SnapName -> RawSnapshotLocation
snapLoc
          (\PantryConfig
pantryConfig -> 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
stackRoot 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
userStorage -> Config -> RIO env a
inner Config
                { Path Rel Dir
workDir :: Path Rel Dir
$sel:workDir:Config :: Path Rel Dir
workDir
                , Path Abs File
userConfigPath :: Path Abs File
$sel:userConfigPath:Config :: Path Abs File
userConfigPath
                , BuildOpts
build :: BuildOpts
$sel:build:Config :: BuildOpts
build
                , DockerOpts
docker :: DockerOpts
$sel:docker:Config :: DockerOpts
docker
                , NixOpts
nix :: NixOpts
$sel:nix:Config :: NixOpts
nix
                , EnvSettings -> IO ProcessContext
processContextSettings :: EnvSettings -> IO ProcessContext
$sel:processContextSettings:Config :: EnvSettings -> IO ProcessContext
processContextSettings
                , Path Abs Dir
localProgramsBase :: Path Abs Dir
$sel:localProgramsBase:Config :: Path Abs Dir
localProgramsBase
                , Path Abs Dir
localPrograms :: Path Abs Dir
$sel:localPrograms:Config :: Path Abs Dir
localPrograms
                , Bool
hideTHLoading :: Bool
$sel:hideTHLoading:Config :: Bool
hideTHLoading
                , Bool
prefixTimestamps :: Bool
$sel:prefixTimestamps:Config :: Bool
prefixTimestamps
                , Platform
platform :: Platform
$sel:platform:Config :: Platform
platform
                , PlatformVariant
platformVariant :: PlatformVariant
$sel:platformVariant:Config :: PlatformVariant
platformVariant
                , Maybe GHCVariant
ghcVariant :: Maybe GHCVariant
$sel:ghcVariant:Config :: Maybe GHCVariant
ghcVariant
                , Maybe CompilerBuild
ghcBuild :: Maybe CompilerBuild
$sel:ghcBuild:Config :: Maybe CompilerBuild
ghcBuild
                , Text
latestSnapshot :: Text
$sel:latestSnapshot:Config :: Text
latestSnapshot
                , Bool
systemGHC :: Bool
$sel:systemGHC:Config :: Bool
systemGHC
                , Bool
installGHC :: Bool
$sel:installGHC:Config :: Bool
installGHC
                , Bool
skipGHCCheck :: Bool
$sel:skipGHCCheck:Config :: Bool
skipGHCCheck
                , Bool
skipMsys :: Bool
$sel:skipMsys:Config :: Bool
skipMsys
                , VersionCheck
compilerCheck :: VersionCheck
$sel:compilerCheck:Config :: VersionCheck
compilerCheck
                , CompilerRepository
compilerRepository :: CompilerRepository
$sel:compilerRepository:Config :: CompilerRepository
compilerRepository
                , Path Abs Dir
localBin :: Path Abs Dir
$sel:localBin:Config :: Path Abs Dir
localBin
                , VersionRange
requireStackVersion :: VersionRange
$sel:requireStackVersion:Config :: VersionRange
requireStackVersion
                , Int
jobs :: Int
$sel:jobs:Config :: Int
jobs
                , Maybe (Path Abs File)
overrideGccPath :: Maybe (Path Abs File)
$sel:overrideGccPath:Config :: Maybe (Path Abs File)
overrideGccPath
                , [String]
extraIncludeDirs :: [String]
$sel:extraIncludeDirs:Config :: [String]
extraIncludeDirs
                , [String]
extraLibDirs :: [String]
$sel:extraLibDirs:Config :: [String]
extraLibDirs
                , [Text]
customPreprocessorExts :: [Text]
$sel:customPreprocessorExts:Config :: [Text]
customPreprocessorExts
                , Bool
concurrentTests :: Bool
$sel:concurrentTests:Config :: Bool
concurrentTests
                , Map Text Text
templateParams :: Map Text Text
$sel:templateParams:Config :: Map Text Text
templateParams
                , Maybe SCM
scmInit :: Maybe SCM
$sel:scmInit:Config :: Maybe SCM
scmInit
                , Map PackageName [Text]
ghcOptionsByName :: Map PackageName [Text]
$sel:ghcOptionsByName:Config :: Map PackageName [Text]
ghcOptionsByName
                , Map ApplyGhcOptions [Text]
ghcOptionsByCat :: Map ApplyGhcOptions [Text]
$sel:ghcOptionsByCat:Config :: Map ApplyGhcOptions [Text]
ghcOptionsByCat
                , Map CabalConfigKey [Text]
cabalConfigOpts :: Map CabalConfigKey [Text]
$sel:cabalConfigOpts:Config :: Map CabalConfigKey [Text]
cabalConfigOpts
                , [String]
setupInfoLocations :: [String]
$sel:setupInfoLocations:Config :: [String]
setupInfoLocations
                , SetupInfo
setupInfoInline :: SetupInfo
$sel:setupInfoInline:Config :: SetupInfo
setupInfoInline
                , PvpBounds
pvpBounds :: PvpBounds
$sel:pvpBounds:Config :: PvpBounds
pvpBounds
                , Bool
modifyCodePage :: Bool
$sel:modifyCodePage:Config :: Bool
modifyCodePage
                , Bool
rebuildGhcOptions :: Bool
$sel:rebuildGhcOptions:Config :: Bool
rebuildGhcOptions
                , ApplyGhcOptions
applyGhcOptions :: ApplyGhcOptions
$sel:applyGhcOptions:Config :: ApplyGhcOptions
applyGhcOptions
                , ApplyProgOptions
applyProgOptions :: ApplyProgOptions
$sel:applyProgOptions:Config :: ApplyProgOptions
applyProgOptions
                , Bool
allowNewer :: Bool
$sel:allowNewer:Config :: Bool
allowNewer
                , Maybe [PackageName]
allowNewerDeps :: Maybe [PackageName]
$sel:allowNewerDeps:Config :: Maybe [PackageName]
allowNewerDeps
                , Maybe TemplateName
defaultTemplate :: Maybe TemplateName
$sel:defaultTemplate:Config :: Maybe TemplateName
defaultTemplate
                , Bool
allowDifferentUser :: Bool
$sel:allowDifferentUser:Config :: Bool
allowDifferentUser
                , DumpLogs
dumpLogs :: DumpLogs
$sel:dumpLogs:Config :: DumpLogs
dumpLogs
                , ProjectConfig (Project, Path Abs File)
project :: ProjectConfig (Project, Path Abs File)
$sel:project:Config :: ProjectConfig (Project, Path Abs File)
project
                , Bool
allowLocals :: Bool
$sel:allowLocals:Config :: Bool
allowLocals
                , Bool
saveHackageCreds :: Bool
$sel:saveHackageCreds:Config :: Bool
saveHackageCreds
                , Text
hackageBaseUrl :: Text
$sel:hackageBaseUrl:Config :: Text
hackageBaseUrl
                , Runner
runner :: Runner
$sel:runner:Config :: Runner
runner
                , PantryConfig
pantryConfig :: PantryConfig
$sel:pantryConfig:Config :: PantryConfig
pantryConfig
                , Path Abs Dir
stackRoot :: Path Abs Dir
$sel:stackRoot:Config :: Path Abs Dir
stackRoot
                , Maybe AbstractResolver
resolver :: Maybe AbstractResolver
$sel:resolver:Config :: Maybe AbstractResolver
resolver
                , UserStorage
userStorage :: UserStorage
$sel:userStorage:Config :: UserStorage
userStorage
                , Bool
hideSourcePaths :: Bool
$sel:hideSourcePaths:Config :: Bool
hideSourcePaths
                , Bool
recommendUpgrade :: Bool
$sel:recommendUpgrade:Config :: Bool
recommendUpgrade
                , Bool
notifyIfNixOnPath :: Bool
$sel:notifyIfNixOnPath:Config :: Bool
notifyIfNixOnPath
                , Bool
notifyIfGhcUntested :: Bool
$sel:notifyIfGhcUntested:Config :: Bool
notifyIfGhcUntested
                , Bool
notifyIfCabalUntested :: Bool
$sel:notifyIfCabalUntested:Config :: Bool
notifyIfCabalUntested
                , Bool
notifyIfArchUnknown :: Bool
$sel:notifyIfArchUnknown:Config :: Bool
notifyIfArchUnknown
                , Bool
noRunCompile :: Bool
$sel:noRunCompile:Config :: Bool
noRunCompile
                , Bool
stackDeveloperMode :: Bool
$sel:stackDeveloperMode:Config :: Bool
stackDeveloperMode
                , Maybe (CasaRepoPrefix, Int)
casa :: Maybe (CasaRepoPrefix, Int)
$sel:casa:Config :: Maybe (CasaRepoPrefix, Int)
casa
                }
            )
          )

-- | 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
go.timeInLog
        (LogOptions -> LogOptions) -> LogOptions -> LogOptions
forall a b. (a -> b) -> a -> b
$ LogLevel -> LogOptions -> LogOptions
setLogMinLevel GlobalOpts
go.logLevel
        (LogOptions -> LogOptions) -> LogOptions -> LogOptions
forall a b. (a -> b) -> a -> b
$ Bool -> LogOptions -> LogOptions
setLogVerboseFormat (GlobalOpts
go.logLevel 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
go.terminal
          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. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, 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 (.stackYaml)
  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 (.resolver)
  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 (.configMonoid)
  (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 {dockerOpts = c.dockerOpts { defaultEnable = Any 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
    let Platform Arch
arch OS
_ = Config
config.platform
    case Arch
arch of
      OtherArch String
unknownArch
        | Config
config.notifyIfArchUnknown ->
            [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
unknownArch) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
              , String -> StyleDoc
flow String
"To mute this message in future, set"
              , Style -> StyleDoc -> StyleDoc
style Style
Shell (String -> StyleDoc
flow String
"notify-if-arch-unknown: false")
              , String -> StyleDoc
flow String
"in Stack's configuration."
              ]
      Arch
_ -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Version
stackVersion Version -> VersionRange -> Bool
`withinRange` Config
config.requireStackVersion)
      (ConfigException -> RIO env ()
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (VersionRange -> ConfigException
BadStackVersionException Config
config.requireStackVersion))
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Config
config.allowDifferentUser (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. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, 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
config.workDir)
    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
config.resolver ((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
stackYaml) <- case Config
config.project 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
project.userMsg 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
config.userConfigPath)
    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
config.resolver 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
project.resolver
                  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 Config
config.userConfigPath), 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 (.compiler)
  let project :: Project
      project :: Project
project = Project
project'
        { Project.compiler = mcompiler <|> project'.compiler
        , Project.resolver = fromMaybe project'.resolver 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
project.extraPackageDBs

  SMWanted
smWanted <- 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
stackYaml Project
project.resolver ((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
stackYaml 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
stackYaml Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
workDir Path Rel Dir -> Path Rel File -> Path Rel File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileStorage

  Path Abs File -> (ProjectStorage -> RIO Config a) -> RIO Config a
forall env a.
HasLogFunc env =>
Path Abs File -> (ProjectStorage -> RIO env a) -> RIO env a
initProjectStorage Path Abs File
projectStorageFile ((ProjectStorage -> RIO Config a) -> RIO Config a)
-> (ProjectStorage -> RIO Config a) -> RIO Config a
forall a b. (a -> b) -> a -> b
$ \ProjectStorage
projectStorage -> do
    let bc :: BuildConfig
bc = BuildConfig
          { Config
config :: Config
$sel:config:BuildConfig :: Config
config
          , SMWanted
smWanted :: SMWanted
$sel:smWanted:BuildConfig :: SMWanted
smWanted
          , [Path Abs Dir]
extraPackageDBs :: [Path Abs Dir]
$sel:extraPackageDBs:BuildConfig :: [Path Abs Dir]
extraPackageDBs
          , Path Abs File
stackYaml :: Path Abs File
$sel:stackYaml:BuildConfig :: Path Abs File
stackYaml
          , $sel:curator:BuildConfig :: Maybe Curator
curator = Project
project.curator
          , ProjectStorage
projectStorage :: ProjectStorage
$sel:projectStorage:BuildConfig :: 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
      { $sel:userMsg:Project :: Maybe String
userMsg = Maybe String
forall a. Maybe a
Nothing
      , $sel:packages:Project :: [RelFilePath]
packages = []
      , $sel:extraDeps:Project :: [RawPackageLocation]
extraDeps = (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
      , $sel:flagsByPkg:Project :: Map PackageName (Map FlagName Bool)
flagsByPkg = Map PackageName (Map FlagName Bool)
forall a. Monoid a => a
mempty
      , $sel:resolver:Project :: RawSnapshotLocation
resolver = RawSnapshotLocation
r
      , $sel:compiler:Project :: Maybe WantedCompiler
compiler = Maybe WantedCompiler
forall a. Maybe a
Nothing
      , $sel:extraPackageDBs:Project :: [String]
extraPackageDBs = []
      , $sel:curator:Project :: Maybe Curator
curator = Maybe Curator
forall a. Maybe a
Nothing
      , $sel:dropPackages:Project :: Set PackageName
dropPackages = 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
config.build

  [(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
project.packages ((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
bopts.buildHaddocks
    (PackageName, ProjectPackage)
-> RIO env (PackageName, ProjectPackage)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProjectPackage
pp.projectCommon.name, 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
project.extraDeps
  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
project.extraDeps ((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 ((DepPackage
dp.depCommon.name, 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
. (.resolvedDir))) [(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 (.location)) [(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
project.dropPackages

  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
project.flagsByPkg
      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 { projectCommon = p.projectCommon { flags = 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 { depCommon = d.depCommon { flags = 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
config.ghcOptionsByName
      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 { depCommon = d.depCommon { ghcOptions = 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 { projectCommon = p.projectCommon { ghcOptions = 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. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, 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
        { $sel:compiler:SMWanted :: WantedCompiler
compiler = WantedCompiler -> Maybe WantedCompiler -> WantedCompiler
forall a. a -> Maybe a -> a
fromMaybe WantedCompiler
snapCompiler Project
project.compiler
        , $sel:project:SMWanted :: Map PackageName ProjectPackage
project = Map PackageName ProjectPackage
packages
        , $sel:deps:SMWanted :: Map PackageName DepPackage
deps = Map PackageName DepPackage
deps
        , $sel:snapshotLocation:SMWanted :: RawSnapshotLocation
snapshotLocation = Project
project.resolver
        }

  (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
clArgs.stackRoot 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"