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

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

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

-- whatever files are available.

--

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

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

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

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

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

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

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

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

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

-- the new path.

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

     -- displayed)

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

  -> Path Abs a
     -- ^ New path

  -> Path Abs a
     -- ^ Deprecated path

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

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

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

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

-- Otherwise, the new location is returned.

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

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

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

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

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

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

-- | Get the latest snapshot resolver available.

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

-- Interprets ConfigMonoid options.

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

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

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

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

    Maybe String
mstackWorkEnv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
stackWorkEnvVar
    let mproject :: Maybe (Project, Path Abs File)
mproject =
          case ProjectConfig (Project, Path Abs File)
configProject of
            PCProject (Project, Path Abs File)
pair -> forall a. a -> Maybe a
Just (Project, Path Abs File)
pair
            ProjectConfig (Project, Path Abs File)
PCGlobalProject -> forall a. Maybe a
Nothing
            PCNoProject [PackageIdentifierRevision]
_deps -> forall a. Maybe a
Nothing
        configAllowLocals :: Bool
configAllowLocals =
          case ProjectConfig (Project, Path Abs File)
configProject of
            PCProject (Project, Path Abs File)
_ -> Bool
True
            ProjectConfig (Project, Path Abs File)
PCGlobalProject -> Bool
True
            PCNoProject [PackageIdentifierRevision]
_ -> Bool
False
    Path Rel Dir
configWorkDir0 <-
      let parseStackWorkEnv :: String -> m (Path Rel Dir)
parseStackWorkEnv String
x =
            forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
              (forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir String
x)
              ( \PathException
e -> case PathException
e of
                  InvalidRelDir String
_ ->
                    forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO forall a b. (a -> b) -> a -> b
$ String -> ConfigPrettyException
StackWorkEnvNotRelativeDir String
x
                  PathException
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PathException
e
              )
      in  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Rel Dir
relDirStackWork) (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {m :: * -> *}.
(MonadUnliftIO m, MonadThrow m) =>
String -> m (Path Rel Dir)
parseStackWorkEnv) Maybe String
mstackWorkEnv
    let configWorkDir :: Path Rel Dir
configWorkDir = forall a. a -> First a -> a
fromFirst Path Rel Dir
configWorkDir0 First (Path Rel Dir)
configMonoidWorkDir
        configLatestSnapshot :: Text
configLatestSnapshot = forall a. a -> First a -> a
fromFirst
          Text
"https://s3.amazonaws.com/haddock.stackage.org/snapshots.json"
          First Text
configMonoidLatestSnapshot
        clConnectionCount :: Int
clConnectionCount = forall a. a -> First a -> a
fromFirst Int
8 First Int
configMonoidConnectionCount
        configHideTHLoading :: Bool
configHideTHLoading = FirstTrue -> Bool
fromFirstTrue FirstTrue
configMonoidHideTHLoading
        configPrefixTimestamps :: Bool
configPrefixTimestamps = forall a. a -> First a -> a
fromFirst Bool
False First Bool
configMonoidPrefixTimestamps
        configGHCVariant :: Maybe GHCVariant
configGHCVariant = forall a. First a -> Maybe a
getFirst First GHCVariant
configMonoidGHCVariant
        configCompilerRepository :: CompilerRepository
configCompilerRepository = forall a. a -> First a -> a
fromFirst
          CompilerRepository
defaultCompilerRepository
          First CompilerRepository
configMonoidCompilerRepository
        configGHCBuild :: Maybe CompilerBuild
configGHCBuild = forall a. First a -> Maybe a
getFirst First CompilerBuild
configMonoidGHCBuild
        configInstallGHC :: Bool
configInstallGHC = FirstTrue -> Bool
fromFirstTrue FirstTrue
configMonoidInstallGHC
        configSkipGHCCheck :: Bool
configSkipGHCCheck = FirstFalse -> Bool
fromFirstFalse FirstFalse
configMonoidSkipGHCCheck
        configSkipMsys :: Bool
configSkipMsys = FirstFalse -> Bool
fromFirstFalse FirstFalse
configMonoidSkipMsys
        configExtraIncludeDirs :: [String]
configExtraIncludeDirs = [String]
configMonoidExtraIncludeDirs
        configExtraLibDirs :: [String]
configExtraLibDirs = [String]
configMonoidExtraLibDirs
        configCustomPreprocessorExts :: [Text]
configCustomPreprocessorExts = [Text]
configMonoidCustomPreprocessorExts
        configOverrideGccPath :: Maybe (Path Abs File)
configOverrideGccPath = forall a. First a -> Maybe a
getFirst First (Path Abs File)
configMonoidOverrideGccPath
        -- Only place in the codebase where platform is hard-coded. In theory in

        -- the future, allow it to be configured.

        (Platform Arch
defArch OS
defOS) = Platform
buildPlatform
        arch :: Arch
arch = forall a. a -> Maybe a -> a
fromMaybe Arch
defArch
          forall a b. (a -> b) -> a -> b
$ forall a. First a -> Maybe a
getFirst First String
configMonoidArch forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Parsec a => String -> Maybe a
Distribution.Text.simpleParse
        os :: OS
os = OS
defOS
        configPlatform :: Platform
configPlatform = Arch -> OS -> Platform
Platform Arch
arch OS
os
        configRequireStackVersion :: VersionRange
configRequireStackVersion = VersionRange -> VersionRange
simplifyVersionRange
          (IntersectingVersionRange -> VersionRange
getIntersectingVersionRange IntersectingVersionRange
configMonoidRequireStackVersion)
        configCompilerCheck :: VersionCheck
configCompilerCheck = forall a. a -> First a -> a
fromFirst VersionCheck
MatchMinor First VersionCheck
configMonoidCompilerCheck
    case Arch
arch of
      OtherArch String
"aarch64" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      OtherArch String
unk ->
        forall 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 (forall a. IsString a => String -> a
fromString String
unk) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
          ]
      Arch
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    PlatformVariant
configPlatformVariant <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe PlatformVariant
PlatformVariantNone String -> PlatformVariant
PlatformVariant forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
platformVariantEnvVar
    let configBuild :: BuildOpts
configBuild = BuildOptsMonoid -> BuildOpts
buildOptsFromMonoid BuildOptsMonoid
configMonoidBuildOpts
    DockerOpts
configDocker <-
      forall (m :: * -> *).
MonadThrow m =>
Maybe Project
-> Maybe AbstractResolver -> DockerOptsMonoid -> m DockerOpts
dockerOptsFromMonoid (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst Maybe (Project, Path Abs File)
mproject) Maybe AbstractResolver
configResolver DockerOptsMonoid
configMonoidDockerOpts
    NixOpts
configNix <- forall env.
(HasRunner env, HasTerm env) =>
NixOptsMonoid -> OS -> RIO env NixOpts
nixOptsFromMonoid NixOptsMonoid
configMonoidNixOpts OS
os
    Bool
configSystemGHC <-
      case (forall a. First a -> Maybe a
getFirst First Bool
configMonoidSystemGHC, NixOpts -> Bool
nixEnable NixOpts
configNix) of
        (Just Bool
False, Bool
True) ->
          forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ConfigException
NixRequiresSystemGhc
        (Maybe Bool, Bool)
_ ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure
            (forall a. a -> First a -> a
fromFirst
              (DockerOpts -> Bool
dockerEnable DockerOpts
configDocker Bool -> Bool -> Bool
|| NixOpts -> Bool
nixEnable NixOpts
configNix)
              First Bool
configMonoidSystemGHC)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe GHCVariant
configGHCVariant Bool -> Bool -> Bool
&& Bool
configSystemGHC) forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ConfigException
ManualGHCVariantSettingsAreIncompatibleWithSystemGHC
    [(String, String)]
rawEnv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(String, String)]
getEnvironment
    Map Text Text
pathsEnv <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall (f :: * -> *) a. Applicative f => a -> f a
pure
      forall a b. (a -> b) -> a -> b
$ [String]
-> Map Text Text -> Either ProcessException (Map Text Text)
augmentPathMap (forall a b. (a -> b) -> [a] -> [b]
map forall b t. Path b t -> String
toFilePath [Path Abs Dir]
configMonoidExtraPath)
                       (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** String -> Text
T.pack) [(String, String)]
rawEnv))
    ProcessContext
origEnv <- forall (m :: * -> *).
MonadIO m =>
Map Text Text -> m ProcessContext
mkProcessContext Map Text Text
pathsEnv
    let configProcessContextSettings :: EnvSettings -> IO ProcessContext
configProcessContextSettings EnvSettings
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessContext
origEnv
    Path Abs Dir
configLocalProgramsBase <- case forall a. First a -> Maybe a
getFirst First (Path Abs Dir)
configMonoidLocalProgramsBase of
      Maybe (Path Abs Dir)
Nothing -> forall (m :: * -> *).
MonadThrow m =>
Path Abs Dir -> Platform -> ProcessContext -> m (Path Abs Dir)
getDefaultLocalProgramsBase Path Abs Dir
configStackRoot Platform
configPlatform ProcessContext
origEnv
      Just Path Abs Dir
path -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
path
    let localProgramsFilePath :: String
localProgramsFilePath = forall b t. Path b t -> String
toFilePath Path Abs Dir
configLocalProgramsBase
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
osIsWindows Bool -> Bool -> Bool
&& Char
' ' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
localProgramsFilePath) forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
configLocalProgramsBase
      -- getShortPathName returns the long path name when a short name does not

      -- exist.

      String
shortLocalProgramsFilePath <-
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO String
getShortPathName String
localProgramsFilePath
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char
' ' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
shortLocalProgramsFilePath) forall a b. (a -> b) -> a -> b
$
        forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError forall a b. (a -> b) -> a -> b
$
          StyleDoc
"[S-8432]"
          forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
          forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
               [ String -> StyleDoc
flow String
"Stack's 'programs' path contains a space character and \
                      \has no alternative short ('8 dot 3') name. This will \
                      \cause problems with packages that use the GNU project's \
                      \'configure' shell script. Use the"
               , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"local-programs-path"
               , String -> StyleDoc
flow String
"configuration option to specify an alternative path. \
                      \The current path is:"
               , Style -> StyleDoc -> StyleDoc
style Style
File (forall a. IsString a => String -> a
fromString String
localProgramsFilePath) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
               ]
    Path Rel Dir
platformOnlyDir <-
      forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall env (m :: * -> *).
(MonadReader env m, HasPlatform env, MonadThrow m) =>
m (Path Rel Dir)
platformOnlyRelDir (Platform
configPlatform, PlatformVariant
configPlatformVariant)
    let configLocalPrograms :: Path Abs Dir
configLocalPrograms = Path Abs Dir
configLocalProgramsBase forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
platformOnlyDir
    Path Abs Dir
configLocalBin <-
      case forall a. First a -> Maybe a
getFirst First String
configMonoidLocalBinPath of
        Maybe String
Nothing -> do
          Path Abs Dir
localDir <- forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
getAppUserDataDir String
"local"
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Path Abs Dir
localDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirBin
        Just String
userPath ->
          (case Maybe (Project, Path Abs File)
mproject of
            -- Not in a project

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

            -- relative

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

          -- parseRelAsAbsDirMaybe utility and use it along with

          -- resolveDirMaybe.

          forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny`
          forall a b. a -> b -> a
const (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (String -> ConfigException
NoSuchDirectory String
userPath))
    Int
configJobs <-
      case forall a. First a -> Maybe a
getFirst First Int
configMonoidJobs of
        Maybe Int
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumProcessors
        Just Int
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
i
    let configConcurrentTests :: Bool
configConcurrentTests = forall a. a -> First a -> a
fromFirst Bool
True First Bool
configMonoidConcurrentTests
    let configTemplateParams :: Map Text Text
configTemplateParams = Map Text Text
configMonoidTemplateParameters
        configScmInit :: Maybe SCM
configScmInit = forall a. First a -> Maybe a
getFirst First SCM
configMonoidScmInit
        configCabalConfigOpts :: Map CabalConfigKey [Text]
configCabalConfigOpts = coerce :: forall a b. Coercible a b => a -> b
coerce MonoidMap CabalConfigKey (Dual [Text])
configMonoidCabalConfigOpts
        configGhcOptionsByName :: Map PackageName [Text]
configGhcOptionsByName = coerce :: forall a b. Coercible a b => a -> b
coerce MonoidMap PackageName (Dual [Text])
configMonoidGhcOptionsByName
        configGhcOptionsByCat :: Map ApplyGhcOptions [Text]
configGhcOptionsByCat = coerce :: forall a b. Coercible a b => a -> b
coerce MonoidMap ApplyGhcOptions (Dual [Text])
configMonoidGhcOptionsByCat
        configSetupInfoLocations :: [String]
configSetupInfoLocations = [String]
configMonoidSetupInfoLocations
        configSetupInfoInline :: SetupInfo
configSetupInfoInline = SetupInfo
configMonoidSetupInfoInline
        configPvpBounds :: PvpBounds
configPvpBounds =
          forall a. a -> First a -> a
fromFirst (PvpBoundsType -> Bool -> PvpBounds
PvpBounds PvpBoundsType
PvpBoundsNone Bool
False) First PvpBounds
configMonoidPvpBounds
        configModifyCodePage :: Bool
configModifyCodePage = FirstTrue -> Bool
fromFirstTrue FirstTrue
configMonoidModifyCodePage
        configRebuildGhcOptions :: Bool
configRebuildGhcOptions = FirstFalse -> Bool
fromFirstFalse FirstFalse
configMonoidRebuildGhcOptions
        configApplyGhcOptions :: ApplyGhcOptions
configApplyGhcOptions = forall a. a -> First a -> a
fromFirst ApplyGhcOptions
AGOLocals First ApplyGhcOptions
configMonoidApplyGhcOptions
        configApplyProgOptions :: ApplyProgOptions
configApplyProgOptions = forall a. a -> First a -> a
fromFirst ApplyProgOptions
APOLocals First ApplyProgOptions
configMonoidApplyProgOptions
        configAllowNewer :: Bool
configAllowNewer = forall a. a -> First a -> a
fromFirst Bool
False First Bool
configMonoidAllowNewer
        configAllowNewerDeps :: Maybe [PackageName]
configAllowNewerDeps = coerce :: forall a b. Coercible a b => a -> b
coerce Maybe AllowNewerDeps
configMonoidAllowNewerDeps
        configDefaultTemplate :: Maybe TemplateName
configDefaultTemplate = forall a. First a -> Maybe a
getFirst First TemplateName
configMonoidDefaultTemplate
        configDumpLogs :: DumpLogs
configDumpLogs = forall a. a -> First a -> a
fromFirst DumpLogs
DumpWarningLogs First DumpLogs
configMonoidDumpLogs
        configSaveHackageCreds :: Bool
configSaveHackageCreds = forall a. a -> First a -> a
fromFirst Bool
True First Bool
configMonoidSaveHackageCreds
        configHackageBaseUrl :: Text
configHackageBaseUrl =
          forall a. a -> First a -> a
fromFirst Text
"https://hackage.haskell.org/" First Text
configMonoidHackageBaseUrl
        configHideSourcePaths :: Bool
configHideSourcePaths = FirstTrue -> Bool
fromFirstTrue FirstTrue
configMonoidHideSourcePaths
        configRecommendUpgrade :: Bool
configRecommendUpgrade = FirstTrue -> Bool
fromFirstTrue FirstTrue
configMonoidRecommendUpgrade
        configNoRunCompile :: Bool
configNoRunCompile = FirstFalse -> Bool
fromFirstFalse FirstFalse
configMonoidNoRunCompile
    Bool
configAllowDifferentUser <-
      case forall a. First a -> Maybe a
getFirst First Bool
configMonoidAllowDifferentUser of
        Just Bool
True -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        Maybe Bool
_ -> forall (m :: * -> *). MonadIO m => m Bool
getInContainer
    Runner
configRunner' <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasRunner env => Lens' env Runner
runnerL
    Bool
useAnsi <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hSupportsANSI Handle
stderr
    let stylesUpdate' :: StylesUpdate
stylesUpdate' = (Runner
configRunner' forall s a. s -> Getting a s a -> a
^. forall env. HasStylesUpdate env => Lens' env StylesUpdate
stylesUpdateL) forall a. Semigroup a => a -> a -> a
<>
          StylesUpdate
configMonoidStyles
        useColor' :: Bool
useColor' = Runner -> Bool
runnerUseColor Runner
configRunner'
        mUseColor :: Maybe Bool
mUseColor = do
          ColorWhen
colorWhen <- forall a. First a -> Maybe a
getFirst First ColorWhen
configMonoidColorWhen
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case ColorWhen
colorWhen of
            ColorWhen
ColorNever  -> Bool
False
            ColorWhen
ColorAlways -> Bool
True
            ColorWhen
ColorAuto  -> Bool
useAnsi
        useColor'' :: Bool
useColor'' = forall a. a -> Maybe a -> a
fromMaybe Bool
useColor' Maybe Bool
mUseColor
        configRunner'' :: Runner
configRunner'' = Runner
configRunner'
          forall a b. a -> (a -> b) -> b
& forall env. HasProcessContext env => Lens' env ProcessContext
processContextL forall s t a b. ASetter s t a b -> b -> s -> t
.~ ProcessContext
origEnv
          forall a b. a -> (a -> b) -> b
& forall env. HasStylesUpdate env => Lens' env StylesUpdate
stylesUpdateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ StylesUpdate
stylesUpdate'
          forall a b. a -> (a -> b) -> b
& forall env. HasTerm env => Lens' env Bool
useColorL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
useColor''
        go :: GlobalOpts
go = Runner -> GlobalOpts
runnerGlobalOpts Runner
configRunner'
    PackageIndexConfig
pic <-
      case forall a. First a -> Maybe a
getFirst First PackageIndexConfig
configMonoidPackageIndex of
        Maybe PackageIndexConfig
Nothing ->
          case forall a. First a -> Maybe a
getFirst First [PackageIndexConfig]
configMonoidPackageIndices of
            Maybe [PackageIndexConfig]
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIndexConfig
defaultPackageIndexConfig
            Just [PackageIndexConfig
pic] -> do
              forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn StyleDoc
packageIndicesWarning
              forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIndexConfig
pic
            Just [PackageIndexConfig]
x -> forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO forall a b. (a -> b) -> a -> b
$ [PackageIndexConfig] -> ConfigPrettyException
MultiplePackageIndices [PackageIndexConfig]
x
        Just PackageIndexConfig
pic -> forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIndexConfig
pic
    Maybe String
mpantryRoot <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
pantryRootEnvVar
    Path Abs Dir
pantryRoot <-
      case Maybe String
mpantryRoot of
        Just String
dir ->
          case forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir String
dir of
            Maybe (Path Abs Dir)
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ String -> String -> ParseAbsolutePathException
ParseAbsolutePathException String
pantryRootEnvVar String
dir
            Just Path Abs Dir
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
x
        Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Path Abs Dir
configStackRoot forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirPantry
    let snapLoc :: SnapName -> RawSnapshotLocation
snapLoc =
          case forall a. First a -> Maybe a
getFirst First Text
configMonoidSnapshotLocation of
            Maybe Text
Nothing -> SnapName -> RawSnapshotLocation
defaultSnapshotLocation
            Just Text
addr ->
              SnapName -> RawSnapshotLocation
customSnapshotLocation
               where
                customSnapshotLocation :: SnapName -> RawSnapshotLocation
customSnapshotLocation (LTS Int
x Int
y) =
                  Utf8Builder -> RawSnapshotLocation
mkRSLUrl forall a b. (a -> b) -> a -> b
$ Utf8Builder
addr'
                    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/lts/" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
x
                    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
y forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".yaml"
                customSnapshotLocation (Nightly Day
date) =
                  let (Year
year, Int
month, Int
day) = Day -> (Year, Int, Int)
toGregorian Day
date
                  in  Utf8Builder -> RawSnapshotLocation
mkRSLUrl forall a b. (a -> b) -> a -> b
$ Utf8Builder
addr'
                        forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/nightly/"
                        forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Year
year
                        forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
month
                        forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
day forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".yaml"
                mkRSLUrl :: Utf8Builder -> RawSnapshotLocation
mkRSLUrl Utf8Builder
builder = Text -> Maybe BlobKey -> RawSnapshotLocation
RSLUrl (Utf8Builder -> Text
utf8BuilderToText Utf8Builder
builder) forall a. Maybe a
Nothing
                addr' :: Utf8Builder
addr' = forall a. Display a => a -> Utf8Builder
display forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhileEnd (forall a. Eq a => a -> a -> Bool
==Char
'/') Text
addr
    let configStackDeveloperMode :: Bool
configStackDeveloperMode =
          forall a. a -> First a -> a
fromFirst Bool
stackDeveloperModeDefault First Bool
configMonoidStackDeveloperMode
    forall (m :: * -> *) a.
MonadUnliftIO m =>
GlobalOpts -> Bool -> StylesUpdate -> (LogFunc -> m a) -> m a
withNewLogFunc GlobalOpts
go Bool
useColor'' StylesUpdate
stylesUpdate' forall a b. (a -> b) -> a -> b
$ \LogFunc
logFunc -> do
      let configRunner :: Runner
configRunner = Runner
configRunner'' forall a b. a -> (a -> b) -> b
& forall env. HasLogFunc env => Lens' env LogFunc
logFuncL forall s t a b. ASetter s t a b -> b -> s -> t
.~ LogFunc
logFunc
      forall env a. HasLogFunc env => LogFunc -> RIO env a -> RIO env a
withLocalLogFunc LogFunc
logFunc forall a b. (a -> b) -> a -> b
$ forall env a. HasLogFunc env => RIO env a -> RIO env a
handleMigrationException forall a b. (a -> b) -> a -> b
$
        forall env a.
HasLogFunc env =>
Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Int
-> CasaRepoPrefix
-> Int
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig
          Path Abs Dir
pantryRoot
          PackageIndexConfig
pic
          (forall b a. b -> (a -> b) -> Maybe a -> b
maybe HpackExecutable
HpackBundled String -> HpackExecutable
HpackCommand forall a b. (a -> b) -> a -> b
$ forall a. First a -> Maybe a
getFirst First String
configMonoidOverrideHpack)
          Int
clConnectionCount
          (forall a. a -> First a -> a
fromFirst CasaRepoPrefix
defaultCasaRepoPrefix First CasaRepoPrefix
configMonoidCasaRepoPrefix)
          Int
defaultCasaMaxPerRequest
          SnapName -> RawSnapshotLocation
snapLoc
          (\PantryConfig
configPantryConfig -> forall env a.
HasLogFunc env =>
Path Abs File -> (UserStorage -> RIO env a) -> RIO env a
initUserStorage
            (Path Abs Dir
configStackRoot forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileStorage)
            (\UserStorage
configUserStorage -> Config -> RIO env a
inner Config {Bool
Int
[String]
[Text]
Maybe [PackageName]
Maybe (Path Abs File)
Maybe CompilerBuild
Maybe GHCVariant
Maybe AbstractResolver
Maybe SCM
Maybe TemplateName
VersionRange
Platform
Map PackageName [Text]
Map Text Text
Map ApplyGhcOptions [Text]
Map CabalConfigKey [Text]
Text
PantryConfig
Path Abs File
Path Abs Dir
Path Rel Dir
ApplyGhcOptions
ApplyProgOptions
BuildOpts
DumpLogs
NixOpts
PlatformVariant
ProjectConfig (Project, Path Abs File)
PvpBounds
UserStorage
VersionCheck
CompilerRepository
SetupInfo
DockerOpts
Runner
EnvSettings -> IO ProcessContext
configStackDeveloperMode :: Bool
configNoRunCompile :: Bool
configRecommendUpgrade :: Bool
configHideSourcePaths :: Bool
configUserStorage :: UserStorage
configResolver :: Maybe AbstractResolver
configStackRoot :: Path Abs Dir
configPantryConfig :: PantryConfig
configRunner :: Runner
configHackageBaseUrl :: Text
configSaveHackageCreds :: Bool
configAllowLocals :: Bool
configProject :: ProjectConfig (Project, Path Abs File)
configDumpLogs :: DumpLogs
configAllowDifferentUser :: Bool
configDefaultTemplate :: Maybe TemplateName
configAllowNewerDeps :: Maybe [PackageName]
configAllowNewer :: Bool
configApplyProgOptions :: ApplyProgOptions
configApplyGhcOptions :: ApplyGhcOptions
configRebuildGhcOptions :: Bool
configModifyCodePage :: Bool
configPvpBounds :: PvpBounds
configSetupInfoInline :: SetupInfo
configSetupInfoLocations :: [String]
configCabalConfigOpts :: Map CabalConfigKey [Text]
configGhcOptionsByCat :: Map ApplyGhcOptions [Text]
configGhcOptionsByName :: Map PackageName [Text]
configScmInit :: Maybe SCM
configTemplateParams :: Map Text Text
configConcurrentTests :: Bool
configCustomPreprocessorExts :: [Text]
configExtraLibDirs :: [String]
configExtraIncludeDirs :: [String]
configOverrideGccPath :: Maybe (Path Abs File)
configJobs :: Int
configRequireStackVersion :: VersionRange
configLocalBin :: Path Abs Dir
configCompilerRepository :: CompilerRepository
configCompilerCheck :: VersionCheck
configSkipMsys :: Bool
configSkipGHCCheck :: Bool
configInstallGHC :: Bool
configSystemGHC :: Bool
configLatestSnapshot :: Text
configGHCBuild :: Maybe CompilerBuild
configGHCVariant :: Maybe GHCVariant
configPlatformVariant :: PlatformVariant
configPlatform :: Platform
configPrefixTimestamps :: Bool
configHideTHLoading :: Bool
configLocalPrograms :: Path Abs Dir
configLocalProgramsBase :: Path Abs Dir
configProcessContextSettings :: EnvSettings -> IO ProcessContext
configNix :: NixOpts
configDocker :: DockerOpts
configBuild :: BuildOpts
configUserConfigPath :: Path Abs File
configWorkDir :: Path Rel Dir
configUserStorage :: UserStorage
configPantryConfig :: PantryConfig
configRunner :: Runner
configStackDeveloperMode :: Bool
configAllowDifferentUser :: Bool
configNoRunCompile :: Bool
configRecommendUpgrade :: Bool
configHideSourcePaths :: Bool
configHackageBaseUrl :: Text
configSaveHackageCreds :: Bool
configDumpLogs :: DumpLogs
configDefaultTemplate :: Maybe TemplateName
configAllowNewerDeps :: Maybe [PackageName]
configAllowNewer :: Bool
configApplyProgOptions :: ApplyProgOptions
configApplyGhcOptions :: ApplyGhcOptions
configRebuildGhcOptions :: Bool
configModifyCodePage :: Bool
configPvpBounds :: PvpBounds
configSetupInfoInline :: SetupInfo
configSetupInfoLocations :: [String]
configGhcOptionsByCat :: Map ApplyGhcOptions [Text]
configGhcOptionsByName :: Map PackageName [Text]
configCabalConfigOpts :: Map CabalConfigKey [Text]
configScmInit :: Maybe SCM
configTemplateParams :: Map Text Text
configConcurrentTests :: Bool
configJobs :: Int
configLocalBin :: Path Abs Dir
configLocalPrograms :: Path Abs Dir
configLocalProgramsBase :: Path Abs Dir
configProcessContextSettings :: EnvSettings -> IO ProcessContext
configSystemGHC :: Bool
configNix :: NixOpts
configDocker :: DockerOpts
configBuild :: BuildOpts
configPlatformVariant :: PlatformVariant
configCompilerCheck :: VersionCheck
configRequireStackVersion :: VersionRange
configPlatform :: Platform
configOverrideGccPath :: Maybe (Path Abs File)
configCustomPreprocessorExts :: [Text]
configExtraLibDirs :: [String]
configExtraIncludeDirs :: [String]
configSkipMsys :: Bool
configSkipGHCCheck :: Bool
configInstallGHC :: Bool
configGHCBuild :: Maybe CompilerBuild
configCompilerRepository :: CompilerRepository
configGHCVariant :: Maybe GHCVariant
configPrefixTimestamps :: Bool
configHideTHLoading :: Bool
configLatestSnapshot :: Text
configWorkDir :: Path Rel Dir
configAllowLocals :: Bool
configProject :: ProjectConfig (Project, Path Abs File)
configResolver :: Maybe AbstractResolver
configUserConfigPath :: Path Abs File
configStackRoot :: Path Abs Dir
..}))

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

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

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

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

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

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

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

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

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

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

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

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

-- and defaults as necessary.

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

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

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

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

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

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

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

-- | Load the build configuration, adds build-specific values to config loaded

-- by @loadConfig@. values.

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

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

  -- Resolver that can be used below.


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

  -- to properly deal with an AbstractResolver, we need a base directory (to

  -- deal with custom snapshot relative paths). We consider the current working

  -- directory to be the correct base. Let's calculate the mresolver first.

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

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

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

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

  -- yet

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

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

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

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

  -- prefetch git repos to avoid cloning per subdirectory

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

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

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

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

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

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

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

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

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

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

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

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

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


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

-- exception.

checkDuplicateNames :: MonadThrow m => [(PackageName, PackageLocation)] -> m ()
checkDuplicateNames :: forall (m :: * -> *).
MonadThrow m =>
[(PackageName, PackageLocation)] -> m ()
checkDuplicateNames [(PackageName, PackageLocation)]
locals =
  case forall a. (a -> Bool) -> [a] -> [a]
filter forall {a} {a}. (a, [a]) -> Bool
hasMultiples forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall (f :: * -> *) a. Applicative f => a -> f a
pure) [(PackageName, PackageLocation)]
locals of
    [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [(PackageName, [PackageLocation])]
x -> forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  (Path Abs Dir
configRoot, Path Abs Dir
stackRoot) <- do
    case forall a. First a -> Maybe a
getFirst (ConfigMonoid -> First (Path Abs Dir)
configMonoidStackRoot ConfigMonoid
clArgs) of
      Just Path Abs Dir
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir
x, Path Abs Dir
x)
      Maybe (Path Abs Dir)
Nothing -> do
        Maybe String
mstackRoot <- String -> IO (Maybe String)
lookupEnv String
stackRootEnvVar
        case Maybe String
mstackRoot of
          Maybe String
Nothing -> do
            String
wantXdg <- forall a. a -> Maybe a -> a
fromMaybe String
"" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
stackXdgEnvVar
            if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
wantXdg)
              then do
                Path Rel Dir
xdgRelDir <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir String
stackProgName
                (,)
                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadIO m =>
XdgDirectory -> Maybe (Path Rel Dir) -> m (Path Abs Dir)
getXdgDir XdgDirectory
XdgConfig (forall a. a -> Maybe a
Just Path Rel Dir
xdgRelDir)
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *).
MonadIO m =>
XdgDirectory -> Maybe (Path Rel Dir) -> m (Path Abs Dir)
getXdgDir XdgDirectory
XdgData (forall a. a -> Maybe a
Just Path Rel Dir
xdgRelDir)
              else do
                Path Abs Dir
oldStyleRoot <- forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
getAppUserDataDir String
stackProgName
                forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir
oldStyleRoot, Path Abs Dir
oldStyleRoot)
          Just String
x -> case forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir String
x of
            Maybe (Path Abs Dir)
Nothing ->
              forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ String -> String -> ParseAbsolutePathException
ParseAbsolutePathException String
stackRootEnvVar String
x
            Just Path Abs Dir
parsed -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir
parsed, Path Abs Dir
parsed)

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

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

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

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

-- owned by the current user.

--

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

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

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

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

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

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

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

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

-- the owner for the given path.

--

-- Will always pure 'True' on Windows.

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

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

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

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

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

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

--

-- Returns most local first

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

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

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

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

loadConfigYaml ::
     HasLogFunc env
  => (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> RIO env a
loadConfigYaml :: forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env a
loadConfigYaml Value -> Parser (WithJSONWarnings a)
parser Path Abs File
path = do
  Either ParseException a
eres <- forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env (Either ParseException a)
loadYaml Value -> Parser (WithJSONWarnings a)
parser Path Abs File
path
  case Either ParseException a
eres of
    Left ParseException
err -> forall 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res

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

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

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

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

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

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

-- based on current directory.

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

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

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

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

-- new location is returned.

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

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

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

-- new location is returned.

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

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

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