{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot   #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeFamilies          #-}

{-|
Module      : Stack.Config
Description : The general Stack configuration.
License     : BSD-3-Clause

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
  , getImplicitGlobalProjectDir
  , getSnapshots
  , makeConcreteSnapshot
  , getRawSnapshot
  , 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.Char ( isLatin1 )
import           Data.Coerce ( coerce )
import qualified Data.Either.Extra as EE
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.Set as Set
import qualified Data.Text as T
import qualified Data.Yaml as Yaml
import qualified Distribution.PackageDescription as PD
import           Distribution.System
                   ( Arch (..), OS (..), Platform (..), buildPlatform )
import qualified Distribution.Text ( simpleParse )
import           Distribution.Version ( simplifyVersionRange )
import qualified Hpack
import           GHC.Conc ( getNumProcessors )
import           Network.HTTP.StackClient
                   ( httpJSON, parseUrlThrow, getResponseBody )
import           Pantry ( loadSnapshot )
import           Path
                   ( PathException (..), (</>), parent, parseAbsDir
                   , parseAbsFile, parseRelDir, stripProperPrefix
                   )
import           Path.Extra ( toFilePathNoTrailingSep )
import           Path.Find ( findInParents )
import           Path.IO
                   ( XdgDirectory (..), canonicalizePath, doesFileExist
                   , ensureDir, forgivingAbsence, getAppUserDataDir
                   , getCurrentDir, getXdgDir, resolveDir, resolveDir'
                   , resolveFile, resolveFile'
                   )
import           RIO.List ( unzip, intersperse )
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, defaultUserConfigPath
                   , implicitGlobalProjectDir, 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, 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 (..), BuildPrettyException (..) )
import           Stack.Types.BuildConfig ( BuildConfig (..) )
import           Stack.Types.BuildOpts ( BuildOpts (..) )
import           Stack.Types.ColorWhen ( ColorWhen (..) )
import           Stack.Types.Compiler
                   ( defaultCompilerBindistPath, defaultCompilerRepository
                   , defaultCompilerTarget
                   )
import           Stack.Types.Config
                   ( Config (..), HasConfig (..), askLatestSnapshotUrl
                   , configProjectRoot, stackRootL, workDirL
                   )
import           Stack.Types.Config.Exception
                   ( ConfigException (..), ConfigPrettyException (..)
                   , ParseAbsolutePathException (..)
                   )
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.MsysEnvironment
                   ( MsysEnvironment (..), msysEnvArch )
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.Runner
                   ( HasRunner (..), Runner (..), globalOptsL, terminalL )
import           Stack.Types.Snapshot ( AbstractSnapshot (..), Snapshots (..) )
import           Stack.Types.SourceMap
                   ( CommonPackage (..), DepPackage (..), ProjectPackage (..)
                   , SMWanted (..)
                   )
import           Stack.Types.StackYamlLoc ( StackYamlLoc (..) )
import           Stack.Types.UnusedFlags ( FlagSource (..), UnusedFlags (..) )
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 )

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

getImplicitGlobalProjectDir :: HasConfig env => RIO env (Path Abs Dir)
getImplicitGlobalProjectDir :: forall env. HasConfig env => RIO env (Path Abs Dir)
getImplicitGlobalProjectDir = Getting (Path Abs Dir) env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Path Abs Dir) env (Path Abs Dir)
 -> RIO env (Path Abs Dir))
-> Getting (Path Abs Dir) env (Path Abs Dir)
-> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Getting (Path Abs Dir) env (Path Abs Dir)
forall s. HasConfig s => Lens' s (Path Abs Dir)
Lens' env (Path Abs Dir)
stackRootL Getting (Path Abs Dir) env (Path Abs Dir)
-> ((Path Abs Dir -> Const (Path Abs Dir) (Path Abs Dir))
    -> Path Abs Dir -> Const (Path Abs Dir) (Path Abs Dir))
-> Getting (Path Abs Dir) env (Path Abs Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path Abs Dir -> Path Abs Dir)
-> SimpleGetter (Path Abs Dir) (Path Abs Dir)
forall s a. (s -> a) -> SimpleGetter s a
to Path Abs Dir -> Path Abs Dir
implicitGlobalProjectDir

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

getSnapshots :: HasConfig env => RIO env Snapshots
getSnapshots :: forall env. HasConfig env => RIO env Snapshots
getSnapshots = do
  latestUrlText <- RIO env Text
forall env (m :: * -> *).
(MonadReader env m, HasConfig env) =>
m Text
askLatestSnapshotUrl
  latestUrl <- parseUrlThrow (T.unpack latestUrlText)
  logDebug $ "Downloading snapshot versions file from " <> display latestUrlText
  result <- httpJSON latestUrl
  logDebug "Done downloading and parsing snapshot versions file"
  pure $ getResponseBody result

-- | Turn an 'AbstractSnapshot' into a 'RawSnapshotLocation'.

makeConcreteSnapshot ::
     HasConfig env
  => AbstractSnapshot
  -> RIO env RawSnapshotLocation
makeConcreteSnapshot :: forall env.
HasConfig env =>
AbstractSnapshot -> RIO env RawSnapshotLocation
makeConcreteSnapshot (ASSnapshot RawSnapshotLocation
s) = RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshotLocation
s
makeConcreteSnapshot AbstractSnapshot
as = do
  s <-
    case AbstractSnapshot
as of
      AbstractSnapshot
ASGlobal -> do
        fp <- RIO env (Path Abs Dir)
forall env. HasConfig env => RIO env (Path Abs Dir)
getImplicitGlobalProjectDir RIO env (Path Abs Dir)
-> (Path Abs Dir -> Path Abs File) -> RIO env (Path Abs File)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (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)
        iopc <- loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp
        ProjectAndConfigMonoid project _ <- liftIO iopc
        pure project.snapshot
      AbstractSnapshot
ASLatestNightly ->
        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
      ASLatestLTSMajor Int
x -> do
        snapshots <- RIO env Snapshots
forall env. HasConfig env => RIO env Snapshots
getSnapshots
        case IntMap.lookup x 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
      AbstractSnapshot
ASLatestLTS -> do
        snapshots <- RIO env Snapshots
forall env. HasConfig env => RIO env Snapshots
getSnapshots
        if IntMap.null snapshots.lts
          then throwIO NoLTSFound
          else let (x, y) = IntMap.findMax snapshots.lts
               in  pure $ RSLSynonym $ LTS x y
  prettyInfoL
    [ flow "Selected snapshot:"
    , style Current (fromString $ T.unpack $ textDisplay s) <> "."
    ]
  pure s

-- | Get the raw snapshot from the global options.

getRawSnapshot :: HasConfig env => RIO env (Maybe RawSnapshot)
getRawSnapshot :: forall env. HasConfig env => RIO env (Maybe RawSnapshot)
getRawSnapshot = do
  mASnapshot <- Getting (Maybe AbstractSnapshot) env (Maybe AbstractSnapshot)
-> RIO env (Maybe AbstractSnapshot)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Maybe AbstractSnapshot) env (Maybe AbstractSnapshot)
 -> RIO env (Maybe AbstractSnapshot))
-> Getting (Maybe AbstractSnapshot) env (Maybe AbstractSnapshot)
-> RIO env (Maybe AbstractSnapshot)
forall a b. (a -> b) -> a -> b
$ (GlobalOpts -> Const (Maybe AbstractSnapshot) GlobalOpts)
-> env -> Const (Maybe AbstractSnapshot) env
forall env. HasRunner env => Lens' env GlobalOpts
Lens' env GlobalOpts
globalOptsL ((GlobalOpts -> Const (Maybe AbstractSnapshot) GlobalOpts)
 -> env -> Const (Maybe AbstractSnapshot) env)
-> ((Maybe AbstractSnapshot
     -> Const (Maybe AbstractSnapshot) (Maybe AbstractSnapshot))
    -> GlobalOpts -> Const (Maybe AbstractSnapshot) GlobalOpts)
-> Getting (Maybe AbstractSnapshot) env (Maybe AbstractSnapshot)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GlobalOpts -> Maybe AbstractSnapshot)
-> SimpleGetter GlobalOpts (Maybe AbstractSnapshot)
forall s a. (s -> a) -> SimpleGetter s a
to (.snapshot)
  forM mASnapshot $ \AbstractSnapshot
aSnapshot -> do
    concrete <- AbstractSnapshot -> RIO env RawSnapshotLocation
forall env.
HasConfig env =>
AbstractSnapshot -> RIO env RawSnapshotLocation
makeConcreteSnapshot AbstractSnapshot
aSnapshot
    loc <- completeSnapshotLocation concrete
    loadSnapshot loc

-- | Get the latest snapshot available.

getLatestSnapshot :: HasConfig env => RIO env RawSnapshotLocation
getLatestSnapshot :: forall env. HasConfig env => RIO env RawSnapshotLocation
getLatestSnapshot = do
  snapshots <- RIO env Snapshots
forall env. HasConfig env => RIO env Snapshots
getSnapshots
  let 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))
  pure $ RSLSynonym $ fromMaybe (Nightly snapshots.nightly) mlts

-- Interprets ConfigMonoid options.

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

  -> Path Abs File
     -- ^ User-specific global configuration file.

  -> Maybe AbstractSnapshot
  -> 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 AbstractSnapshot
-> ProjectConfig (Project, Path Abs File)
-> ConfigMonoid
-> (Config -> RIO env a)
-> RIO env a
configFromConfigMonoid
  Path Abs Dir
stackRoot
  Path Abs File
userGlobalConfigFile
  Maybe AbstractSnapshot
snapshot
  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"

    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 =
          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 [RawPackageLocationImmutable]
_deps -> Maybe (Project, Path Abs File)
forall a. Maybe a
Nothing
        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 [RawPackageLocationImmutable]
_ -> Bool
False
    configWorkDir0 <-
      let 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  maybe (pure relDirStackWork) (liftIO . parseStackWorkEnv) mstackWorkEnv
    let 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
        -- The history of the URL below is as follows:

        --

        -- * Before Stack 1.3.0 it was

        --   https://www.stackage.org/download/snapshots.json.

        -- * From Stack 1.3.0 to 2.15.3 it was

        --   https://s3.amazonaws.com/haddock.stackage.org/snapshots.json. The

        --   change was made because S3 was expected to have greater uptime than

        --   stackage.org.

        -- * In early 2024, the Stackage project was handed over to the Haskell

        --   Foundation. Following that handover, the URL below was considered

        --   the most reliable source of the file in question.

        latestSnapshot = Text -> First Text -> Text
forall a. a -> First a -> a
fromFirst
          Text
"https://stackage-haddock.haskell.org/snapshots.json"
          ConfigMonoid
configMonoid.latestSnapshot
        clConnectionCount = Int -> First Int -> Int
forall a. a -> First a -> a
fromFirst Int
8 ConfigMonoid
configMonoid.connectionCount
        hideTHLoading = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.hideTHLoading
        prefixTimestamps = Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst Bool
False ConfigMonoid
configMonoid.prefixTimestamps
        ghcVariant = First GHCVariant -> Maybe GHCVariant
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.ghcVariant
        compilerRepository = CompilerRepository
-> First CompilerRepository -> CompilerRepository
forall a. a -> First a -> a
fromFirst
          CompilerRepository
defaultCompilerRepository
          ConfigMonoid
configMonoid.compilerRepository
        compilerTarget = CompilerTarget -> First CompilerTarget -> CompilerTarget
forall a. a -> First a -> a
fromFirst
          CompilerTarget
defaultCompilerTarget
          ConfigMonoid
configMonoid.compilerTarget
        compilerBindistPath = CompilerBindistPath
-> First CompilerBindistPath -> CompilerBindistPath
forall a. a -> First a -> a
fromFirst
          CompilerBindistPath
defaultCompilerBindistPath
          ConfigMonoid
configMonoid.compilerBindistPath
        ghcBuild = First CompilerBuild -> Maybe CompilerBuild
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.ghcBuild
        installGHC = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.installGHC
        installMsys = Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst Bool
installGHC ConfigMonoid
configMonoid.installMsys
        skipGHCCheck = FirstFalse -> Bool
fromFirstFalse ConfigMonoid
configMonoid.skipGHCCheck
        skipMsys = FirstFalse -> Bool
fromFirstFalse ConfigMonoid
configMonoid.skipMsys
        defMsysEnvironment = case Platform
platform of
          Platform Arch
I386 OS
Windows -> MsysEnvironment -> Maybe MsysEnvironment
forall a. a -> Maybe a
Just MsysEnvironment
MINGW32
          Platform Arch
X86_64 OS
Windows -> MsysEnvironment -> Maybe MsysEnvironment
forall a. a -> Maybe a
Just MsysEnvironment
MINGW64
          Platform
_ -> Maybe MsysEnvironment
forall a. Maybe a
Nothing
        extraIncludeDirs = ConfigMonoid
configMonoid.extraIncludeDirs
        extraLibDirs = ConfigMonoid
configMonoid.extraLibDirs
        customPreprocessorExts = ConfigMonoid
configMonoid.customPreprocessorExts
        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 defArch defOS) = buildPlatform
        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
defOS
        platform = Arch -> OS -> Platform
Platform Arch
arch OS
os
        requireStackVersion = VersionRange -> VersionRange
simplifyVersionRange
          ConfigMonoid
configMonoid.requireStackVersion.intersectingVersionRange
        compilerCheck = VersionCheck -> First VersionCheck -> VersionCheck
forall a. a -> First a -> a
fromFirst VersionCheck
MatchMinor ConfigMonoid
configMonoid.compilerCheck
    msysEnvironment <- case defMsysEnvironment of
      -- Ignore the configuration setting if there is no default for the

      -- platform.

      Maybe MsysEnvironment
Nothing -> Maybe MsysEnvironment -> RIO env (Maybe MsysEnvironment)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe MsysEnvironment
forall a. Maybe a
Nothing
      Just MsysEnvironment
defMsysEnv -> do
        let msysEnv :: MsysEnvironment
msysEnv = MsysEnvironment -> First MsysEnvironment -> MsysEnvironment
forall a. a -> First a -> a
fromFirst MsysEnvironment
defMsysEnv ConfigMonoid
configMonoid.msysEnvironment
        if MsysEnvironment -> Arch
msysEnvArch MsysEnvironment
msysEnv Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
arch
          then Maybe MsysEnvironment -> RIO env (Maybe MsysEnvironment)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe MsysEnvironment -> RIO env (Maybe MsysEnvironment))
-> Maybe MsysEnvironment -> RIO env (Maybe MsysEnvironment)
forall a b. (a -> b) -> a -> b
$ MsysEnvironment -> Maybe MsysEnvironment
forall a. a -> Maybe a
Just MsysEnvironment
msysEnv
          else ConfigPrettyException -> RIO env (Maybe MsysEnvironment)
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (ConfigPrettyException -> RIO env (Maybe MsysEnvironment))
-> ConfigPrettyException -> RIO env (Maybe MsysEnvironment)
forall a b. (a -> b) -> a -> b
$ MsysEnvironment -> Arch -> ConfigPrettyException
BadMsysEnvironment MsysEnvironment
msysEnv Arch
arch
    platformVariant <- liftIO $
      maybe PlatformVariantNone PlatformVariant <$> lookupEnv platformVariantEnvVar
    let build = BuildOptsMonoid -> BuildOpts
buildOptsFromMonoid ConfigMonoid
configMonoid.buildOpts
    docker <-
      dockerOptsFromMonoid (fmap fst mproject) snapshot configMonoid.dockerOpts
    nix <- nixOptsFromMonoid configMonoid.nixOpts os
    systemGHC <-
      case (getFirst configMonoid.systemGHC, 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)
    when (isJust ghcVariant && systemGHC) $
      throwM ManualGHCVariantSettingsAreIncompatibleWithSystemGHC
    rawEnv <- liftIO getEnvironment
    pathsEnv <- either throwM pure
      $ augmentPathMap (map toFilePath configMonoid.extraPath)
                       (Map.fromList (map (T.pack *** T.pack) rawEnv))
    origEnv <- mkProcessContext pathsEnv
    let processContextSettings EnvSettings
_ = ProcessContext -> IO ProcessContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessContext
origEnv
    localProgramsBase <- case getFirst 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 = Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
localProgramsBase
        spaceInLocalProgramsPath = 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
        nonLatin1InLocalProgramsPath = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isLatin1 String
localProgramsFilePath
        problematicLocalProgramsPath =
             Bool
nonLatin1InLocalProgramsPath
          Bool -> Bool -> Bool
|| (Bool
osIsWindows Bool -> Bool -> Bool
&& Bool
spaceInLocalProgramsPath)
    when problematicLocalProgramsPath $ do
      let msgSpace =
            [ String -> StyleDoc
flow String
"It contains a space character. This will prevent building \
                   \with GHC 9.4.1 or later."
            | Bool
osIsWindows Bool -> Bool -> Bool
&& Bool
spaceInLocalProgramsPath
            ]
      msgNoShort <- if osIsWindows && spaceInLocalProgramsPath
        then do
          ensureDir localProgramsBase
          -- getShortPathName returns the long path name when a short name does not

          -- exist.

          shortLocalProgramsFilePath <-
            liftIO $ getShortPathName localProgramsFilePath
          pure [ flow "It also has no alternative short ('8 dot 3') name. This \
                      \will cause problems with packages that use the GNU \
                      \project's 'configure' shell script."
               | ' ' `elem` shortLocalProgramsFilePath
               ]
        else pure []
      let msgNonLatin1 = if Bool
nonLatin1InLocalProgramsPath
            then
              [ String -> StyleDoc
flow String
"It contains at least one non-ISO/IEC 8859-1 (Latin-1) \
                     \character (Unicode code point > 255). This will cause \
                     \problems with packages that build using the"
              , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"hsc2hs"
              , String -> StyleDoc
flow String
"tool with its default template"
              , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"template-hsc.h" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
              ]
            else []
      prettyWarn $
          "[S-8432]"
          <> line
          <> fillSep
               (  [ flow "Stack's 'programs' path is"
                  , style File (fromString localProgramsFilePath) <> "."
                  ]
               <> msgSpace
               <> msgNoShort
               <> msgNonLatin1
               )
          <> blankLine
          <> fillSep
               [ flow "To avoid such problems, use the"
               , style Shell "local-programs-path"
               , flow "non-project specific configuration option to specify an \
                      \alternative path without those characteristics."
               ]
          <> line
    platformOnlyDir <-
      runReaderT platformOnlyRelDir (platform, platformVariant)
    let 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
    localBin <-
      case getFirst configMonoid.localBinPath of
        Maybe String
Nothing -> do
          localDir <- String -> RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
getAppUserDataDir String
"local"
          pure $ localDir </> 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))
    fileWatchHook <-
      case getFirst configMonoid.fileWatchHook of
        Maybe String
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 Maybe (Path Abs File)
forall a. Maybe a
Nothing
        Just String
userPath ->
          ( case Maybe (Project, Path Abs File)
mproject of
              -- Not in a project

              Maybe (Project, Path Abs File)
Nothing -> Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just (Path Abs File -> Maybe (Path Abs File))
-> RIO env (Path Abs File) -> RIO env (Maybe (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
userPath
              -- Resolves to the project dir and appends the user path if it is

              -- relative

              Just (Project
_, Path Abs File
configYaml) ->
                Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just (Path Abs File -> Maybe (Path Abs File))
-> RIO env (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs Dir -> String -> RIO env (Path Abs File)
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Path Abs File)
resolveFile (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

          -- parseRelAsAbsFileMaybe utility and use it along with

          -- resolveFileMaybe.

          RIO env (Maybe (Path Abs File))
-> (SomeException -> RIO env (Maybe (Path Abs File)))
-> RIO env (Maybe (Path Abs File))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny`
          RIO env (Maybe (Path Abs File))
-> SomeException -> RIO env (Maybe (Path Abs File))
forall a b. a -> b -> a
const (ConfigException -> RIO env (Maybe (Path Abs File))
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (String -> ConfigException
NoSuchFile String
userPath))
    jobs <-
      case getFirst 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 -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst Bool
True ConfigMonoid
configMonoid.concurrentTests
        templateParams = ConfigMonoid
configMonoid.templateParameters
        scmInit = First SCM -> Maybe SCM
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.scmInit
        cabalConfigOpts = MonoidMap CabalConfigKey (Dual [Text]) -> Map CabalConfigKey [Text]
forall a b. Coercible a b => a -> b
coerce ConfigMonoid
configMonoid.cabalConfigOpts
        ghcOptionsByName = MonoidMap PackageName (Dual [Text]) -> Map PackageName [Text]
forall a b. Coercible a b => a -> b
coerce ConfigMonoid
configMonoid.ghcOptionsByName
        ghcOptionsByCat = MonoidMap ApplyGhcOptions (Dual [Text])
-> Map ApplyGhcOptions [Text]
forall a b. Coercible a b => a -> b
coerce ConfigMonoid
configMonoid.ghcOptionsByCat
        setupInfoLocations = ConfigMonoid
configMonoid.setupInfoLocations
        setupInfoInline = ConfigMonoid
configMonoid.setupInfoInline
        pvpBounds =
          PvpBounds -> First PvpBounds -> PvpBounds
forall a. a -> First a -> a
fromFirst (PvpBoundsType -> Bool -> PvpBounds
PvpBounds PvpBoundsType
PvpBoundsNone Bool
False) ConfigMonoid
configMonoid.pvpBounds
        modifyCodePage = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.modifyCodePage
        rebuildGhcOptions =
          FirstFalse -> Bool
fromFirstFalse ConfigMonoid
configMonoid.rebuildGhcOptions
        applyGhcOptions =
          ApplyGhcOptions -> First ApplyGhcOptions -> ApplyGhcOptions
forall a. a -> First a -> a
fromFirst ApplyGhcOptions
AGOLocals ConfigMonoid
configMonoid.applyGhcOptions
        applyProgOptions =
          ApplyProgOptions -> First ApplyProgOptions -> ApplyProgOptions
forall a. a -> First a -> a
fromFirst ApplyProgOptions
APOLocals ConfigMonoid
configMonoid.applyProgOptions
        allowNewer = ConfigMonoid
configMonoid.allowNewer
        allowNewerDeps = Maybe AllowNewerDeps -> Maybe [PackageName]
forall a b. Coercible a b => a -> b
coerce ConfigMonoid
configMonoid.allowNewerDeps
    defaultInitSnapshot <- do
      root <- getCurrentDir
      let resolve = (Maybe AbstractSnapshot -> First AbstractSnapshot
forall a. Maybe a -> First a
First (Maybe AbstractSnapshot -> First AbstractSnapshot)
-> RIO env (Maybe AbstractSnapshot)
-> RIO env (First AbstractSnapshot)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (RIO env (Maybe AbstractSnapshot)
 -> RIO env (First AbstractSnapshot))
-> (First (Unresolved AbstractSnapshot)
    -> RIO env (Maybe AbstractSnapshot))
-> First (Unresolved AbstractSnapshot)
-> RIO env (First AbstractSnapshot)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unresolved AbstractSnapshot -> RIO env AbstractSnapshot)
-> Maybe (Unresolved AbstractSnapshot)
-> RIO env (Maybe AbstractSnapshot)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (Maybe (Path Abs Dir)
-> Unresolved AbstractSnapshot -> RIO env AbstractSnapshot
forall (m :: * -> *) a.
MonadIO m =>
Maybe (Path Abs Dir) -> Unresolved a -> m a
resolvePaths (Path Abs Dir -> Maybe (Path Abs Dir)
forall a. a -> Maybe a
Just Path Abs Dir
root)) (Maybe (Unresolved AbstractSnapshot)
 -> RIO env (Maybe AbstractSnapshot))
-> (First (Unresolved AbstractSnapshot)
    -> Maybe (Unresolved AbstractSnapshot))
-> First (Unresolved AbstractSnapshot)
-> RIO env (Maybe AbstractSnapshot)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. First (Unresolved AbstractSnapshot)
-> Maybe (Unresolved AbstractSnapshot)
forall a. First a -> Maybe a
getFirst
      resolve configMonoid.defaultInitSnapshot
    let defaultTemplate = First TemplateName -> Maybe TemplateName
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.defaultTemplate
        dumpLogs = DumpLogs -> First DumpLogs -> DumpLogs
forall a. a -> First a -> a
fromFirst DumpLogs
DumpWarningLogs ConfigMonoid
configMonoid.dumpLogs
        saveHackageCreds = ConfigMonoid
configMonoid.saveHackageCreds
        hackageBaseUrl =
          Text -> First Text -> Text
forall a. a -> First a -> a
fromFirst Text
Constants.hackageBaseUrl ConfigMonoid
configMonoid.hackageBaseUrl
        hideSourcePaths = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.hideSourcePaths
        recommendStackUpgrade = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.recommendStackUpgrade
        notifyIfNixOnPath = FirstFalse -> Bool
fromFirstFalse ConfigMonoid
configMonoid.notifyIfNixOnPath
        notifyIfGhcUntested = FirstFalse -> Bool
fromFirstFalse ConfigMonoid
configMonoid.notifyIfGhcUntested
        notifyIfCabalUntested = FirstFalse -> Bool
fromFirstFalse ConfigMonoid
configMonoid.notifyIfCabalUntested
        notifyIfArchUnknown = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.notifyIfArchUnknown
        notifyIfNoRunTests = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.notifyIfNoRunTests
        notifyIfNoRunBenchmarks =
          FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.notifyIfNoRunBenchmarks
        notifyIfBaseNotBoot =
          FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.notifyIfBaseNotBoot
        noRunCompile = FirstFalse -> Bool
fromFirstFalse ConfigMonoid
configMonoid.noRunCompile
    allowDifferentUser <-
      case getFirst 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
    configRunner' <- view runnerL
    useAnsi <- liftIO $ hNowSupportsANSI stderr
    let 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' = Runner
configRunner'.useColor
        mUseColor =
          First ColorWhen -> Maybe ColorWhen
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.colorWhen Maybe ColorWhen -> (ColorWhen -> Bool) -> Maybe Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
            ColorWhen
ColorNever  -> Bool
False
            ColorWhen
ColorAlways -> Bool
True
            ColorWhen
ColorAuto  -> Bool
useAnsi
        useColor'' = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
useColor' Maybe Bool
mUseColor
        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 = Runner
configRunner'.globalOpts
        pic = PackageIndexConfig
-> First PackageIndexConfig -> PackageIndexConfig
forall a. a -> First a -> a
fromFirst  PackageIndexConfig
defaultPackageIndexConfig ConfigMonoid
configMonoid.packageIndex
    pantryRoot <- liftIO (lookupEnv pantryRootEnvVar) >>= \case
      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 =
          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
    globalHintsLoc <- case getFirst configMonoid.globalHintsLocation of
      Maybe (Unresolved GlobalHintsLocation)
Nothing -> (WantedCompiler -> GlobalHintsLocation)
-> RIO env (WantedCompiler -> GlobalHintsLocation)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WantedCompiler -> GlobalHintsLocation
defaultGlobalHintsLocation
      Just Unresolved GlobalHintsLocation
unresolverGlobalHintsLoc -> do
        resolvedGlobalHintsLocation <-
          Maybe (Path Abs Dir)
-> Unresolved GlobalHintsLocation -> RIO env GlobalHintsLocation
forall (m :: * -> *) a.
MonadIO m =>
Maybe (Path Abs Dir) -> Unresolved a -> m a
resolvePaths (Path Abs Dir -> Maybe (Path Abs Dir)
forall a. a -> Maybe a
Just Path Abs Dir
stackRoot) Unresolved GlobalHintsLocation
unresolverGlobalHintsLoc
        pure $ const resolvedGlobalHintsLocation
    let stackDeveloperMode = Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst
          Bool
stackDeveloperModeDefault
          ConfigMonoid
configMonoid.stackDeveloperMode
        hpackForce = if FirstFalse -> Bool
fromFirstFalse ConfigMonoid
configMonoid.hpackForce
          then Force
Hpack.Force
          else Force
Hpack.NoForce
        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
    withNewLogFunc go useColor'' stylesUpdate' $ \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
-> Force
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (WantedCompiler -> GlobalHintsLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
forall env a.
HasLogFunc env =>
Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Force
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (WantedCompiler -> GlobalHintsLocation)
-> (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)
          Force
hpackForce
          Int
clConnectionCount
          Maybe (CasaRepoPrefix, Int)
casa
          SnapName -> RawSnapshotLocation
snapLoc
          WantedCompiler -> GlobalHintsLocation
globalHintsLoc
          (\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
workDir :: Path Rel Dir
workDir
                , Path Abs File
userGlobalConfigFile :: Path Abs File
userGlobalConfigFile :: Path Abs File
userGlobalConfigFile
                , BuildOpts
build :: BuildOpts
build :: BuildOpts
build
                , DockerOpts
docker :: DockerOpts
docker :: DockerOpts
docker
                , NixOpts
nix :: NixOpts
nix :: NixOpts
nix
                , EnvSettings -> IO ProcessContext
processContextSettings :: EnvSettings -> IO ProcessContext
processContextSettings :: EnvSettings -> IO ProcessContext
processContextSettings
                , Path Abs Dir
localProgramsBase :: Path Abs Dir
localProgramsBase :: Path Abs Dir
localProgramsBase
                , Path Abs Dir
localPrograms :: Path Abs Dir
localPrograms :: Path Abs Dir
localPrograms
                , Bool
hideTHLoading :: Bool
hideTHLoading :: Bool
hideTHLoading
                , Bool
prefixTimestamps :: Bool
prefixTimestamps :: Bool
prefixTimestamps
                , Platform
platform :: Platform
platform :: Platform
platform
                , PlatformVariant
platformVariant :: PlatformVariant
platformVariant :: PlatformVariant
platformVariant
                , Maybe GHCVariant
ghcVariant :: Maybe GHCVariant
ghcVariant :: Maybe GHCVariant
ghcVariant
                , Maybe CompilerBuild
ghcBuild :: Maybe CompilerBuild
ghcBuild :: Maybe CompilerBuild
ghcBuild
                , Text
latestSnapshot :: Text
latestSnapshot :: Text
latestSnapshot
                , Bool
systemGHC :: Bool
systemGHC :: Bool
systemGHC
                , Bool
installGHC :: Bool
installGHC :: Bool
installGHC
                , Bool
installMsys :: Bool
installMsys :: Bool
installMsys
                , Bool
skipGHCCheck :: Bool
skipGHCCheck :: Bool
skipGHCCheck
                , Bool
skipMsys :: Bool
skipMsys :: Bool
skipMsys
                , Maybe MsysEnvironment
msysEnvironment :: Maybe MsysEnvironment
msysEnvironment :: Maybe MsysEnvironment
msysEnvironment
                , VersionCheck
compilerCheck :: VersionCheck
compilerCheck :: VersionCheck
compilerCheck
                , CompilerRepository
compilerRepository :: CompilerRepository
compilerRepository :: CompilerRepository
compilerRepository
                , CompilerTarget
compilerTarget :: CompilerTarget
compilerTarget :: CompilerTarget
compilerTarget
                , CompilerBindistPath
compilerBindistPath :: CompilerBindistPath
compilerBindistPath :: CompilerBindistPath
compilerBindistPath
                , Path Abs Dir
localBin :: Path Abs Dir
localBin :: Path Abs Dir
localBin
                , Maybe (Path Abs File)
fileWatchHook :: Maybe (Path Abs File)
fileWatchHook :: Maybe (Path Abs File)
fileWatchHook
                , VersionRange
requireStackVersion :: VersionRange
requireStackVersion :: VersionRange
requireStackVersion
                , Int
jobs :: Int
jobs :: Int
jobs
                , Maybe (Path Abs File)
overrideGccPath :: Maybe (Path Abs File)
overrideGccPath :: Maybe (Path Abs File)
overrideGccPath
                , [String]
extraIncludeDirs :: [String]
extraIncludeDirs :: [String]
extraIncludeDirs
                , [String]
extraLibDirs :: [String]
extraLibDirs :: [String]
extraLibDirs
                , [Text]
customPreprocessorExts :: [Text]
customPreprocessorExts :: [Text]
customPreprocessorExts
                , Bool
concurrentTests :: Bool
concurrentTests :: Bool
concurrentTests
                , Map Text Text
templateParams :: Map Text Text
templateParams :: Map Text Text
templateParams
                , Maybe SCM
scmInit :: Maybe SCM
scmInit :: Maybe SCM
scmInit
                , Map PackageName [Text]
ghcOptionsByName :: Map PackageName [Text]
ghcOptionsByName :: Map PackageName [Text]
ghcOptionsByName
                , Map ApplyGhcOptions [Text]
ghcOptionsByCat :: Map ApplyGhcOptions [Text]
ghcOptionsByCat :: Map ApplyGhcOptions [Text]
ghcOptionsByCat
                , Map CabalConfigKey [Text]
cabalConfigOpts :: Map CabalConfigKey [Text]
cabalConfigOpts :: Map CabalConfigKey [Text]
cabalConfigOpts
                , [String]
setupInfoLocations :: [String]
setupInfoLocations :: [String]
setupInfoLocations
                , SetupInfo
setupInfoInline :: SetupInfo
setupInfoInline :: SetupInfo
setupInfoInline
                , PvpBounds
pvpBounds :: PvpBounds
pvpBounds :: PvpBounds
pvpBounds
                , Bool
modifyCodePage :: Bool
modifyCodePage :: Bool
modifyCodePage
                , Bool
rebuildGhcOptions :: Bool
rebuildGhcOptions :: Bool
rebuildGhcOptions
                , ApplyGhcOptions
applyGhcOptions :: ApplyGhcOptions
applyGhcOptions :: ApplyGhcOptions
applyGhcOptions
                , ApplyProgOptions
applyProgOptions :: ApplyProgOptions
applyProgOptions :: ApplyProgOptions
applyProgOptions
                , First Bool
allowNewer :: First Bool
allowNewer :: First Bool
allowNewer
                , Maybe [PackageName]
allowNewerDeps :: Maybe [PackageName]
allowNewerDeps :: Maybe [PackageName]
allowNewerDeps
                , First AbstractSnapshot
defaultInitSnapshot :: First AbstractSnapshot
defaultInitSnapshot :: First AbstractSnapshot
defaultInitSnapshot
                , Maybe TemplateName
defaultTemplate :: Maybe TemplateName
defaultTemplate :: Maybe TemplateName
defaultTemplate
                , Bool
allowDifferentUser :: Bool
allowDifferentUser :: Bool
allowDifferentUser
                , DumpLogs
dumpLogs :: DumpLogs
dumpLogs :: DumpLogs
dumpLogs
                , ProjectConfig (Project, Path Abs File)
project :: ProjectConfig (Project, Path Abs File)
project :: ProjectConfig (Project, Path Abs File)
project
                , Bool
allowLocals :: Bool
allowLocals :: Bool
allowLocals
                , FirstTrue
saveHackageCreds :: FirstTrue
saveHackageCreds :: FirstTrue
saveHackageCreds
                , Text
hackageBaseUrl :: Text
hackageBaseUrl :: Text
hackageBaseUrl
                , Runner
runner :: Runner
runner :: Runner
runner
                , PantryConfig
pantryConfig :: PantryConfig
pantryConfig :: PantryConfig
pantryConfig
                , Path Abs Dir
stackRoot :: Path Abs Dir
stackRoot :: Path Abs Dir
stackRoot
                , Maybe AbstractSnapshot
snapshot :: Maybe AbstractSnapshot
snapshot :: Maybe AbstractSnapshot
snapshot
                , UserStorage
userStorage :: UserStorage
userStorage :: UserStorage
userStorage
                , Bool
hideSourcePaths :: Bool
hideSourcePaths :: Bool
hideSourcePaths
                , Bool
recommendStackUpgrade :: Bool
recommendStackUpgrade :: Bool
recommendStackUpgrade
                , Bool
notifyIfNixOnPath :: Bool
notifyIfNixOnPath :: Bool
notifyIfNixOnPath
                , Bool
notifyIfGhcUntested :: Bool
notifyIfGhcUntested :: Bool
notifyIfGhcUntested
                , Bool
notifyIfCabalUntested :: Bool
notifyIfCabalUntested :: Bool
notifyIfCabalUntested
                , Bool
notifyIfArchUnknown :: Bool
notifyIfArchUnknown :: Bool
notifyIfArchUnknown
                , Bool
notifyIfNoRunTests :: Bool
notifyIfNoRunTests :: Bool
notifyIfNoRunTests
                , Bool
notifyIfNoRunBenchmarks :: Bool
notifyIfNoRunBenchmarks :: Bool
notifyIfNoRunBenchmarks
                , Bool
notifyIfBaseNotBoot :: Bool
notifyIfBaseNotBoot :: Bool
notifyIfBaseNotBoot
                , Bool
noRunCompile :: Bool
noRunCompile :: Bool
noRunCompile
                , Bool
stackDeveloperMode :: Bool
stackDeveloperMode :: Bool
stackDeveloperMode
                , Maybe (CasaRepoPrefix, Int)
casa :: Maybe (CasaRepoPrefix, Int)
casa :: 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 t'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
  logOptions0 <- Handle -> Bool -> m LogOptions
forall (m :: * -> *). MonadIO m => Handle -> Bool -> m LogOptions
logOptionsHandle Handle
stderr Bool
False
  let 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
  withLogFunc logOptions 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
  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)
  mproject <- loadProjectConfig mstackYaml
  mASnapshot <- view $ globalOptsL . to (.snapshot)
  configArgs <- view $ globalOptsL . to (.configMonoid)
  (configRoot, stackRoot, userOwnsStackRoot) <-
    determineStackRootAndOwnership configArgs

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

  userConfigPath <- getDefaultUserConfigPath configRoot
  extraConfigs0 <- getExtraConfigs userConfigPath >>=
    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 =
        -- 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 =
        Path Abs Dir
-> Path Abs File
-> Maybe AbstractSnapshot
-> 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 AbstractSnapshot
-> ProjectConfig (Project, Path Abs File)
-> ConfigMonoid
-> (Config -> RIO env a)
-> RIO env a
configFromConfigMonoid
          Path Abs Dir
stackRoot
          Path Abs File
userConfigPath
          Maybe AbstractSnapshot
mASnapshot
          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)

  withConfig $ \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 <- RIO Config Config
forall r (m :: * -> *). MonadReader r m => m r
ask

  -- If provided, turn the AbstractSnapshot from the command line into a

  -- snapshot that can be used below.


  -- The snapshot and mcompiler are provided on the command line. In order

  -- to properly deal with an AbstractSnapshot, 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 mSnapshot first.

  mSnapshot <- forM config.snapshot $ \AbstractSnapshot
aSnapshot -> do
    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 snapshot: "
       Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> AbstractSnapshot -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display AbstractSnapshot
aSnapshot
       Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" specified on command line"
    AbstractSnapshot -> RIO Config RawSnapshotLocation
forall env.
HasConfig env =>
AbstractSnapshot -> RIO env RawSnapshotLocation
makeConcreteSnapshot AbstractSnapshot
aSnapshot

  (project', configFile) <- case 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 ()
prettyUserMessage
      (Project, Either (Path Abs File) (Path Abs File))
-> RIO Config (Project, Either (Path Abs File) (Path Abs File))
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Project
project, Path Abs File -> Either (Path Abs File) (Path Abs File)
forall a b. b -> Either a b
Right Path Abs File
fp)
    PCNoProject [RawPackageLocationImmutable]
extraDeps -> do
      p <-
        case Maybe RawSnapshotLocation
mSnapshot of
          Maybe RawSnapshotLocation
Nothing -> ConfigException -> RIO Config Project
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ConfigException
NoSnapshotWhenUsingNoProject
          Just RawSnapshotLocation
_ -> Maybe RawSnapshotLocation
-> [RawPackageLocationImmutable] -> RIO Config Project
getEmptyProject Maybe RawSnapshotLocation
mSnapshot [RawPackageLocationImmutable]
extraDeps
      pure (p, Left config.userGlobalConfigFile)
    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"
      destDir <- RIO Config (Path Abs Dir)
forall env. HasConfig env => RIO env (Path Abs Dir)
getImplicitGlobalProjectDir
      let 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' = Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
dest
      ensureDir destDir
      exists <- doesFileExist dest
      if exists
        then do
          iopc <- loadConfigYaml (parseProjectAndConfigMonoid destDir) dest
          ProjectAndConfigMonoid project _ <- liftIO iopc
          when (view terminalL config) $
            case config.snapshot of
              Maybe AbstractSnapshot
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 snapshot: "
                  Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Project
project.snapshot
                  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 AbstractSnapshot
_ -> () -> RIO Config ()
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          pure (project, Right dest)
        else do
          prettyInfoL
            [ flow "Writing the configuration file for the implicit \
                   \global project to:"
            , pretty dest <> "."
            , flow "Note: You can change the snapshot via the"
            , style Shell "snapshot"
            , flow "key there."
            ]
          p <- getEmptyProject mSnapshot []
          liftIO $ do
            writeBinaryFileAtomic dest $ byteString $ S.concat
              [ "# This is the implicit global project's configuration file, which is only used\n"
              , "# when 'stack' is run outside of a real project. Settings here do _not_ act as\n"
              , "# defaults for all projects. To change Stack's default settings, edit\n"
              , "# '", encodeUtf8 (T.pack $ toFilePath config.userGlobalConfigFile), "' instead.\n"
              , "#\n"
              , "# For more information about Stack's configuration, see\n"
              , "# http://docs.haskellstack.org/en/stable/configure/yaml/\n"
              , "#\n"
              , Yaml.encode p]
            writeBinaryFileAtomic (parent dest </> relFileReadmeTxt) $
              "This is the implicit global project, which is " <>
              "used only when 'stack' is run\noutside of a " <>
              "real project.\n"
          pure (p, Right dest)
  mcompiler <- view $ globalOptsL . to (.compiler)
  let project :: Project
      project = Project
project'
        { Project.compiler = mcompiler <|> project'.compiler
        , Project.snapshot = fromMaybe project'.snapshot mSnapshot
        }
      -- We are indifferent as to whether the configuration file is a

      -- user-specific global or a project-level one.

      eitherConfigFile = Either (Path Abs File) (Path Abs File) -> Path Abs File
forall a. Either a a -> a
EE.fromEither Either (Path Abs File) (Path Abs File)
configFile
  extraPackageDBs <- mapM resolveDir' project.extraPackageDBs

  smWanted <- lockCachedWanted eitherConfigFile project.snapshot $
    fillProjectWanted eitherConfigFile config project

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

  workDir <- view workDirL
  let projectStorageFile = Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
eitherConfigFile 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

  initProjectStorage projectStorageFile $ \ProjectStorage
projectStorage -> do
    let bc :: BuildConfig
bc = BuildConfig
          { Config
config :: Config
config :: Config
config
          , SMWanted
smWanted :: SMWanted
smWanted :: SMWanted
smWanted
          , [Path Abs Dir]
extraPackageDBs :: [Path Abs Dir]
extraPackageDBs :: [Path Abs Dir]
extraPackageDBs
          , Either (Path Abs File) (Path Abs File)
configFile :: Either (Path Abs File) (Path Abs File)
configFile :: Either (Path Abs File) (Path Abs File)
configFile
          , curator :: Maybe Curator
curator = Project
project.curator
          , ProjectStorage
projectStorage :: ProjectStorage
projectStorage :: 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
    -> [RawPackageLocationImmutable]
    -> RIO Config Project
  getEmptyProject :: Maybe RawSnapshotLocation
-> [RawPackageLocationImmutable] -> RIO Config Project
getEmptyProject Maybe RawSnapshotLocation
mSnapshot [RawPackageLocationImmutable]
extraDeps = do
    snapshot <- case Maybe RawSnapshotLocation
mSnapshot of
      Just RawSnapshotLocation
snapshot -> 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
snapshot)
          , 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
snapshot
      Maybe RawSnapshotLocation
Nothing -> do
        r'' <- RIO Config RawSnapshotLocation
forall env. HasConfig env => RIO env RawSnapshotLocation
getLatestSnapshot
        prettyInfoL
          [ flow "Using the latest snapshot"
          , style Current (fromString $ T.unpack $ textDisplay r'') <> "."
          ]
        pure r''
    pure Project
      { userMsg = Nothing
      , packages = []
      , extraDeps = map RPLImmutable extraDeps
      , flagsByPkg = mempty
      , snapshot
      , compiler = Nothing
      , extraPackageDBs = []
      , curator = Nothing
      , dropPackages = mempty
      }
  prettyUserMessage :: String -> RIO Config ()
  prettyUserMessage :: String -> RIO Config ()
prettyUserMessage String
userMsg = do
    let userMsgs :: [StyleDoc]
userMsgs = (String -> StyleDoc) -> [String] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> StyleDoc
flow ([String] -> [StyleDoc]) -> [String] -> [StyleDoc]
forall a b. (a -> b) -> a -> b
$ String -> [String]
splitAtLineEnds String
userMsg
        warningDoc :: StyleDoc
warningDoc = [StyleDoc] -> StyleDoc
forall a. Monoid a => [a] -> a
mconcat ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
intersperse StyleDoc
blankLine [StyleDoc]
userMsgs
    StyleDoc -> RIO Config ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn StyleDoc
warningDoc
   where
    splitAtLineEnds :: String -> [String]
splitAtLineEnds = [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
forall a. [a] -> [a]
reverse ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String -> [String]
go []
     where
      go :: [String] -> String -> [String]
      go :: [String] -> String -> [String]
go [String]
ss [] = [String]
ss
      go [String]
ss String
s = case String -> String -> (String, String)
go' [] String
s of
        ([], String
rest) -> [String] -> String -> [String]
go [String]
ss String
rest
        (String
s', String
rest) -> [String] -> String -> [String]
go (String
s' String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
ss) String
rest
      go' :: String -> String -> (String, String)
      go' :: String -> String -> (String, String)
go' String
s [] = (String
s, [])
      go' String
s [Char
c] = (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
s, [])
      go' String
s String
"\n\n" = (String
s, [])
      go' String
s [Char
c1, Char
c2] = (Char
c2Char -> String -> String
forall a. a -> [a] -> [a]
:Char
c1Char -> String -> String
forall a. a -> [a] -> [a]
:String
s, [])
      go' String
s (Char
'\n':Char
'\n':String
rest) = (String
s, String -> String
stripLineEnds String
rest)
      go' String
s (Char
'\n':Char
'\r':Char
'\n':String
rest) = (String
s, String -> String
stripLineEnds String
rest)
      go' String
s (Char
'\r':Char
'\n':Char
'\n':String
rest) = (String
s, String -> String
stripLineEnds String
rest)
      go' String
s (Char
'\r':Char
'\n':Char
'\r':Char
'\n':String
rest) = (String
s, String -> String
stripLineEnds String
rest)
      go' String
s (Char
c:String
rest) = String -> String -> (String, String)
go' (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
s) String
rest
      stripLineEnds :: String -> String
      stripLineEnds :: String -> String
stripLineEnds (Char
'\n':String
rest) = String -> String
stripLineEnds String
rest
      stripLineEnds (Char
'\r':Char
'\n':String
rest) = String -> String
stripLineEnds String
rest
      stripLineEnds String
rest = String
rest

fillProjectWanted ::
     (HasLogFunc env, HasPantryConfig env, HasProcessContext env)
  => Path Abs File
     -- ^ Location of the configuration file, which may be either a

     -- user-specific global or a project-level one.

  -> Config
  -> Project
  -> Map RawPackageLocationImmutable PackageLocationImmutable
  -> WantedCompiler
  -> Map PackageName (Bool -> RIO env DepPackage)
  -> RIO env (SMWanted, [CompletedPLI])
fillProjectWanted :: forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
Path Abs File
-> Config
-> Project
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO env DepPackage)
-> RIO env (SMWanted, [CompletedPLI])
fillProjectWanted Path Abs File
configFile 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

  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
    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 File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
configFile) (Text -> String
T.unpack Text
t)
    let resolved = RelFilePath -> Path Abs Dir -> ResolvedPath Dir
forall t. RelFilePath -> Path Abs t -> ResolvedPath t
ResolvedPath RelFilePath
fp Path Abs Dir
abs'
    pp <- mkProjectPackage YesPrintWarnings resolved bopts.buildHaddocks
    pure (pp.projectCommon.name, pp)

  -- prefetch git repos to avoid cloning per subdirectory

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

  let 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
  logDebug ("Prefetching git repos: " <> display (T.pack (show gitRepos)))
  fetchReposRaw gitRepos

  (deps0, mcompleted) <- fmap unzip . forM project.extraDeps $ \RawPackageLocation
rpl -> do
    (pl, mCompleted) <- case RawPackageLocation
rpl of
       RPLImmutable RawPackageLocationImmutable
rpli -> do
         (compl, 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
               cpl <- RawPackageLocationImmutable -> RIO env CompletePackageLocation
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env CompletePackageLocation
completePackageLocation RawPackageLocationImmutable
rpli
               if cplHasCabalFile cpl
                 then pure (cplComplete cpl, Just $ cplComplete cpl)
                 else do
                   warnMissingCabalFile rpli
                   pure (cplComplete cpl, Nothing)
         pure (PLImmutable compl, CompletedPLI rpli <$> 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)
    dp <- additionalDepPackage (shouldHaddockDeps bopts) pl
    pure ((dp.depCommon.name, dp), mCompleted)

  checkDuplicateNames $
    map (second (PLMutable . (.resolvedDir))) packages0 ++
    map (second (.location)) deps0

  let 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)
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

  snDeps <- for snPackages $ \Bool -> RIO env DepPackage
getDep -> Bool -> RIO env DepPackage
getDep (BuildOpts -> Bool
shouldHaddockDeps BuildOpts
bopts)

  let 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
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 = Project
project.flagsByPkg
      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
-> 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 } }

  checkFlagsUsedThrowing pFlags packages1 deps1

  let pkgGhcOptions = Config
config.ghcOptionsByName
      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
-> 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]
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

  unless (Map.null unusedPkgGhcOptions) $
    throwM $ InvalidGhcOptionsSpecification (Map.keys unusedPkgGhcOptions)

  let wanted = SMWanted
        { compiler :: WantedCompiler
compiler = WantedCompiler -> Maybe WantedCompiler -> WantedCompiler
forall a. a -> Maybe a -> a
fromMaybe WantedCompiler
snapCompiler Project
project.compiler
        , project :: Map PackageName ProjectPackage
project = Map PackageName ProjectPackage
packages
        , deps :: Map PackageName DepPackage
deps = Map PackageName DepPackage
deps
        , snapshotLocation :: RawSnapshotLocation
snapshotLocation = Project
project.snapshot
        }

  pure (wanted, catMaybes mcompleted)

-- | Check if a package is a project package or a dependency and, if it is,

-- if all the specified flags are defined in the package's Cabal file.

checkFlagsUsedThrowing ::
     forall m. (MonadIO m, MonadThrow m)
  => Map PackageName (Map FlagName Bool)
  -> Map PackageName ProjectPackage
  -> Map PackageName DepPackage
  -> m ()
checkFlagsUsedThrowing :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Map PackageName (Map FlagName Bool)
-> Map PackageName ProjectPackage
-> Map PackageName DepPackage
-> m ()
checkFlagsUsedThrowing Map PackageName (Map FlagName Bool)
packageFlags Map PackageName ProjectPackage
projectPackages Map PackageName DepPackage
deps = do
  unusedFlags <- [(PackageName, Map FlagName Bool)]
-> ((PackageName, Map FlagName Bool) -> m (Maybe UnusedFlags))
-> m [UnusedFlags]
forall (m :: * -> *) a b.
Monad m =>
[a] -> (a -> m (Maybe b)) -> m [b]
forMaybeM (Map PackageName (Map FlagName Bool)
-> [(PackageName, Map FlagName Bool)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName (Map FlagName Bool)
packageFlags) (PackageName, Map FlagName Bool) -> m (Maybe UnusedFlags)
getUnusedPackageFlags
  unless (null unusedFlags) $
    prettyThrowM $ InvalidFlagSpecification unusedFlags
 where
  getUnusedPackageFlags ::
       (PackageName, Map FlagName Bool)
    -> m (Maybe UnusedFlags)
  getUnusedPackageFlags :: (PackageName, Map FlagName Bool) -> m (Maybe UnusedFlags)
getUnusedPackageFlags (PackageName
name, Map FlagName Bool
userFlags) = case Maybe CommonPackage
maybeCommon of
    -- Package is not available as project or dependency

    Maybe CommonPackage
Nothing -> Maybe UnusedFlags -> m (Maybe UnusedFlags)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe UnusedFlags -> m (Maybe UnusedFlags))
-> Maybe UnusedFlags -> m (Maybe UnusedFlags)
forall a b. (a -> b) -> a -> b
$ UnusedFlags -> Maybe UnusedFlags
forall a. a -> Maybe a
Just (UnusedFlags -> Maybe UnusedFlags)
-> UnusedFlags -> Maybe UnusedFlags
forall a b. (a -> b) -> a -> b
$ FlagSource -> PackageName -> UnusedFlags
UFNoPackage FlagSource
FSStackYaml PackageName
name
    -- Package exists, let's check if the flags are defined

    Just CommonPackage
common -> do
      gpd <- IO GenericPackageDescription -> m GenericPackageDescription
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO CommonPackage
common.gpd
      let pname = PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> PackageIdentifier -> PackageName
forall a b. (a -> b) -> a -> b
$ PackageDescription -> PackageIdentifier
PD.package (PackageDescription -> PackageIdentifier)
-> PackageDescription -> PackageIdentifier
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
PD.packageDescription GenericPackageDescription
gpd
          pkgFlags = [FlagName] -> Set FlagName
forall a. Ord a => [a] -> Set a
Set.fromList ([FlagName] -> Set FlagName) -> [FlagName] -> Set FlagName
forall a b. (a -> b) -> a -> b
$ (PackageFlag -> FlagName) -> [PackageFlag] -> [FlagName]
forall a b. (a -> b) -> [a] -> [b]
map PackageFlag -> FlagName
PD.flagName ([PackageFlag] -> [FlagName]) -> [PackageFlag] -> [FlagName]
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> [PackageFlag]
PD.genPackageFlags GenericPackageDescription
gpd
          unused = Map FlagName Bool -> Set FlagName
forall k a. Map k a -> Set k
Map.keysSet (Map FlagName Bool -> Set FlagName)
-> Map FlagName Bool -> Set FlagName
forall a b. (a -> b) -> a -> b
$ Map FlagName Bool -> Set FlagName -> Map FlagName Bool
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.withoutKeys Map FlagName Bool
userFlags Set FlagName
pkgFlags
      pure $ if Set.null unused
        -- All flags are defined, nothing to do

        then Nothing
        -- Error about the undefined flags

        else Just $ UFFlagsNotDefined FSStackYaml pname pkgFlags unused
   where
    maybeCommon :: Maybe CommonPackage
maybeCommon =     (ProjectPackage -> CommonPackage)
-> Maybe ProjectPackage -> Maybe CommonPackage
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (.projectCommon) (PackageName
-> Map PackageName ProjectPackage -> Maybe ProjectPackage
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName ProjectPackage
projectPackages)
                  Maybe CommonPackage -> Maybe CommonPackage -> Maybe CommonPackage
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (DepPackage -> CommonPackage)
-> Maybe DepPackage -> Maybe CommonPackage
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (.depCommon) (PackageName -> Map PackageName DepPackage -> Maybe DepPackage
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName DepPackage
deps)

-- | 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
  (configRoot, stackRoot) <-
    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 ->
        String -> IO (Maybe String)
lookupEnv String
stackRootEnvVar IO (Maybe String)
-> (Maybe String -> IO (Path Abs Dir, Path Abs Dir))
-> IO (Path Abs Dir, Path Abs Dir)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe String
Nothing -> do
            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 not (null wantXdg)
              then do
                xdgRelDir <- parseRelDir stackProgName
                (,)
                  <$> getXdgDir XdgConfig (Just xdgRelDir)
                  <*> getXdgDir XdgData (Just xdgRelDir)
              else do
                oldStyleRoot <- getAppUserDataDir stackProgName
                pure (oldStyleRoot, 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)

  (existingStackRootOrParentDir, userOwnsIt) <-
    findInParents getDirAndOwnership stackRoot >>= \case
      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)

  when (existingStackRootOrParentDir /= stackRoot) $
    if userOwnsIt
      then ensureDir stackRoot
      else throwIO $
        Won'tCreateStackRootInDirectoryOwnedByDifferentUser
          stackRoot
          existingStackRootOrParentDir

  configRoot' <- canonicalizePath configRoot
  stackRoot' <- canonicalizePath stackRoot
  pure (configRoot', stackRoot', 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 =
  (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] m (Maybe (Path Abs Dir, Bool))
-> (Maybe (Path Abs Dir, Bool) -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    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
    ownership <- Path Abs Dir -> IO Bool
forall (m :: * -> *) t. MonadIO m => Path Abs t -> m Bool
isOwnedByUser Path Abs Dir
dir
    pure (dir, ownership)

-- | Check whether the current user (determined with

-- 'System.Posix.User.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 <- String -> IO FileStatus
getFileStatus (Path Abs t -> String
forall b t. Path b t -> String
toFilePath Path Abs t
path)
      user <- getEffectiveUserID
      pure (user == fileOwner 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 = 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
  env <- IO [(String, String)]
getEnvironment
  mstackConfig <-
      maybe (pure Nothing) (fmap Just . parseAbsFile)
    $ lookup "STACK_CONFIG" env
  mstackGlobalConfig <-
      maybe (pure Nothing) (fmap Just . parseAbsFile)
    $ lookup "STACK_GLOBAL_CONFIG" env
  filterM doesFileExist
    $ fromMaybe userConfigPath mstackConfig
    : maybe [] pure (mstackGlobalConfig <|> defaultGlobalConfigPath)

-- | 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 = (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 RIO env (Either ParseException a)
-> (Either ParseException a -> RIO env a) -> RIO env a
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  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 =
  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 (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)) RIO env (Either ParseException Value)
-> (Either ParseException Value
    -> RIO env (Either ParseException a))
-> RIO env (Either ParseException a)
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    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
  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 lookup "STACK_YAML" 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
      currDir <- RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
      maybe PCGlobalProject PCProject <$> findInParents getStackDotYaml 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'
    exists <- Path b File -> m Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path b File
fp
    if exists
      then pure $ Just fp
      else pure Nothing
getProjectConfig (SYLNoProject [RawPackageLocationImmutable]
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
$ [RawPackageLocationImmutable] -> ProjectConfig (Path Abs File)
forall a. [RawPackageLocationImmutable] -> ProjectConfig a
PCNoProject [RawPackageLocationImmutable]
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 = StackYamlLoc -> RIO env (ProjectConfig (Path Abs File))
forall env.
HasTerm env =>
StackYamlLoc -> RIO env (ProjectConfig (Path Abs File))
getProjectConfig StackYamlLoc
mstackYaml RIO env (ProjectConfig (Path Abs File))
-> (ProjectConfig (Path Abs File)
    -> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid)))
-> RIO env (ProjectConfig (Project, Path Abs File, 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
>>= \case
  PCProject Path Abs File
fp -> do
    currDir <- RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
    logDebug $
         "Loading project config file "
      <> fromString
           (maybe (toFilePath fp) toFilePath (stripProperPrefix currDir fp))
    PCProject <$> load 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 [RawPackageLocationImmutable]
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
$ [RawPackageLocationImmutable]
-> ProjectConfig (Project, Path Abs File, ConfigMonoid)
forall a. [RawPackageLocationImmutable] -> ProjectConfig a
PCNoProject [RawPackageLocationImmutable]
extraDeps
 where
  load :: Path Abs File -> RIO env (Project, Path Abs File, ConfigMonoid)
load Path Abs File
fp = do
    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 config <- liftIO iopc
    pure (project, fp, config)

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

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
configRoot = do
  let userConfigPath :: Path Abs File
userConfigPath = Path Abs Dir -> Path Abs File
defaultUserConfigPath Path Abs Dir
configRoot
  userConfigExists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
userConfigPath
  unless userConfigExists $ do
    ensureDir (parent userConfigPath)
    liftIO $ writeBinaryFileAtomic userConfigPath defaultConfigYaml
  pure userConfigPath

-- | The contents of the default Stack global configuration file.

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