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

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

The general Stack configuration that starts everything off. This should be smart
to fallback if there is no stack.yaml, instead relying on whatever files are
available.

If there is no stack.yaml, and there is a cabal.config, we read in those
constraints, and if there's a cabal.sandbox.config, we read any constraints from
there and also find the package database from there, etc. And if there's
nothing, we should probably default to behaving like cabal, possibly with
spitting out a warning that "you should run `stk init` to make things better".
-}

module Stack.Config
  ( loadConfig
  , loadConfigYaml
  , getImplicitGlobalProjectDir
  , getSnapshots
  , makeConcreteSnapshot
  , getRawSnapshot
  , checkOwnership
  , getInContainer
  , getInNixShell
  , defaultConfigYaml
  , getProjectConfig
  , withBuildConfig
  , withNewLogFunc
  , determineStackRootAndOwnership
  ) where

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

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

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

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

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

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

makeConcreteSnapshot ::
     HasConfig env
  => AbstractSnapshot
  -> RIO env RawSnapshotLocation
makeConcreteSnapshot :: forall env.
HasConfig env =>
AbstractSnapshot -> RIO env RawSnapshotLocation
makeConcreteSnapshot (ASSnapshot RawSnapshotLocation
s) = RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshotLocation
s
makeConcreteSnapshot AbstractSnapshot
as = do
  RawSnapshotLocation
s <-
    case AbstractSnapshot
as of
      AbstractSnapshot
ASGlobal -> do
        Path Abs File
fp <- RIO env (Path Abs Dir)
forall env. HasConfig env => RIO env (Path Abs Dir)
getImplicitGlobalProjectDir RIO env (Path Abs Dir)
-> (Path Abs Dir -> Path Abs File) -> RIO env (Path Abs File)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
stackDotYaml)
        IO ProjectAndConfigMonoid
iopc <- (Value -> Parser (WithJSONWarnings (IO ProjectAndConfigMonoid)))
-> Path Abs File -> RIO env (IO ProjectAndConfigMonoid)
forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env a
loadConfigYaml (Path Abs Dir
-> Value -> Parser (WithJSONWarnings (IO ProjectAndConfigMonoid))
parseProjectAndConfigMonoid (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
fp)) Path Abs File
fp
        ProjectAndConfigMonoid Project
project ConfigMonoid
_ <- IO ProjectAndConfigMonoid -> RIO env ProjectAndConfigMonoid
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ProjectAndConfigMonoid
iopc
        RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Project
project.snapshot
      AbstractSnapshot
ASLatestNightly ->
        SnapName -> RawSnapshotLocation
RSLSynonym (SnapName -> RawSnapshotLocation)
-> (Snapshots -> SnapName) -> Snapshots -> RawSnapshotLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> SnapName
Nightly (Day -> SnapName) -> (Snapshots -> Day) -> Snapshots -> SnapName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.nightly) (Snapshots -> RawSnapshotLocation)
-> RIO env Snapshots -> RIO env RawSnapshotLocation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RIO env Snapshots
forall env. HasConfig env => RIO env Snapshots
getSnapshots
      ASLatestLTSMajor Int
x -> do
        Snapshots
snapshots <- RIO env Snapshots
forall env. HasConfig env => RIO env Snapshots
getSnapshots
        case Int -> IntMap Int -> Maybe Int
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
x Snapshots
snapshots.lts of
          Maybe Int
Nothing -> ConfigException -> RIO env RawSnapshotLocation
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (ConfigException -> RIO env RawSnapshotLocation)
-> ConfigException -> RIO env RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ Int -> ConfigException
NoLTSWithMajorVersion Int
x
          Just Int
y -> RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawSnapshotLocation -> RIO env RawSnapshotLocation)
-> RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ SnapName -> RawSnapshotLocation
RSLSynonym (SnapName -> RawSnapshotLocation)
-> SnapName -> RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ Int -> Int -> SnapName
LTS Int
x Int
y
      AbstractSnapshot
ASLatestLTS -> do
        Snapshots
snapshots <- RIO env Snapshots
forall env. HasConfig env => RIO env Snapshots
getSnapshots
        if IntMap Int -> Bool
forall a. IntMap a -> Bool
IntMap.null Snapshots
snapshots.lts
          then ConfigException -> RIO env RawSnapshotLocation
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ConfigException
NoLTSFound
          else let (Int
x, Int
y) = IntMap Int -> (Int, Int)
forall a. IntMap a -> (Int, a)
IntMap.findMax Snapshots
snapshots.lts
               in  RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawSnapshotLocation -> RIO env RawSnapshotLocation)
-> RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ SnapName -> RawSnapshotLocation
RSLSynonym (SnapName -> RawSnapshotLocation)
-> SnapName -> RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ Int -> Int -> SnapName
LTS Int
x Int
y
  [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
    [ String -> StyleDoc
flow String
"Selected snapshot:"
    , Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> Text
forall a. Display a => a -> Text
textDisplay RawSnapshotLocation
s) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
    ]
  RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshotLocation
s

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

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

-- | Get the latest snapshot available.

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

-- Interprets ConfigMonoid options.

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

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

  -> Maybe AbstractSnapshot
  -> ProjectConfig (Project, Path Abs File)
  -> ConfigMonoid
  -> (Config -> RIO env a)
  -> RIO env a
configFromConfigMonoid :: forall env a.
(HasRunner env, HasTerm env) =>
Path Abs Dir
-> Path Abs File
-> Maybe AbstractSnapshot
-> ProjectConfig (Project, Path Abs File)
-> ConfigMonoid
-> (Config -> RIO env a)
-> RIO env a
configFromConfigMonoid
  Path Abs Dir
stackRoot
  Path Abs File
userGlobalConfigFile
  Maybe AbstractSnapshot
snapshot
  ProjectConfig (Project, Path Abs File)
project
  ConfigMonoid
configMonoid
  Config -> RIO env a
inner
  = do
    -- If --stack-work is passed, prefer it. Otherwise, if STACK_WORK

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

    Maybe String
mstackWorkEnv <- IO (Maybe String) -> RIO env (Maybe String)
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> RIO env (Maybe String))
-> IO (Maybe String) -> RIO env (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
stackWorkEnvVar
    let mproject :: Maybe (Project, Path Abs File)
mproject =
          case ProjectConfig (Project, Path Abs File)
project of
            PCProject (Project, Path Abs File)
pair -> (Project, Path Abs File) -> Maybe (Project, Path Abs File)
forall a. a -> Maybe a
Just (Project, Path Abs File)
pair
            ProjectConfig (Project, Path Abs File)
PCGlobalProject -> Maybe (Project, Path Abs File)
forall a. Maybe a
Nothing
            PCNoProject [RawPackageLocationImmutable]
_deps -> Maybe (Project, Path Abs File)
forall a. Maybe a
Nothing
        allowLocals :: Bool
allowLocals =
          case ProjectConfig (Project, Path Abs File)
project of
            PCProject (Project, Path Abs File)
_ -> Bool
True
            ProjectConfig (Project, Path Abs File)
PCGlobalProject -> Bool
True
            PCNoProject [RawPackageLocationImmutable]
_ -> Bool
False
    Path Rel Dir
configWorkDir0 <-
      let parseStackWorkEnv :: String -> m (Path Rel Dir)
parseStackWorkEnv String
x =
            m (Path Rel Dir)
-> (PathException -> m (Path Rel Dir)) -> m (Path Rel Dir)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
              (String -> m (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir String
x)
              ( \PathException
e -> case PathException
e of
                  InvalidRelDir String
_ ->
                    ConfigPrettyException -> m (Path Rel Dir)
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (ConfigPrettyException -> m (Path Rel Dir))
-> ConfigPrettyException -> m (Path Rel Dir)
forall a b. (a -> b) -> a -> b
$ String -> ConfigPrettyException
StackWorkEnvNotRelativeDir String
x
                  PathException
_ -> PathException -> m (Path Rel Dir)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PathException
e
              )
      in  RIO env (Path Rel Dir)
-> (String -> RIO env (Path Rel Dir))
-> Maybe String
-> RIO env (Path Rel Dir)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Path Rel Dir -> RIO env (Path Rel Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Rel Dir
relDirStackWork) (IO (Path Rel Dir) -> RIO env (Path Rel Dir)
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Path Rel Dir) -> RIO env (Path Rel Dir))
-> (String -> IO (Path Rel Dir))
-> String
-> RIO env (Path Rel Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Path Rel Dir)
forall {m :: * -> *}.
(MonadUnliftIO m, MonadThrow m) =>
String -> m (Path Rel Dir)
parseStackWorkEnv) Maybe String
mstackWorkEnv
    let workDir :: Path Rel Dir
workDir = Path Rel Dir -> First (Path Rel Dir) -> Path Rel Dir
forall a. a -> First a -> a
fromFirst Path Rel Dir
configWorkDir0 ConfigMonoid
configMonoid.workDir
        -- The history of the URL below is as follows:

        --

        -- * Before Stack 1.3.0 it was

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

        -- * From Stack 1.3.0 to 2.15.3 it was

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

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

        --   stackage.org.

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

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

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

        latestSnapshot :: Text
latestSnapshot = Text -> First Text -> Text
forall a. a -> First a -> a
fromFirst
          Text
"https://stackage-haddock.haskell.org/snapshots.json"
          ConfigMonoid
configMonoid.latestSnapshot
        clConnectionCount :: Int
clConnectionCount = Int -> First Int -> Int
forall a. a -> First a -> a
fromFirst Int
8 ConfigMonoid
configMonoid.connectionCount
        hideTHLoading :: Bool
hideTHLoading = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.hideTHLoading
        prefixTimestamps :: Bool
prefixTimestamps = Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst Bool
False ConfigMonoid
configMonoid.prefixTimestamps
        ghcVariant :: Maybe GHCVariant
ghcVariant = First GHCVariant -> Maybe GHCVariant
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.ghcVariant
        compilerRepository :: CompilerRepository
compilerRepository = CompilerRepository
-> First CompilerRepository -> CompilerRepository
forall a. a -> First a -> a
fromFirst
          CompilerRepository
defaultCompilerRepository
          ConfigMonoid
configMonoid.compilerRepository
        ghcBuild :: Maybe CompilerBuild
ghcBuild = First CompilerBuild -> Maybe CompilerBuild
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.ghcBuild
        installGHC :: Bool
installGHC = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.installGHC
        installMsys :: Bool
installMsys = Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst Bool
installGHC ConfigMonoid
configMonoid.installMsys
        skipGHCCheck :: Bool
skipGHCCheck = FirstFalse -> Bool
fromFirstFalse ConfigMonoid
configMonoid.skipGHCCheck
        skipMsys :: Bool
skipMsys = FirstFalse -> Bool
fromFirstFalse ConfigMonoid
configMonoid.skipMsys
        defMsysEnvironment :: Maybe MsysEnvironment
defMsysEnvironment = case Platform
platform of
          Platform Arch
I386 OS
Windows -> MsysEnvironment -> Maybe MsysEnvironment
forall a. a -> Maybe a
Just MsysEnvironment
MINGW32
          Platform Arch
X86_64 OS
Windows -> MsysEnvironment -> Maybe MsysEnvironment
forall a. a -> Maybe a
Just MsysEnvironment
MINGW64
          Platform
_ -> Maybe MsysEnvironment
forall a. Maybe a
Nothing
        extraIncludeDirs :: [String]
extraIncludeDirs = ConfigMonoid
configMonoid.extraIncludeDirs
        extraLibDirs :: [String]
extraLibDirs = ConfigMonoid
configMonoid.extraLibDirs
        customPreprocessorExts :: [Text]
customPreprocessorExts = ConfigMonoid
configMonoid.customPreprocessorExts
        overrideGccPath :: Maybe (Path Abs File)
overrideGccPath = First (Path Abs File) -> Maybe (Path Abs File)
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.overrideGccPath
        -- Only place in the codebase where platform is hard-coded. In theory in

        -- the future, allow it to be configured.

        (Platform Arch
defArch OS
defOS) = Platform
buildPlatform
        arch :: Arch
arch = Arch -> Maybe Arch -> Arch
forall a. a -> Maybe a -> a
fromMaybe Arch
defArch
          (Maybe Arch -> Arch) -> Maybe Arch -> Arch
forall a b. (a -> b) -> a -> b
$ First String -> Maybe String
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.arch Maybe String -> (String -> Maybe Arch) -> Maybe Arch
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Arch
forall a. Parsec a => String -> Maybe a
Distribution.Text.simpleParse
        os :: OS
os = OS
defOS
        platform :: Platform
platform = Arch -> OS -> Platform
Platform Arch
arch OS
os
        requireStackVersion :: VersionRange
requireStackVersion = VersionRange -> VersionRange
simplifyVersionRange
          ConfigMonoid
configMonoid.requireStackVersion.intersectingVersionRange
        compilerCheck :: VersionCheck
compilerCheck = VersionCheck -> First VersionCheck -> VersionCheck
forall a. a -> First a -> a
fromFirst VersionCheck
MatchMinor ConfigMonoid
configMonoid.compilerCheck
    Maybe MsysEnvironment
msysEnvironment <- case Maybe MsysEnvironment
defMsysEnvironment of
      -- Ignore the configuration setting if there is no default for the

      -- platform.

      Maybe MsysEnvironment
Nothing -> Maybe MsysEnvironment -> RIO env (Maybe MsysEnvironment)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe MsysEnvironment
forall a. Maybe a
Nothing
      Just MsysEnvironment
defMsysEnv -> do
        let msysEnv :: MsysEnvironment
msysEnv = MsysEnvironment -> First MsysEnvironment -> MsysEnvironment
forall a. a -> First a -> a
fromFirst MsysEnvironment
defMsysEnv ConfigMonoid
configMonoid.msysEnvironment
        if MsysEnvironment -> Arch
msysEnvArch MsysEnvironment
msysEnv Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
arch
          then Maybe MsysEnvironment -> RIO env (Maybe MsysEnvironment)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe MsysEnvironment -> RIO env (Maybe MsysEnvironment))
-> Maybe MsysEnvironment -> RIO env (Maybe MsysEnvironment)
forall a b. (a -> b) -> a -> b
$ MsysEnvironment -> Maybe MsysEnvironment
forall a. a -> Maybe a
Just MsysEnvironment
msysEnv
          else ConfigPrettyException -> RIO env (Maybe MsysEnvironment)
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (ConfigPrettyException -> RIO env (Maybe MsysEnvironment))
-> ConfigPrettyException -> RIO env (Maybe MsysEnvironment)
forall a b. (a -> b) -> a -> b
$ MsysEnvironment -> Arch -> ConfigPrettyException
BadMsysEnvironment MsysEnvironment
msysEnv Arch
arch
    PlatformVariant
platformVariant <- IO PlatformVariant -> RIO env PlatformVariant
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PlatformVariant -> RIO env PlatformVariant)
-> IO PlatformVariant -> RIO env PlatformVariant
forall a b. (a -> b) -> a -> b
$
      PlatformVariant
-> (String -> PlatformVariant) -> Maybe String -> PlatformVariant
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PlatformVariant
PlatformVariantNone String -> PlatformVariant
PlatformVariant (Maybe String -> PlatformVariant)
-> IO (Maybe String) -> IO PlatformVariant
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
platformVariantEnvVar
    let build :: BuildOpts
build = BuildOptsMonoid -> BuildOpts
buildOptsFromMonoid ConfigMonoid
configMonoid.buildOpts
    DockerOpts
docker <-
      Maybe Project
-> Maybe AbstractSnapshot -> DockerOptsMonoid -> RIO env DockerOpts
forall (m :: * -> *).
MonadThrow m =>
Maybe Project
-> Maybe AbstractSnapshot -> DockerOptsMonoid -> m DockerOpts
dockerOptsFromMonoid (((Project, Path Abs File) -> Project)
-> Maybe (Project, Path Abs File) -> Maybe Project
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Project, Path Abs File) -> Project
forall a b. (a, b) -> a
fst Maybe (Project, Path Abs File)
mproject) Maybe AbstractSnapshot
snapshot ConfigMonoid
configMonoid.dockerOpts
    NixOpts
nix <- NixOptsMonoid -> OS -> RIO env NixOpts
forall env.
(HasRunner env, HasTerm env) =>
NixOptsMonoid -> OS -> RIO env NixOpts
nixOptsFromMonoid ConfigMonoid
configMonoid.nixOpts OS
os
    Bool
systemGHC <-
      case (First Bool -> Maybe Bool
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.systemGHC, NixOpts
nix.enable) of
        (Just Bool
False, Bool
True) ->
          ConfigException -> RIO env Bool
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM ConfigException
NixRequiresSystemGhc
        (Maybe Bool, Bool)
_ ->
          Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            (Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst
              (DockerOpts
docker.enable Bool -> Bool -> Bool
|| NixOpts
nix.enable)
              ConfigMonoid
configMonoid.systemGHC)
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe GHCVariant -> Bool
forall a. Maybe a -> Bool
isJust Maybe GHCVariant
ghcVariant Bool -> Bool -> Bool
&& Bool
systemGHC) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
      ConfigException -> RIO env ()
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM ConfigException
ManualGHCVariantSettingsAreIncompatibleWithSystemGHC
    [(String, String)]
rawEnv <- IO [(String, String)] -> RIO env [(String, String)]
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(String, String)]
getEnvironment
    Map Text Text
pathsEnv <- (ProcessException -> RIO env (Map Text Text))
-> (Map Text Text -> RIO env (Map Text Text))
-> Either ProcessException (Map Text Text)
-> RIO env (Map Text Text)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ProcessException -> RIO env (Map Text Text)
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM Map Text Text -> RIO env (Map Text Text)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Either ProcessException (Map Text Text)
 -> RIO env (Map Text Text))
-> Either ProcessException (Map Text Text)
-> RIO env (Map Text Text)
forall a b. (a -> b) -> a -> b
$ [String]
-> Map Text Text -> Either ProcessException (Map Text Text)
augmentPathMap ((Path Abs Dir -> String) -> [Path Abs Dir] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath ConfigMonoid
configMonoid.extraPath)
                       ([(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (((String, String) -> (Text, Text))
-> [(String, String)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text)
-> (String -> Text) -> (String, String) -> (Text, Text)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** String -> Text
T.pack) [(String, String)]
rawEnv))
    ProcessContext
origEnv <- Map Text Text -> RIO env ProcessContext
forall (m :: * -> *).
MonadIO m =>
Map Text Text -> m ProcessContext
mkProcessContext Map Text Text
pathsEnv
    let processContextSettings :: EnvSettings -> IO ProcessContext
processContextSettings EnvSettings
_ = ProcessContext -> IO ProcessContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessContext
origEnv
    Path Abs Dir
localProgramsBase <- case First (Path Abs Dir) -> Maybe (Path Abs Dir)
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.localProgramsBase of
      Maybe (Path Abs Dir)
Nothing -> Path Abs Dir
-> Platform -> ProcessContext -> RIO env (Path Abs Dir)
forall (m :: * -> *).
MonadThrow m =>
Path Abs Dir -> Platform -> ProcessContext -> m (Path Abs Dir)
getDefaultLocalProgramsBase Path Abs Dir
stackRoot Platform
platform ProcessContext
origEnv
      Just Path Abs Dir
path -> Path Abs Dir -> RIO env (Path Abs Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
path
    let localProgramsFilePath :: String
localProgramsFilePath = Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
localProgramsBase
        spaceInLocalProgramsPath :: Bool
spaceInLocalProgramsPath = Char
' ' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
localProgramsFilePath
        nonLatin1InLocalProgramsPath :: Bool
nonLatin1InLocalProgramsPath = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isLatin1 String
localProgramsFilePath
        problematicLocalProgramsPath :: Bool
problematicLocalProgramsPath =
             Bool
nonLatin1InLocalProgramsPath
          Bool -> Bool -> Bool
|| (Bool
osIsWindows Bool -> Bool -> Bool
&& Bool
spaceInLocalProgramsPath)
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
problematicLocalProgramsPath (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
      let msgSpace :: [StyleDoc]
msgSpace =
            [ String -> StyleDoc
flow String
"It contains a space character. This will prevent building \
                   \with GHC 9.4.1 or later."
            | Bool
osIsWindows Bool -> Bool -> Bool
&& Bool
spaceInLocalProgramsPath
            ]
      [StyleDoc]
msgNoShort <- if Bool
osIsWindows Bool -> Bool -> Bool
&& Bool
spaceInLocalProgramsPath
        then do
          Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
localProgramsBase
          -- getShortPathName returns the long path name when a short name does not

          -- exist.

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

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

            -- relative

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

          -- parseRelAsAbsDirMaybe utility and use it along with

          -- resolveDirMaybe.

          RIO env (Path Abs Dir)
-> (SomeException -> RIO env (Path Abs Dir))
-> RIO env (Path Abs Dir)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny`
          RIO env (Path Abs Dir) -> SomeException -> RIO env (Path Abs Dir)
forall a b. a -> b -> a
const (ConfigException -> RIO env (Path Abs Dir)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (String -> ConfigException
NoSuchDirectory String
userPath))
    Maybe (Path Abs File)
fileWatchHook <-
      case First String -> Maybe String
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.fileWatchHook of
        Maybe String
Nothing -> Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs File)
forall a. Maybe a
Nothing
        Just String
userPath ->
          ( case Maybe (Project, Path Abs File)
mproject of
              -- Not in a project

              Maybe (Project, Path Abs File)
Nothing -> Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just (Path Abs File -> Maybe (Path Abs File))
-> RIO env (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> RIO env (Path Abs File)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs File)
resolveFile' String
userPath
              -- Resolves to the project dir and appends the user path if it is

              -- relative

              Just (Project
_, Path Abs File
configYaml) ->
                Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just (Path Abs File -> Maybe (Path Abs File))
-> RIO env (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs Dir -> String -> RIO env (Path Abs File)
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Path Abs File)
resolveFile (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
configYaml) String
userPath
          )
          -- TODO: Either catch specific exceptions or add a

          -- parseRelAsAbsFileMaybe utility and use it along with

          -- resolveFileMaybe.

          RIO env (Maybe (Path Abs File))
-> (SomeException -> RIO env (Maybe (Path Abs File)))
-> RIO env (Maybe (Path Abs File))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny`
          RIO env (Maybe (Path Abs File))
-> SomeException -> RIO env (Maybe (Path Abs File))
forall a b. a -> b -> a
const (ConfigException -> RIO env (Maybe (Path Abs File))
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (String -> ConfigException
NoSuchFile String
userPath))
    Int
jobs <-
      case First Int -> Maybe Int
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.jobs of
        Maybe Int
Nothing -> IO Int -> RIO env Int
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumProcessors
        Just Int
i -> Int -> RIO env Int
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
i
    let concurrentTests :: Bool
concurrentTests =
          Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst Bool
True ConfigMonoid
configMonoid.concurrentTests
        templateParams :: Map Text Text
templateParams = ConfigMonoid
configMonoid.templateParameters
        scmInit :: Maybe SCM
scmInit = First SCM -> Maybe SCM
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.scmInit
        cabalConfigOpts :: Map CabalConfigKey [Text]
cabalConfigOpts = MonoidMap CabalConfigKey (Dual [Text]) -> Map CabalConfigKey [Text]
forall a b. Coercible a b => a -> b
coerce ConfigMonoid
configMonoid.cabalConfigOpts
        ghcOptionsByName :: Map PackageName [Text]
ghcOptionsByName = MonoidMap PackageName (Dual [Text]) -> Map PackageName [Text]
forall a b. Coercible a b => a -> b
coerce ConfigMonoid
configMonoid.ghcOptionsByName
        ghcOptionsByCat :: Map ApplyGhcOptions [Text]
ghcOptionsByCat = MonoidMap ApplyGhcOptions (Dual [Text])
-> Map ApplyGhcOptions [Text]
forall a b. Coercible a b => a -> b
coerce ConfigMonoid
configMonoid.ghcOptionsByCat
        setupInfoLocations :: [String]
setupInfoLocations = ConfigMonoid
configMonoid.setupInfoLocations
        setupInfoInline :: SetupInfo
setupInfoInline = ConfigMonoid
configMonoid.setupInfoInline
        pvpBounds :: PvpBounds
pvpBounds =
          PvpBounds -> First PvpBounds -> PvpBounds
forall a. a -> First a -> a
fromFirst (PvpBoundsType -> Bool -> PvpBounds
PvpBounds PvpBoundsType
PvpBoundsNone Bool
False) ConfigMonoid
configMonoid.pvpBounds
        modifyCodePage :: Bool
modifyCodePage = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.modifyCodePage
        rebuildGhcOptions :: Bool
rebuildGhcOptions =
          FirstFalse -> Bool
fromFirstFalse ConfigMonoid
configMonoid.rebuildGhcOptions
        applyGhcOptions :: ApplyGhcOptions
applyGhcOptions =
          ApplyGhcOptions -> First ApplyGhcOptions -> ApplyGhcOptions
forall a. a -> First a -> a
fromFirst ApplyGhcOptions
AGOLocals ConfigMonoid
configMonoid.applyGhcOptions
        applyProgOptions :: ApplyProgOptions
applyProgOptions =
          ApplyProgOptions -> First ApplyProgOptions -> ApplyProgOptions
forall a. a -> First a -> a
fromFirst ApplyProgOptions
APOLocals ConfigMonoid
configMonoid.applyProgOptions
        allowNewer :: First Bool
allowNewer = ConfigMonoid
configMonoid.allowNewer
        allowNewerDeps :: Maybe [PackageName]
allowNewerDeps = Maybe AllowNewerDeps -> Maybe [PackageName]
forall a b. Coercible a b => a -> b
coerce ConfigMonoid
configMonoid.allowNewerDeps
    First AbstractSnapshot
defaultInitSnapshot <- do
      Path Abs Dir
root <- RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
      let resolve :: First (Unresolved AbstractSnapshot)
-> RIO env (First AbstractSnapshot)
resolve = (Maybe AbstractSnapshot -> First AbstractSnapshot
forall a. Maybe a -> First a
First <$>) (RIO env (Maybe AbstractSnapshot)
 -> RIO env (First AbstractSnapshot))
-> (First (Unresolved AbstractSnapshot)
    -> RIO env (Maybe AbstractSnapshot))
-> First (Unresolved AbstractSnapshot)
-> RIO env (First AbstractSnapshot)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unresolved AbstractSnapshot -> RIO env AbstractSnapshot)
-> Maybe (Unresolved AbstractSnapshot)
-> RIO env (Maybe AbstractSnapshot)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (Maybe (Path Abs Dir)
-> Unresolved AbstractSnapshot -> RIO env AbstractSnapshot
forall (m :: * -> *) a.
MonadIO m =>
Maybe (Path Abs Dir) -> Unresolved a -> m a
resolvePaths (Path Abs Dir -> Maybe (Path Abs Dir)
forall a. a -> Maybe a
Just Path Abs Dir
root)) (Maybe (Unresolved AbstractSnapshot)
 -> RIO env (Maybe AbstractSnapshot))
-> (First (Unresolved AbstractSnapshot)
    -> Maybe (Unresolved AbstractSnapshot))
-> First (Unresolved AbstractSnapshot)
-> RIO env (Maybe AbstractSnapshot)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. First (Unresolved AbstractSnapshot)
-> Maybe (Unresolved AbstractSnapshot)
forall a. First a -> Maybe a
getFirst
      First (Unresolved AbstractSnapshot)
-> RIO env (First AbstractSnapshot)
resolve ConfigMonoid
configMonoid.defaultInitSnapshot
    let defaultTemplate :: Maybe TemplateName
defaultTemplate = First TemplateName -> Maybe TemplateName
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.defaultTemplate
        dumpLogs :: DumpLogs
dumpLogs = DumpLogs -> First DumpLogs -> DumpLogs
forall a. a -> First a -> a
fromFirst DumpLogs
DumpWarningLogs ConfigMonoid
configMonoid.dumpLogs
        saveHackageCreds :: FirstTrue
saveHackageCreds = ConfigMonoid
configMonoid.saveHackageCreds
        hackageBaseUrl :: Text
hackageBaseUrl =
          Text -> First Text -> Text
forall a. a -> First a -> a
fromFirst Text
Constants.hackageBaseUrl ConfigMonoid
configMonoid.hackageBaseUrl
        hideSourcePaths :: Bool
hideSourcePaths = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.hideSourcePaths
        recommendStackUpgrade :: Bool
recommendStackUpgrade = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.recommendStackUpgrade
        notifyIfNixOnPath :: Bool
notifyIfNixOnPath = FirstFalse -> Bool
fromFirstFalse ConfigMonoid
configMonoid.notifyIfNixOnPath
        notifyIfGhcUntested :: Bool
notifyIfGhcUntested = FirstFalse -> Bool
fromFirstFalse ConfigMonoid
configMonoid.notifyIfGhcUntested
        notifyIfCabalUntested :: Bool
notifyIfCabalUntested = FirstFalse -> Bool
fromFirstFalse ConfigMonoid
configMonoid.notifyIfCabalUntested
        notifyIfArchUnknown :: Bool
notifyIfArchUnknown = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.notifyIfArchUnknown
        notifyIfNoRunTests :: Bool
notifyIfNoRunTests = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.notifyIfNoRunTests
        notifyIfNoRunBenchmarks :: Bool
notifyIfNoRunBenchmarks =
          FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.notifyIfNoRunBenchmarks
        noRunCompile :: Bool
noRunCompile = FirstFalse -> Bool
fromFirstFalse ConfigMonoid
configMonoid.noRunCompile
    Bool
allowDifferentUser <-
      case First Bool -> Maybe Bool
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.allowDifferentUser of
        Just Bool
True -> Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        Maybe Bool
_ -> RIO env Bool
forall (m :: * -> *). MonadIO m => m Bool
getInContainer
    Runner
configRunner' <- Getting Runner env Runner -> RIO env Runner
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Runner env Runner
forall env. HasRunner env => Lens' env Runner
Lens' env Runner
runnerL
    Bool
useAnsi <- IO Bool -> RIO env Bool
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RIO env Bool) -> IO Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hNowSupportsANSI Handle
stderr
    let stylesUpdate' :: StylesUpdate
stylesUpdate' = (Runner
configRunner' Runner -> Getting StylesUpdate Runner StylesUpdate -> StylesUpdate
forall s a. s -> Getting a s a -> a
^. Getting StylesUpdate Runner StylesUpdate
forall env. HasStylesUpdate env => Lens' env StylesUpdate
Lens' Runner StylesUpdate
stylesUpdateL) StylesUpdate -> StylesUpdate -> StylesUpdate
forall a. Semigroup a => a -> a -> a
<>
          ConfigMonoid
configMonoid.styles
        useColor' :: Bool
useColor' = Runner
configRunner'.useColor
        mUseColor :: Maybe Bool
mUseColor = do
          ColorWhen
colorWhen <- First ColorWhen -> Maybe ColorWhen
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.colorWhen
          Bool -> Maybe Bool
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ case ColorWhen
colorWhen of
            ColorWhen
ColorNever  -> Bool
False
            ColorWhen
ColorAlways -> Bool
True
            ColorWhen
ColorAuto  -> Bool
useAnsi
        useColor'' :: Bool
useColor'' = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
useColor' Maybe Bool
mUseColor
        configRunner'' :: Runner
configRunner'' = Runner
configRunner'
          Runner -> (Runner -> Runner) -> Runner
forall a b. a -> (a -> b) -> b
& (ProcessContext -> Identity ProcessContext)
-> Runner -> Identity Runner
forall env. HasProcessContext env => Lens' env ProcessContext
Lens' Runner ProcessContext
processContextL ((ProcessContext -> Identity ProcessContext)
 -> Runner -> Identity Runner)
-> ProcessContext -> Runner -> Runner
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ProcessContext
origEnv
          Runner -> (Runner -> Runner) -> Runner
forall a b. a -> (a -> b) -> b
& (StylesUpdate -> Identity StylesUpdate)
-> Runner -> Identity Runner
forall env. HasStylesUpdate env => Lens' env StylesUpdate
Lens' Runner StylesUpdate
stylesUpdateL ((StylesUpdate -> Identity StylesUpdate)
 -> Runner -> Identity Runner)
-> StylesUpdate -> Runner -> Runner
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StylesUpdate
stylesUpdate'
          Runner -> (Runner -> Runner) -> Runner
forall a b. a -> (a -> b) -> b
& (Bool -> Identity Bool) -> Runner -> Identity Runner
forall env. HasTerm env => Lens' env Bool
Lens' Runner Bool
useColorL ((Bool -> Identity Bool) -> Runner -> Identity Runner)
-> Bool -> Runner -> Runner
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
useColor''
        go :: GlobalOpts
go = Runner
configRunner'.globalOpts
        pic :: PackageIndexConfig
pic = PackageIndexConfig
-> First PackageIndexConfig -> PackageIndexConfig
forall a. a -> First a -> a
fromFirst  PackageIndexConfig
defaultPackageIndexConfig ConfigMonoid
configMonoid.packageIndex
    Maybe String
mpantryRoot <- IO (Maybe String) -> RIO env (Maybe String)
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> RIO env (Maybe String))
-> IO (Maybe String) -> RIO env (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
pantryRootEnvVar
    Path Abs Dir
pantryRoot <-
      case Maybe String
mpantryRoot of
        Just String
dir ->
          case String -> Maybe (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir String
dir of
            Maybe (Path Abs Dir)
Nothing -> ParseAbsolutePathException -> RIO env (Path Abs Dir)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (ParseAbsolutePathException -> RIO env (Path Abs Dir))
-> ParseAbsolutePathException -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ String -> String -> ParseAbsolutePathException
ParseAbsolutePathException String
pantryRootEnvVar String
dir
            Just Path Abs Dir
x -> Path Abs Dir -> RIO env (Path Abs Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
x
        Maybe String
Nothing -> Path Abs Dir -> RIO env (Path Abs Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir -> RIO env (Path Abs Dir))
-> Path Abs Dir -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
stackRoot Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirPantry
    let snapLoc :: SnapName -> RawSnapshotLocation
snapLoc =
          case First Text -> Maybe Text
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.snapshotLocation of
            Maybe Text
Nothing -> SnapName -> RawSnapshotLocation
defaultSnapshotLocation
            Just Text
addr ->
              SnapName -> RawSnapshotLocation
customSnapshotLocation
               where
                customSnapshotLocation :: SnapName -> RawSnapshotLocation
customSnapshotLocation (LTS Int
x Int
y) =
                  Utf8Builder -> RawSnapshotLocation
mkRSLUrl (Utf8Builder -> RawSnapshotLocation)
-> Utf8Builder -> RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ Utf8Builder
addr'
                    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/lts/" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
x
                    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
y Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".yaml"
                customSnapshotLocation (Nightly Day
date) =
                  let (Year
year, Int
month, Int
day) = Day -> (Year, Int, Int)
toGregorian Day
date
                  in  Utf8Builder -> RawSnapshotLocation
mkRSLUrl (Utf8Builder -> RawSnapshotLocation)
-> Utf8Builder -> RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ Utf8Builder
addr'
                        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/nightly/"
                        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Year -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Year
year
                        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
month
                        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
day Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".yaml"
                mkRSLUrl :: Utf8Builder -> RawSnapshotLocation
mkRSLUrl Utf8Builder
builder = Text -> Maybe BlobKey -> RawSnapshotLocation
RSLUrl (Utf8Builder -> Text
utf8BuilderToText Utf8Builder
builder) Maybe BlobKey
forall a. Maybe a
Nothing
                addr' :: Utf8Builder
addr' = Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Text -> Utf8Builder) -> Text -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/') Text
addr
    WantedCompiler -> GlobalHintsLocation
globalHintsLoc <- case First (Unresolved GlobalHintsLocation)
-> Maybe (Unresolved GlobalHintsLocation)
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.globalHintsLocation of
      Maybe (Unresolved GlobalHintsLocation)
Nothing -> (WantedCompiler -> GlobalHintsLocation)
-> RIO env (WantedCompiler -> GlobalHintsLocation)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WantedCompiler -> GlobalHintsLocation
defaultGlobalHintsLocation
      Just Unresolved GlobalHintsLocation
unresolverGlobalHintsLoc -> do
        GlobalHintsLocation
resolvedGlobalHintsLocation <-
          Maybe (Path Abs Dir)
-> Unresolved GlobalHintsLocation -> RIO env GlobalHintsLocation
forall (m :: * -> *) a.
MonadIO m =>
Maybe (Path Abs Dir) -> Unresolved a -> m a
resolvePaths (Path Abs Dir -> Maybe (Path Abs Dir)
forall a. a -> Maybe a
Just Path Abs Dir
stackRoot) Unresolved GlobalHintsLocation
unresolverGlobalHintsLoc
        (WantedCompiler -> GlobalHintsLocation)
-> RIO env (WantedCompiler -> GlobalHintsLocation)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((WantedCompiler -> GlobalHintsLocation)
 -> RIO env (WantedCompiler -> GlobalHintsLocation))
-> (WantedCompiler -> GlobalHintsLocation)
-> RIO env (WantedCompiler -> GlobalHintsLocation)
forall a b. (a -> b) -> a -> b
$ GlobalHintsLocation -> WantedCompiler -> GlobalHintsLocation
forall a b. a -> b -> a
const GlobalHintsLocation
resolvedGlobalHintsLocation
    let stackDeveloperMode :: Bool
stackDeveloperMode = Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst
          Bool
stackDeveloperModeDefault
          ConfigMonoid
configMonoid.stackDeveloperMode
        hpackForce :: Force
hpackForce = if FirstFalse -> Bool
fromFirstFalse ConfigMonoid
configMonoid.hpackForce
          then Force
Hpack.Force
          else Force
Hpack.NoForce
        casa :: Maybe (CasaRepoPrefix, Int)
casa =
          if FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.casaOpts.enable
            then
              let casaRepoPrefix :: CasaRepoPrefix
casaRepoPrefix = CasaRepoPrefix -> First CasaRepoPrefix -> CasaRepoPrefix
forall a. a -> First a -> a
fromFirst
                    (CasaRepoPrefix -> First CasaRepoPrefix -> CasaRepoPrefix
forall a. a -> First a -> a
fromFirst CasaRepoPrefix
defaultCasaRepoPrefix ConfigMonoid
configMonoid.casaRepoPrefix)
                    ConfigMonoid
configMonoid.casaOpts.repoPrefix
                  casaMaxKeysPerRequest :: Int
casaMaxKeysPerRequest = Int -> First Int -> Int
forall a. a -> First a -> a
fromFirst
                    Int
defaultCasaMaxPerRequest
                    ConfigMonoid
configMonoid.casaOpts.maxKeysPerRequest
              in  (CasaRepoPrefix, Int) -> Maybe (CasaRepoPrefix, Int)
forall a. a -> Maybe a
Just (CasaRepoPrefix
casaRepoPrefix, Int
casaMaxKeysPerRequest)
            else Maybe (CasaRepoPrefix, Int)
forall a. Maybe a
Nothing
    GlobalOpts
-> Bool -> StylesUpdate -> (LogFunc -> RIO env a) -> RIO env a
forall (m :: * -> *) a.
MonadUnliftIO m =>
GlobalOpts -> Bool -> StylesUpdate -> (LogFunc -> m a) -> m a
withNewLogFunc GlobalOpts
go Bool
useColor'' StylesUpdate
stylesUpdate' ((LogFunc -> RIO env a) -> RIO env a)
-> (LogFunc -> RIO env a) -> RIO env a
forall a b. (a -> b) -> a -> b
$ \LogFunc
logFunc -> do
      let runner :: Runner
runner = Runner
configRunner'' Runner -> (Runner -> Runner) -> Runner
forall a b. a -> (a -> b) -> b
& (LogFunc -> Identity LogFunc) -> Runner -> Identity Runner
forall env. HasLogFunc env => Lens' env LogFunc
Lens' Runner LogFunc
logFuncL ((LogFunc -> Identity LogFunc) -> Runner -> Identity Runner)
-> LogFunc -> Runner -> Runner
forall s t a b. ASetter s t a b -> b -> s -> t
.~ LogFunc
logFunc
      LogFunc -> RIO env a -> RIO env a
forall env a. HasLogFunc env => LogFunc -> RIO env a -> RIO env a
withLocalLogFunc LogFunc
logFunc (RIO env a -> RIO env a) -> RIO env a -> RIO env a
forall a b. (a -> b) -> a -> b
$ RIO env a -> RIO env a
forall env a. HasLogFunc env => RIO env a -> RIO env a
handleMigrationException (RIO env a -> RIO env a) -> RIO env a -> RIO env a
forall a b. (a -> b) -> a -> b
$ do
        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ case Maybe (CasaRepoPrefix, Int)
casa of
          Maybe (CasaRepoPrefix, Int)
Nothing -> Utf8Builder
"Use of Casa server disabled."
          Just (CasaRepoPrefix
repoPrefix, Int
maxKeys) ->
               Utf8Builder
"Use of Casa server enabled: ("
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (CasaRepoPrefix -> String
forall a. Show a => a -> String
show CasaRepoPrefix
repoPrefix)
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", "
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Int -> String
forall a. Show a => a -> String
show Int
maxKeys)
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")."
        Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Force
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (WantedCompiler -> GlobalHintsLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
forall env a.
HasLogFunc env =>
Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Force
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (WantedCompiler -> GlobalHintsLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig'
          Path Abs Dir
pantryRoot
          PackageIndexConfig
pic
          (HpackExecutable
-> (String -> HpackExecutable) -> Maybe String -> HpackExecutable
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HpackExecutable
HpackBundled String -> HpackExecutable
HpackCommand (Maybe String -> HpackExecutable)
-> Maybe String -> HpackExecutable
forall a b. (a -> b) -> a -> b
$ First String -> Maybe String
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.overrideHpack)
          Force
hpackForce
          Int
clConnectionCount
          Maybe (CasaRepoPrefix, Int)
casa
          SnapName -> RawSnapshotLocation
snapLoc
          WantedCompiler -> GlobalHintsLocation
globalHintsLoc
          (\PantryConfig
pantryConfig -> Path Abs File -> (UserStorage -> RIO env a) -> RIO env a
forall env a.
HasLogFunc env =>
Path Abs File -> (UserStorage -> RIO env a) -> RIO env a
initUserStorage
            (Path Abs Dir
stackRoot Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileStorage)
            ( \UserStorage
userStorage -> Config -> RIO env a
inner Config
                { Path Rel Dir
workDir :: Path Rel Dir
workDir :: Path Rel Dir
workDir
                , Path Abs File
userGlobalConfigFile :: Path Abs File
userGlobalConfigFile :: Path Abs File
userGlobalConfigFile
                , BuildOpts
build :: BuildOpts
build :: BuildOpts
build
                , DockerOpts
docker :: DockerOpts
docker :: DockerOpts
docker
                , NixOpts
nix :: NixOpts
nix :: NixOpts
nix
                , EnvSettings -> IO ProcessContext
processContextSettings :: EnvSettings -> IO ProcessContext
processContextSettings :: EnvSettings -> IO ProcessContext
processContextSettings
                , Path Abs Dir
localProgramsBase :: Path Abs Dir
localProgramsBase :: Path Abs Dir
localProgramsBase
                , Path Abs Dir
localPrograms :: Path Abs Dir
localPrograms :: Path Abs Dir
localPrograms
                , Bool
hideTHLoading :: Bool
hideTHLoading :: Bool
hideTHLoading
                , Bool
prefixTimestamps :: Bool
prefixTimestamps :: Bool
prefixTimestamps
                , Platform
platform :: Platform
platform :: Platform
platform
                , PlatformVariant
platformVariant :: PlatformVariant
platformVariant :: PlatformVariant
platformVariant
                , Maybe GHCVariant
ghcVariant :: Maybe GHCVariant
ghcVariant :: Maybe GHCVariant
ghcVariant
                , Maybe CompilerBuild
ghcBuild :: Maybe CompilerBuild
ghcBuild :: Maybe CompilerBuild
ghcBuild
                , Text
latestSnapshot :: Text
latestSnapshot :: Text
latestSnapshot
                , Bool
systemGHC :: Bool
systemGHC :: Bool
systemGHC
                , Bool
installGHC :: Bool
installGHC :: Bool
installGHC
                , Bool
installMsys :: Bool
installMsys :: Bool
installMsys
                , Bool
skipGHCCheck :: Bool
skipGHCCheck :: Bool
skipGHCCheck
                , Bool
skipMsys :: Bool
skipMsys :: Bool
skipMsys
                , Maybe MsysEnvironment
msysEnvironment :: Maybe MsysEnvironment
msysEnvironment :: Maybe MsysEnvironment
msysEnvironment
                , VersionCheck
compilerCheck :: VersionCheck
compilerCheck :: VersionCheck
compilerCheck
                , CompilerRepository
compilerRepository :: CompilerRepository
compilerRepository :: CompilerRepository
compilerRepository
                , Path Abs Dir
localBin :: Path Abs Dir
localBin :: Path Abs Dir
localBin
                , Maybe (Path Abs File)
fileWatchHook :: Maybe (Path Abs File)
fileWatchHook :: Maybe (Path Abs File)
fileWatchHook
                , VersionRange
requireStackVersion :: VersionRange
requireStackVersion :: VersionRange
requireStackVersion
                , Int
jobs :: Int
jobs :: Int
jobs
                , Maybe (Path Abs File)
overrideGccPath :: Maybe (Path Abs File)
overrideGccPath :: Maybe (Path Abs File)
overrideGccPath
                , [String]
extraIncludeDirs :: [String]
extraIncludeDirs :: [String]
extraIncludeDirs
                , [String]
extraLibDirs :: [String]
extraLibDirs :: [String]
extraLibDirs
                , [Text]
customPreprocessorExts :: [Text]
customPreprocessorExts :: [Text]
customPreprocessorExts
                , Bool
concurrentTests :: Bool
concurrentTests :: Bool
concurrentTests
                , Map Text Text
templateParams :: Map Text Text
templateParams :: Map Text Text
templateParams
                , Maybe SCM
scmInit :: Maybe SCM
scmInit :: Maybe SCM
scmInit
                , Map PackageName [Text]
ghcOptionsByName :: Map PackageName [Text]
ghcOptionsByName :: Map PackageName [Text]
ghcOptionsByName
                , Map ApplyGhcOptions [Text]
ghcOptionsByCat :: Map ApplyGhcOptions [Text]
ghcOptionsByCat :: Map ApplyGhcOptions [Text]
ghcOptionsByCat
                , Map CabalConfigKey [Text]
cabalConfigOpts :: Map CabalConfigKey [Text]
cabalConfigOpts :: Map CabalConfigKey [Text]
cabalConfigOpts
                , [String]
setupInfoLocations :: [String]
setupInfoLocations :: [String]
setupInfoLocations
                , SetupInfo
setupInfoInline :: SetupInfo
setupInfoInline :: SetupInfo
setupInfoInline
                , PvpBounds
pvpBounds :: PvpBounds
pvpBounds :: PvpBounds
pvpBounds
                , Bool
modifyCodePage :: Bool
modifyCodePage :: Bool
modifyCodePage
                , Bool
rebuildGhcOptions :: Bool
rebuildGhcOptions :: Bool
rebuildGhcOptions
                , ApplyGhcOptions
applyGhcOptions :: ApplyGhcOptions
applyGhcOptions :: ApplyGhcOptions
applyGhcOptions
                , ApplyProgOptions
applyProgOptions :: ApplyProgOptions
applyProgOptions :: ApplyProgOptions
applyProgOptions
                , First Bool
allowNewer :: First Bool
allowNewer :: First Bool
allowNewer
                , Maybe [PackageName]
allowNewerDeps :: Maybe [PackageName]
allowNewerDeps :: Maybe [PackageName]
allowNewerDeps
                , First AbstractSnapshot
defaultInitSnapshot :: First AbstractSnapshot
defaultInitSnapshot :: First AbstractSnapshot
defaultInitSnapshot
                , Maybe TemplateName
defaultTemplate :: Maybe TemplateName
defaultTemplate :: Maybe TemplateName
defaultTemplate
                , Bool
allowDifferentUser :: Bool
allowDifferentUser :: Bool
allowDifferentUser
                , DumpLogs
dumpLogs :: DumpLogs
dumpLogs :: DumpLogs
dumpLogs
                , ProjectConfig (Project, Path Abs File)
project :: ProjectConfig (Project, Path Abs File)
project :: ProjectConfig (Project, Path Abs File)
project
                , Bool
allowLocals :: Bool
allowLocals :: Bool
allowLocals
                , FirstTrue
saveHackageCreds :: FirstTrue
saveHackageCreds :: FirstTrue
saveHackageCreds
                , Text
hackageBaseUrl :: Text
hackageBaseUrl :: Text
hackageBaseUrl
                , Runner
runner :: Runner
runner :: Runner
runner
                , PantryConfig
pantryConfig :: PantryConfig
pantryConfig :: PantryConfig
pantryConfig
                , Path Abs Dir
stackRoot :: Path Abs Dir
stackRoot :: Path Abs Dir
stackRoot
                , Maybe AbstractSnapshot
snapshot :: Maybe AbstractSnapshot
snapshot :: Maybe AbstractSnapshot
snapshot
                , UserStorage
userStorage :: UserStorage
userStorage :: UserStorage
userStorage
                , Bool
hideSourcePaths :: Bool
hideSourcePaths :: Bool
hideSourcePaths
                , Bool
recommendStackUpgrade :: Bool
recommendStackUpgrade :: Bool
recommendStackUpgrade
                , Bool
notifyIfNixOnPath :: Bool
notifyIfNixOnPath :: Bool
notifyIfNixOnPath
                , Bool
notifyIfGhcUntested :: Bool
notifyIfGhcUntested :: Bool
notifyIfGhcUntested
                , Bool
notifyIfCabalUntested :: Bool
notifyIfCabalUntested :: Bool
notifyIfCabalUntested
                , Bool
notifyIfArchUnknown :: Bool
notifyIfArchUnknown :: Bool
notifyIfArchUnknown
                , Bool
notifyIfNoRunTests :: Bool
notifyIfNoRunTests :: Bool
notifyIfNoRunTests
                , Bool
notifyIfNoRunBenchmarks :: Bool
notifyIfNoRunBenchmarks :: Bool
notifyIfNoRunBenchmarks
                , Bool
noRunCompile :: Bool
noRunCompile :: Bool
noRunCompile
                , Bool
stackDeveloperMode :: Bool
stackDeveloperMode :: Bool
stackDeveloperMode
                , Maybe (CasaRepoPrefix, Int)
casa :: Maybe (CasaRepoPrefix, Int)
casa :: Maybe (CasaRepoPrefix, Int)
casa
                }
            )
          )

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

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

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

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

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

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

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

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

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

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

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

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

-- and defaults as necessary.

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

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

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

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

        (ConfigMonoid -> ConfigMonoid) -> [ConfigMonoid] -> [ConfigMonoid]
forall a b. (a -> b) -> [a] -> [b]
map
          (\ConfigMonoid
c -> ConfigMonoid
c {dockerOpts = c.dockerOpts { defaultEnable = Any False }})
          [ConfigMonoid]
extraConfigs0

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

  (Config -> RIO env a) -> RIO env a
withConfig ((Config -> RIO env a) -> RIO env a)
-> (Config -> RIO env a) -> RIO env a
forall a b. (a -> b) -> a -> b
$ \Config
config -> do
    let Platform Arch
arch OS
_ = Config
config.platform
    case Arch
arch of
      OtherArch String
unknownArch
        | Config
config.notifyIfArchUnknown ->
            [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
              [ String -> StyleDoc
flow String
"Unknown value for architecture setting:"
              , Style -> StyleDoc -> StyleDoc
style Style
Shell (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
unknownArch) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
              , String -> StyleDoc
flow String
"To mute this message in future, set"
              , Style -> StyleDoc -> StyleDoc
style Style
Shell (String -> StyleDoc
flow String
"notify-if-arch-unknown: false")
              , String -> StyleDoc
flow String
"in Stack's configuration."
              ]
      Arch
_ -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Version
stackVersion Version -> VersionRange -> Bool
`withinRange` Config
config.requireStackVersion)
      (ConfigException -> RIO env ()
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (VersionRange -> ConfigException
BadStackVersionException Config
config.requireStackVersion))
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Config
config.allowDifferentUser (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
      Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
userOwnsStackRoot (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
        ConfigException -> RIO env ()
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (Path Abs Dir -> ConfigException
UserDoesn'tOwnDirectory Path Abs Dir
stackRoot)
      Maybe (Path Abs Dir) -> (Path Abs Dir -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Config -> Maybe (Path Abs Dir)
configProjectRoot Config
config) ((Path Abs Dir -> RIO env ()) -> RIO env ())
-> (Path Abs Dir -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir ->
        Path Abs Dir -> RIO env ()
forall (m :: * -> *). MonadIO m => Path Abs Dir -> m ()
checkOwnership (Path Abs Dir
dir Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Config
config.workDir)
    Config -> RIO env a
inner Config
config

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

-- by @loadConfig@. values.

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

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

  -- snapshot that can be used below.


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

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

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

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

  Maybe RawSnapshotLocation
mSnapshot <- Maybe AbstractSnapshot
-> (AbstractSnapshot -> RIO Config RawSnapshotLocation)
-> RIO Config (Maybe RawSnapshotLocation)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Config
config.snapshot ((AbstractSnapshot -> RIO Config RawSnapshotLocation)
 -> RIO Config (Maybe RawSnapshotLocation))
-> (AbstractSnapshot -> RIO Config RawSnapshotLocation)
-> RIO Config (Maybe RawSnapshotLocation)
forall a b. (a -> b) -> a -> b
$ \AbstractSnapshot
aSnapshot -> do
    Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO Config ()) -> Utf8Builder -> RIO Config ()
forall a b. (a -> b) -> a -> b
$
          Utf8Builder
"Using snapshot: "
       Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> AbstractSnapshot -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display AbstractSnapshot
aSnapshot
       Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" specified on command line"
    AbstractSnapshot -> RIO Config RawSnapshotLocation
forall env.
HasConfig env =>
AbstractSnapshot -> RIO env RawSnapshotLocation
makeConcreteSnapshot AbstractSnapshot
aSnapshot

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

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

      eitherConfigFile :: Path Abs File
eitherConfigFile = Either (Path Abs File) (Path Abs File) -> Path Abs File
forall a. Either a a -> a
EE.fromEither Either (Path Abs File) (Path Abs File)
configFile
  [Path Abs Dir]
extraPackageDBs <- (String -> RIO Config (Path Abs Dir))
-> [String] -> RIO Config [Path Abs Dir]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> RIO Config (Path Abs Dir)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' Project
project.extraPackageDBs

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

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

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

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

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

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

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

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

  -- prefetch git repos to avoid cloning per subdirectory

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

        then Maybe UnusedFlags
forall a. Maybe a
Nothing
        -- Error about the undefined flags

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

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

-- exception.

checkDuplicateNames :: MonadThrow m => [(PackageName, PackageLocation)] -> m ()
checkDuplicateNames :: forall (m :: * -> *).
MonadThrow m =>
[(PackageName, PackageLocation)] -> m ()
checkDuplicateNames [(PackageName, PackageLocation)]
locals =
  case ((PackageName, [PackageLocation]) -> Bool)
-> [(PackageName, [PackageLocation])]
-> [(PackageName, [PackageLocation])]
forall a. (a -> Bool) -> [a] -> [a]
filter (PackageName, [PackageLocation]) -> Bool
forall {a} {a}. (a, [a]) -> Bool
hasMultiples ([(PackageName, [PackageLocation])]
 -> [(PackageName, [PackageLocation])])
-> [(PackageName, [PackageLocation])]
-> [(PackageName, [PackageLocation])]
forall a b. (a -> b) -> a -> b
$ Map PackageName [PackageLocation]
-> [(PackageName, [PackageLocation])]
forall k a. Map k a -> [(k, a)]
Map.toList (Map PackageName [PackageLocation]
 -> [(PackageName, [PackageLocation])])
-> Map PackageName [PackageLocation]
-> [(PackageName, [PackageLocation])]
forall a b. (a -> b) -> a -> b
$ ([PackageLocation] -> [PackageLocation] -> [PackageLocation])
-> [(PackageName, [PackageLocation])]
-> Map PackageName [PackageLocation]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [PackageLocation] -> [PackageLocation] -> [PackageLocation]
forall a. [a] -> [a] -> [a]
(++) ([(PackageName, [PackageLocation])]
 -> Map PackageName [PackageLocation])
-> [(PackageName, [PackageLocation])]
-> Map PackageName [PackageLocation]
forall a b. (a -> b) -> a -> b
$ ((PackageName, PackageLocation)
 -> (PackageName, [PackageLocation]))
-> [(PackageName, PackageLocation)]
-> [(PackageName, [PackageLocation])]
forall a b. (a -> b) -> [a] -> [b]
map ((PackageLocation -> [PackageLocation])
-> (PackageName, PackageLocation)
-> (PackageName, [PackageLocation])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second PackageLocation -> [PackageLocation]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure) [(PackageName, PackageLocation)]
locals of
    [] -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [(PackageName, [PackageLocation])]
x -> ConfigPrettyException -> m ()
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (ConfigPrettyException -> m ()) -> ConfigPrettyException -> m ()
forall a b. (a -> b) -> a -> b
$ [(PackageName, [PackageLocation])] -> ConfigPrettyException
DuplicateLocalPackageNames [(PackageName, [PackageLocation])]
x
 where
  hasMultiples :: (a, [a]) -> Bool
hasMultiples (a
_, a
_:a
_:[a]
_) = Bool
True
  hasMultiples (a, [a])
_ = Bool
False

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

--

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

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

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

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

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

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

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

-- owned by the current user.

--

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

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

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

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

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

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

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

-- | Check whether the current user (determined with

-- 'System.Posix.User.getEffectiveUserId') is the owner for the given path.

--

-- Will always pure 'True' on Windows.

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

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

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

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

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

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

--

-- Returns most local first

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

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

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

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

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

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

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

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

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

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

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

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

-- based on current directory.

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

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

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

getDefaultUserConfigPath ::
     HasTerm env
  => Path Abs Dir
  -> RIO env (Path Abs File)
getDefaultUserConfigPath :: forall env. HasTerm env => Path Abs Dir -> RIO env (Path Abs File)
getDefaultUserConfigPath Path Abs Dir
configRoot = do
  let userConfigPath :: Path Abs File
userConfigPath = Path Abs Dir -> Path Abs File
defaultUserConfigPath Path Abs Dir
configRoot
  Bool
userConfigExists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
userConfigPath
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
userConfigExists (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
    Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
userConfigPath)
    IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Builder -> IO ()
forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
userConfigPath Builder
forall s. (IsString s, Semigroup s) => s
defaultConfigYaml
  Path Abs File -> RIO env (Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
userConfigPath

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

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