{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Stack.Config
( loadConfig
, loadConfigYaml
, packagesParser
, getImplicitGlobalProjectDir
, getSnapshots
, makeConcreteResolver
, checkOwnership
, getInContainer
, getInNixShell
, defaultConfigYaml
, getProjectConfig
, withBuildConfig
, withNewLogFunc
, determineStackRootAndOwnership
) where
import Control.Monad.Extra ( firstJustM )
import Data.Aeson.Types ( Value )
import Data.Aeson.WarningParser
( WithJSONWarnings (..), logJSONWarnings )
import Data.Array.IArray ( (!), (//) )
import qualified Data.ByteString as S
import Data.ByteString.Builder ( byteString )
import Data.Coerce ( coerce )
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import qualified Data.Map.Merge.Strict as MS
import qualified Data.Monoid
import Data.Monoid.Map ( MonoidMap (..) )
import qualified Data.Text as T
import qualified Data.Yaml as Yaml
import Distribution.System
( Arch (..), OS (..), Platform (..), buildPlatform )
import qualified Distribution.Text ( simpleParse )
import Distribution.Version ( simplifyVersionRange )
import GHC.Conc ( getNumProcessors )
import Network.HTTP.StackClient
( httpJSON, parseUrlThrow, getResponseBody )
import Options.Applicative ( Parser, help, long, metavar, strOption )
import Path
( PathException (..), (</>), parent, parseAbsDir
, parseAbsFile, parseRelDir, stripProperPrefix
)
import Path.Extra ( toFilePathNoTrailingSep )
import Path.Find ( findInParents )
import Path.IO
( XdgDirectory (..), canonicalizePath, doesDirExist
, doesFileExist, ensureDir, forgivingAbsence
, getAppUserDataDir, getCurrentDir, getXdgDir, resolveDir
, resolveDir', resolveFile'
)
import RIO.List ( unzip )
import RIO.Process
( HasProcessContext (..), ProcessContext, augmentPathMap
, envVarsL
, mkProcessContext
)
import RIO.Time ( toGregorian )
import Stack.Build.Haddock ( shouldHaddockDeps )
import Stack.Config.Build ( buildOptsFromMonoid )
import Stack.Config.Docker ( dockerOptsFromMonoid )
import Stack.Config.Nix ( nixOptsFromMonoid )
import Stack.Constants
( defaultGlobalConfigPath, defaultGlobalConfigPathDeprecated
, defaultUserConfigPath, defaultUserConfigPathDeprecated
, implicitGlobalProjectDir
, implicitGlobalProjectDirDeprecated, inContainerEnvVar
, inNixShellEnvVar, osIsWindows, pantryRootEnvVar
, platformVariantEnvVar, relDirBin, relDirStackWork
, relFileReadmeTxt, relFileStorage, relDirPantry
, relDirPrograms, relDirStackProgName, relDirUpperPrograms
, stackDeveloperModeDefault, stackDotYaml, stackProgName
, stackRootEnvVar, stackWorkEnvVar, stackXdgEnvVar
)
import qualified Stack.Constants as Constants
import Stack.Lock ( lockCachedWanted )
import Stack.Prelude
import Stack.SourceMap
( additionalDepPackage, checkFlagsUsedThrowing
, mkProjectPackage
)
import Stack.Storage.Project ( initProjectStorage )
import Stack.Storage.User ( initUserStorage )
import Stack.Storage.Util ( handleMigrationException )
import Stack.Types.AllowNewerDeps ( AllowNewerDeps (..) )
import Stack.Types.ApplyGhcOptions ( ApplyGhcOptions (..) )
import Stack.Types.ApplyProgOptions ( ApplyProgOptions (..) )
import Stack.Types.Build.Exception ( BuildException (..) )
import Stack.Types.BuildConfig ( BuildConfig (..) )
import Stack.Types.BuildOpts ( BuildOpts (..) )
import Stack.Types.ColorWhen ( ColorWhen (..) )
import Stack.Types.Compiler ( defaultCompilerRepository )
import Stack.Types.Config
( Config (..), HasConfig (..), askLatestSnapshotUrl
, configProjectRoot, stackRootL, workDirL
)
import Stack.Types.Config.Exception
( ConfigException (..), ConfigPrettyException (..)
, ParseAbsolutePathException (..), packageIndicesWarning )
import Stack.Types.ConfigMonoid
( ConfigMonoid (..), parseConfigMonoid )
import Stack.Types.Casa ( CasaOptsMonoid (..) )
import Stack.Types.Docker ( DockerOpts (..), DockerOptsMonoid (..) )
import Stack.Types.DumpLogs ( DumpLogs (..) )
import Stack.Types.GlobalOpts ( GlobalOpts (..) )
import Stack.Types.Nix ( NixOpts (..) )
import Stack.Types.Platform
( PlatformVariant (..), platformOnlyRelDir )
import Stack.Types.Project ( Project (..) )
import qualified Stack.Types.Project as Project ( Project (..) )
import Stack.Types.ProjectAndConfigMonoid
( ProjectAndConfigMonoid (..), parseProjectAndConfigMonoid )
import Stack.Types.ProjectConfig ( ProjectConfig (..) )
import Stack.Types.PvpBounds ( PvpBounds (..), PvpBoundsType (..) )
import Stack.Types.Resolver ( AbstractResolver (..), Snapshots (..) )
import Stack.Types.Runner
( HasRunner (..), Runner (..), globalOptsL, terminalL )
import Stack.Types.SourceMap
( CommonPackage (..), DepPackage (..), ProjectPackage (..)
, SMWanted (..)
)
import Stack.Types.StackYamlLoc ( StackYamlLoc (..) )
import Stack.Types.UnusedFlags ( FlagSource (..) )
import Stack.Types.Version
( IntersectingVersionRange (..), VersionCheck (..)
, stackVersion, withinRange
)
import System.Console.ANSI ( hNowSupportsANSI, setSGRCode )
import System.Environment ( getEnvironment, lookupEnv )
import System.Info.ShortPathName ( getShortPathName )
import System.PosixCompat.Files ( fileOwner, getFileStatus )
import System.Posix.User ( getEffectiveUserID )
tryDeprecatedPath ::
HasTerm env
=> Maybe T.Text
-> (Path Abs a -> RIO env Bool)
-> Path Abs a
-> Path Abs a
-> RIO env (Path Abs a, Bool)
tryDeprecatedPath :: forall env a.
HasTerm env =>
Maybe Text
-> (Path Abs a -> RIO env Bool)
-> Path Abs a
-> Path Abs a
-> RIO env (Path Abs a, Bool)
tryDeprecatedPath Maybe Text
mWarningDesc Path Abs a -> RIO env Bool
exists Path Abs a
new Path Abs a
old = do
Bool
newExists <- Path Abs a -> RIO env Bool
exists Path Abs a
new
if Bool
newExists
then (Path Abs a, Bool) -> RIO env (Path Abs a, Bool)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs a
new, Bool
True)
else do
Bool
oldExists <- Path Abs a -> RIO env Bool
exists Path Abs a
old
if Bool
oldExists
then do
case Maybe Text
mWarningDesc of
Maybe Text
Nothing -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just Text
desc ->
[StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
[ String -> StyleDoc
flow String
"Location of"
, String -> StyleDoc
flow (Text -> String
T.unpack Text
desc)
, StyleDoc
"at"
, Style -> StyleDoc -> StyleDoc
style Style
Dir (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Path Abs a -> String
forall b t. Path b t -> String
toFilePath Path Abs a
old)
, String -> StyleDoc
flow String
"is deprecated; rename it to"
, Style -> StyleDoc -> StyleDoc
style Style
Dir (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Path Abs a -> String
forall b t. Path b t -> String
toFilePath Path Abs a
new)
, StyleDoc
"instead."
]
(Path Abs a, Bool) -> RIO env (Path Abs a, Bool)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs a
old, Bool
True)
else (Path Abs a, Bool) -> RIO env (Path Abs a, Bool)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs a
new, Bool
False)
getImplicitGlobalProjectDir ::HasTerm env => Config -> RIO env (Path Abs Dir)
getImplicitGlobalProjectDir :: forall env. HasTerm env => Config -> RIO env (Path Abs Dir)
getImplicitGlobalProjectDir Config
config =
(Path Abs Dir, Bool) -> Path Abs Dir
forall a b. (a, b) -> a
fst ((Path Abs Dir, Bool) -> Path Abs Dir)
-> RIO env (Path Abs Dir, Bool) -> RIO env (Path Abs Dir)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
-> (Path Abs Dir -> RIO env Bool)
-> Path Abs Dir
-> Path Abs Dir
-> RIO env (Path Abs Dir, Bool)
forall env a.
HasTerm env =>
Maybe Text
-> (Path Abs a -> RIO env Bool)
-> Path Abs a
-> Path Abs a
-> RIO env (Path Abs a, Bool)
tryDeprecatedPath
Maybe Text
forall a. Maybe a
Nothing
Path Abs Dir -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist
(Path Abs Dir -> Path Abs Dir
implicitGlobalProjectDir Path Abs Dir
stackRoot)
(Path Abs Dir -> Path Abs Dir
implicitGlobalProjectDirDeprecated Path Abs Dir
stackRoot)
where
stackRoot :: Path Abs Dir
stackRoot = Getting (Path Abs Dir) Config (Path Abs Dir)
-> Config -> Path Abs Dir
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) Config (Path Abs Dir)
forall s. HasConfig s => Lens' s (Path Abs Dir)
Lens' Config (Path Abs Dir)
stackRootL Config
config
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
makeConcreteResolver ::
HasConfig env
=> AbstractResolver
-> RIO env RawSnapshotLocation
makeConcreteResolver :: forall env.
HasConfig env =>
AbstractResolver -> RIO env RawSnapshotLocation
makeConcreteResolver (ARResolver RawSnapshotLocation
r) = RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshotLocation
r
makeConcreteResolver AbstractResolver
ar = do
RawSnapshotLocation
r <-
case AbstractResolver
ar of
AbstractResolver
ARGlobal -> do
Config
config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL
Path Abs Dir
implicitGlobalDir <- Config -> RIO env (Path Abs Dir)
forall env. HasTerm env => Config -> RIO env (Path Abs Dir)
getImplicitGlobalProjectDir Config
config
let fp :: Path Abs File
fp = Path Abs Dir
implicitGlobalDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
stackDotYaml
IO ProjectAndConfigMonoid
iopc <- (Value -> Parser (WithJSONWarnings (IO ProjectAndConfigMonoid)))
-> Path Abs File -> RIO env (IO ProjectAndConfigMonoid)
forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env a
loadConfigYaml (Path Abs Dir
-> Value -> Parser (WithJSONWarnings (IO ProjectAndConfigMonoid))
parseProjectAndConfigMonoid (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
fp)) Path Abs File
fp
ProjectAndConfigMonoid Project
project ConfigMonoid
_ <- IO ProjectAndConfigMonoid -> RIO env ProjectAndConfigMonoid
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ProjectAndConfigMonoid
iopc
RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Project
project.resolver
AbstractResolver
ARLatestNightly ->
SnapName -> RawSnapshotLocation
RSLSynonym (SnapName -> RawSnapshotLocation)
-> (Snapshots -> SnapName) -> Snapshots -> RawSnapshotLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> SnapName
Nightly (Day -> SnapName) -> (Snapshots -> Day) -> Snapshots -> SnapName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.nightly) (Snapshots -> RawSnapshotLocation)
-> RIO env Snapshots -> RIO env RawSnapshotLocation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RIO env Snapshots
forall env. HasConfig env => RIO env Snapshots
getSnapshots
ARLatestLTSMajor Int
x -> do
Snapshots
snapshots <- RIO env Snapshots
forall env. HasConfig env => RIO env Snapshots
getSnapshots
case Int -> IntMap Int -> Maybe Int
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
x Snapshots
snapshots.lts of
Maybe Int
Nothing -> ConfigException -> RIO env RawSnapshotLocation
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (ConfigException -> RIO env RawSnapshotLocation)
-> ConfigException -> RIO env RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ Int -> ConfigException
NoLTSWithMajorVersion Int
x
Just Int
y -> RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawSnapshotLocation -> RIO env RawSnapshotLocation)
-> RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ SnapName -> RawSnapshotLocation
RSLSynonym (SnapName -> RawSnapshotLocation)
-> SnapName -> RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ Int -> Int -> SnapName
LTS Int
x Int
y
AbstractResolver
ARLatestLTS -> do
Snapshots
snapshots <- RIO env Snapshots
forall env. HasConfig env => RIO env Snapshots
getSnapshots
if IntMap Int -> Bool
forall a. IntMap a -> Bool
IntMap.null Snapshots
snapshots.lts
then ConfigException -> RIO env RawSnapshotLocation
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ConfigException
NoLTSFound
else let (Int
x, Int
y) = IntMap Int -> (Int, Int)
forall a. IntMap a -> (Int, a)
IntMap.findMax Snapshots
snapshots.lts
in RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawSnapshotLocation -> RIO env RawSnapshotLocation)
-> RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ SnapName -> RawSnapshotLocation
RSLSynonym (SnapName -> RawSnapshotLocation)
-> SnapName -> RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ Int -> Int -> SnapName
LTS Int
x Int
y
[StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
[ String -> StyleDoc
flow String
"Selected resolver:"
, Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> Text
forall a. Display a => a -> Text
textDisplay RawSnapshotLocation
r) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshotLocation
r
getLatestResolver :: HasConfig env => RIO env RawSnapshotLocation
getLatestResolver :: forall env. HasConfig env => RIO env RawSnapshotLocation
getLatestResolver = do
Snapshots
snapshots <- RIO env Snapshots
forall env. HasConfig env => RIO env Snapshots
getSnapshots
let mlts :: Maybe SnapName
mlts = (Int -> Int -> SnapName) -> (Int, Int) -> SnapName
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> SnapName
LTS ((Int, Int) -> SnapName) -> Maybe (Int, Int) -> Maybe SnapName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
[(Int, Int)] -> Maybe (Int, Int)
forall a. [a] -> Maybe a
listToMaybe ([(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a]
reverse (IntMap Int -> [(Int, Int)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList Snapshots
snapshots.lts))
RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawSnapshotLocation -> RIO env RawSnapshotLocation)
-> RawSnapshotLocation -> RIO env RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ SnapName -> RawSnapshotLocation
RSLSynonym (SnapName -> RawSnapshotLocation)
-> SnapName -> RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ SnapName -> Maybe SnapName -> SnapName
forall a. a -> Maybe a -> a
fromMaybe (Day -> SnapName
Nightly Snapshots
snapshots.nightly) Maybe SnapName
mlts
configFromConfigMonoid ::
(HasRunner env, HasTerm env)
=> Path Abs Dir
-> Path Abs File
-> Maybe AbstractResolver
-> ProjectConfig (Project, Path Abs File)
-> ConfigMonoid
-> (Config -> RIO env a)
-> RIO env a
configFromConfigMonoid :: forall env a.
(HasRunner env, HasTerm env) =>
Path Abs Dir
-> Path Abs File
-> Maybe AbstractResolver
-> ProjectConfig (Project, Path Abs File)
-> ConfigMonoid
-> (Config -> RIO env a)
-> RIO env a
configFromConfigMonoid
Path Abs Dir
stackRoot
Path Abs File
userConfigPath
Maybe AbstractResolver
resolver
ProjectConfig (Project, Path Abs File)
project
ConfigMonoid
configMonoid
Config -> RIO env a
inner
= do
Maybe String
mstackWorkEnv <- IO (Maybe String) -> RIO env (Maybe String)
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> RIO env (Maybe String))
-> IO (Maybe String) -> RIO env (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
stackWorkEnvVar
let mproject :: Maybe (Project, Path Abs File)
mproject =
case ProjectConfig (Project, Path Abs File)
project of
PCProject (Project, Path Abs File)
pair -> (Project, Path Abs File) -> Maybe (Project, Path Abs File)
forall a. a -> Maybe a
Just (Project, Path Abs File)
pair
ProjectConfig (Project, Path Abs File)
PCGlobalProject -> Maybe (Project, Path Abs File)
forall a. Maybe a
Nothing
PCNoProject [PackageIdentifierRevision]
_deps -> Maybe (Project, Path Abs File)
forall a. Maybe a
Nothing
allowLocals :: Bool
allowLocals =
case ProjectConfig (Project, Path Abs File)
project of
PCProject (Project, Path Abs File)
_ -> Bool
True
ProjectConfig (Project, Path Abs File)
PCGlobalProject -> Bool
True
PCNoProject [PackageIdentifierRevision]
_ -> Bool
False
Path Rel Dir
configWorkDir0 <-
let parseStackWorkEnv :: String -> m (Path Rel Dir)
parseStackWorkEnv String
x =
m (Path Rel Dir)
-> (PathException -> m (Path Rel Dir)) -> m (Path Rel Dir)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
(String -> m (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir String
x)
( \PathException
e -> case PathException
e of
InvalidRelDir String
_ ->
ConfigPrettyException -> m (Path Rel Dir)
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (ConfigPrettyException -> m (Path Rel Dir))
-> ConfigPrettyException -> m (Path Rel Dir)
forall a b. (a -> b) -> a -> b
$ String -> ConfigPrettyException
StackWorkEnvNotRelativeDir String
x
PathException
_ -> PathException -> m (Path Rel Dir)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PathException
e
)
in RIO env (Path Rel Dir)
-> (String -> RIO env (Path Rel Dir))
-> Maybe String
-> RIO env (Path Rel Dir)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Path Rel Dir -> RIO env (Path Rel Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Rel Dir
relDirStackWork) (IO (Path Rel Dir) -> RIO env (Path Rel Dir)
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Path Rel Dir) -> RIO env (Path Rel Dir))
-> (String -> IO (Path Rel Dir))
-> String
-> RIO env (Path Rel Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Path Rel Dir)
forall {m :: * -> *}.
(MonadUnliftIO m, MonadThrow m) =>
String -> m (Path Rel Dir)
parseStackWorkEnv) Maybe String
mstackWorkEnv
let workDir :: Path Rel Dir
workDir = Path Rel Dir -> First (Path Rel Dir) -> Path Rel Dir
forall a. a -> First a -> a
fromFirst Path Rel Dir
configWorkDir0 ConfigMonoid
configMonoid.workDir
latestSnapshot :: Text
latestSnapshot = Text -> First Text -> Text
forall a. a -> First a -> a
fromFirst
Text
"https://s3.amazonaws.com/haddock.stackage.org/snapshots.json"
ConfigMonoid
configMonoid.latestSnapshot
clConnectionCount :: Int
clConnectionCount = Int -> First Int -> Int
forall a. a -> First a -> a
fromFirst Int
8 ConfigMonoid
configMonoid.connectionCount
hideTHLoading :: Bool
hideTHLoading = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.hideTHLoading
prefixTimestamps :: Bool
prefixTimestamps = Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst Bool
False ConfigMonoid
configMonoid.prefixTimestamps
ghcVariant :: Maybe GHCVariant
ghcVariant = First GHCVariant -> Maybe GHCVariant
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.ghcVariant
compilerRepository :: CompilerRepository
compilerRepository = CompilerRepository
-> First CompilerRepository -> CompilerRepository
forall a. a -> First a -> a
fromFirst
CompilerRepository
defaultCompilerRepository
ConfigMonoid
configMonoid.compilerRepository
ghcBuild :: Maybe CompilerBuild
ghcBuild = First CompilerBuild -> Maybe CompilerBuild
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.ghcBuild
installGHC :: Bool
installGHC = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.installGHC
skipGHCCheck :: Bool
skipGHCCheck = FirstFalse -> Bool
fromFirstFalse ConfigMonoid
configMonoid.skipGHCCheck
skipMsys :: Bool
skipMsys = FirstFalse -> Bool
fromFirstFalse ConfigMonoid
configMonoid.skipMsys
extraIncludeDirs :: [String]
extraIncludeDirs = ConfigMonoid
configMonoid.extraIncludeDirs
extraLibDirs :: [String]
extraLibDirs = ConfigMonoid
configMonoid.extraLibDirs
customPreprocessorExts :: [Text]
customPreprocessorExts = ConfigMonoid
configMonoid.customPreprocessorExts
overrideGccPath :: Maybe (Path Abs File)
overrideGccPath = First (Path Abs File) -> Maybe (Path Abs File)
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.overrideGccPath
(Platform Arch
defArch OS
defOS) = Platform
buildPlatform
arch :: Arch
arch = Arch -> Maybe Arch -> Arch
forall a. a -> Maybe a -> a
fromMaybe Arch
defArch
(Maybe Arch -> Arch) -> Maybe Arch -> Arch
forall a b. (a -> b) -> a -> b
$ First String -> Maybe String
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.arch Maybe String -> (String -> Maybe Arch) -> Maybe Arch
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Arch
forall a. Parsec a => String -> Maybe a
Distribution.Text.simpleParse
os :: OS
os = OS
defOS
platform :: Platform
platform = Arch -> OS -> Platform
Platform Arch
arch OS
os
requireStackVersion :: VersionRange
requireStackVersion = VersionRange -> VersionRange
simplifyVersionRange
ConfigMonoid
configMonoid.requireStackVersion.intersectingVersionRange
compilerCheck :: VersionCheck
compilerCheck = VersionCheck -> First VersionCheck -> VersionCheck
forall a. a -> First a -> a
fromFirst VersionCheck
MatchMinor ConfigMonoid
configMonoid.compilerCheck
PlatformVariant
platformVariant <- IO PlatformVariant -> RIO env PlatformVariant
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PlatformVariant -> RIO env PlatformVariant)
-> IO PlatformVariant -> RIO env PlatformVariant
forall a b. (a -> b) -> a -> b
$
PlatformVariant
-> (String -> PlatformVariant) -> Maybe String -> PlatformVariant
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PlatformVariant
PlatformVariantNone String -> PlatformVariant
PlatformVariant (Maybe String -> PlatformVariant)
-> IO (Maybe String) -> IO PlatformVariant
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
platformVariantEnvVar
let build :: BuildOpts
build = BuildOptsMonoid -> BuildOpts
buildOptsFromMonoid ConfigMonoid
configMonoid.buildOpts
DockerOpts
docker <-
Maybe Project
-> Maybe AbstractResolver -> DockerOptsMonoid -> RIO env DockerOpts
forall (m :: * -> *).
MonadThrow m =>
Maybe Project
-> Maybe AbstractResolver -> DockerOptsMonoid -> m DockerOpts
dockerOptsFromMonoid (((Project, Path Abs File) -> Project)
-> Maybe (Project, Path Abs File) -> Maybe Project
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Project, Path Abs File) -> Project
forall a b. (a, b) -> a
fst Maybe (Project, Path Abs File)
mproject) Maybe AbstractResolver
resolver ConfigMonoid
configMonoid.dockerOpts
NixOpts
nix <- NixOptsMonoid -> OS -> RIO env NixOpts
forall env.
(HasRunner env, HasTerm env) =>
NixOptsMonoid -> OS -> RIO env NixOpts
nixOptsFromMonoid ConfigMonoid
configMonoid.nixOpts OS
os
Bool
systemGHC <-
case (First Bool -> Maybe Bool
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.systemGHC, NixOpts
nix.enable) of
(Just Bool
False, Bool
True) ->
ConfigException -> RIO env Bool
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM ConfigException
NixRequiresSystemGhc
(Maybe Bool, Bool)
_ ->
Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst
(DockerOpts
docker.enable Bool -> Bool -> Bool
|| NixOpts
nix.enable)
ConfigMonoid
configMonoid.systemGHC)
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe GHCVariant -> Bool
forall a. Maybe a -> Bool
isJust Maybe GHCVariant
ghcVariant Bool -> Bool -> Bool
&& Bool
systemGHC) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
ConfigException -> RIO env ()
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM ConfigException
ManualGHCVariantSettingsAreIncompatibleWithSystemGHC
[(String, String)]
rawEnv <- IO [(String, String)] -> RIO env [(String, String)]
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(String, String)]
getEnvironment
Map Text Text
pathsEnv <- (ProcessException -> RIO env (Map Text Text))
-> (Map Text Text -> RIO env (Map Text Text))
-> Either ProcessException (Map Text Text)
-> RIO env (Map Text Text)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ProcessException -> RIO env (Map Text Text)
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM Map Text Text -> RIO env (Map Text Text)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Either ProcessException (Map Text Text)
-> RIO env (Map Text Text))
-> Either ProcessException (Map Text Text)
-> RIO env (Map Text Text)
forall a b. (a -> b) -> a -> b
$ [String]
-> Map Text Text -> Either ProcessException (Map Text Text)
augmentPathMap ((Path Abs Dir -> String) -> [Path Abs Dir] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath ConfigMonoid
configMonoid.extraPath)
([(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (((String, String) -> (Text, Text))
-> [(String, String)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text)
-> (String -> Text) -> (String, String) -> (Text, Text)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** String -> Text
T.pack) [(String, String)]
rawEnv))
ProcessContext
origEnv <- Map Text Text -> RIO env ProcessContext
forall (m :: * -> *).
MonadIO m =>
Map Text Text -> m ProcessContext
mkProcessContext Map Text Text
pathsEnv
let processContextSettings :: EnvSettings -> IO ProcessContext
processContextSettings EnvSettings
_ = ProcessContext -> IO ProcessContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessContext
origEnv
Path Abs Dir
localProgramsBase <- case First (Path Abs Dir) -> Maybe (Path Abs Dir)
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.localProgramsBase of
Maybe (Path Abs Dir)
Nothing -> Path Abs Dir
-> Platform -> ProcessContext -> RIO env (Path Abs Dir)
forall (m :: * -> *).
MonadThrow m =>
Path Abs Dir -> Platform -> ProcessContext -> m (Path Abs Dir)
getDefaultLocalProgramsBase Path Abs Dir
stackRoot Platform
platform ProcessContext
origEnv
Just Path Abs Dir
path -> Path Abs Dir -> RIO env (Path Abs Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
path
let localProgramsFilePath :: String
localProgramsFilePath = Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
localProgramsBase
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
osIsWindows Bool -> Bool -> Bool
&& Char
' ' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
localProgramsFilePath) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
localProgramsBase
String
shortLocalProgramsFilePath <-
IO String -> RIO env String
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> RIO env String) -> IO String -> RIO env String
forall a b. (a -> b) -> a -> b
$ String -> IO String
getShortPathName String
localProgramsFilePath
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char
' ' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
shortLocalProgramsFilePath) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
StyleDoc
"[S-8432]"
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"Stack's 'programs' path contains a space character and \
\has no alternative short ('8 dot 3') name. This will \
\cause problems with packages that use the GNU project's \
\'configure' shell script. Use the"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"local-programs-path"
, String -> StyleDoc
flow String
"configuration option to specify an alternative path. \
\The current path is:"
, Style -> StyleDoc -> StyleDoc
style Style
File (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
localProgramsFilePath) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
Path Rel Dir
platformOnlyDir <-
ReaderT (Platform, PlatformVariant) (RIO env) (Path Rel Dir)
-> (Platform, PlatformVariant) -> RIO env (Path Rel Dir)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (Platform, PlatformVariant) (RIO env) (Path Rel Dir)
forall env (m :: * -> *).
(MonadReader env m, HasPlatform env, MonadThrow m) =>
m (Path Rel Dir)
platformOnlyRelDir (Platform
platform, PlatformVariant
platformVariant)
let localPrograms :: Path Abs Dir
localPrograms = Path Abs Dir
localProgramsBase Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
platformOnlyDir
Path Abs Dir
localBin <-
case First String -> Maybe String
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.localBinPath of
Maybe String
Nothing -> do
Path Abs Dir
localDir <- String -> RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
getAppUserDataDir String
"local"
Path Abs Dir -> RIO env (Path Abs Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir -> RIO env (Path Abs Dir))
-> Path Abs Dir -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
localDir Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirBin
Just String
userPath ->
(case Maybe (Project, Path Abs File)
mproject of
Maybe (Project, Path Abs File)
Nothing -> String -> RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' String
userPath
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)
RIO env (Path Abs Dir)
-> (SomeException -> RIO env (Path Abs Dir))
-> RIO env (Path Abs Dir)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny`
RIO env (Path Abs Dir) -> SomeException -> RIO env (Path Abs Dir)
forall a b. a -> b -> a
const (ConfigException -> RIO env (Path Abs Dir)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (String -> ConfigException
NoSuchDirectory String
userPath))
Int
jobs <-
case First Int -> Maybe Int
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.jobs of
Maybe Int
Nothing -> IO Int -> RIO env Int
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumProcessors
Just Int
i -> Int -> RIO env Int
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
i
let concurrentTests :: Bool
concurrentTests =
Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst Bool
True ConfigMonoid
configMonoid.concurrentTests
templateParams :: Map Text Text
templateParams = ConfigMonoid
configMonoid.templateParameters
scmInit :: Maybe SCM
scmInit = First SCM -> Maybe SCM
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.scmInit
cabalConfigOpts :: Map CabalConfigKey [Text]
cabalConfigOpts = MonoidMap CabalConfigKey (Dual [Text]) -> Map CabalConfigKey [Text]
forall a b. Coercible a b => a -> b
coerce ConfigMonoid
configMonoid.cabalConfigOpts
ghcOptionsByName :: Map PackageName [Text]
ghcOptionsByName = MonoidMap PackageName (Dual [Text]) -> Map PackageName [Text]
forall a b. Coercible a b => a -> b
coerce ConfigMonoid
configMonoid.ghcOptionsByName
ghcOptionsByCat :: Map ApplyGhcOptions [Text]
ghcOptionsByCat = MonoidMap ApplyGhcOptions (Dual [Text])
-> Map ApplyGhcOptions [Text]
forall a b. Coercible a b => a -> b
coerce ConfigMonoid
configMonoid.ghcOptionsByCat
setupInfoLocations :: [String]
setupInfoLocations = ConfigMonoid
configMonoid.setupInfoLocations
setupInfoInline :: SetupInfo
setupInfoInline = ConfigMonoid
configMonoid.setupInfoInline
pvpBounds :: PvpBounds
pvpBounds =
PvpBounds -> First PvpBounds -> PvpBounds
forall a. a -> First a -> a
fromFirst (PvpBoundsType -> Bool -> PvpBounds
PvpBounds PvpBoundsType
PvpBoundsNone Bool
False) ConfigMonoid
configMonoid.pvpBounds
modifyCodePage :: Bool
modifyCodePage = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.modifyCodePage
rebuildGhcOptions :: Bool
rebuildGhcOptions =
FirstFalse -> Bool
fromFirstFalse ConfigMonoid
configMonoid.rebuildGhcOptions
applyGhcOptions :: ApplyGhcOptions
applyGhcOptions =
ApplyGhcOptions -> First ApplyGhcOptions -> ApplyGhcOptions
forall a. a -> First a -> a
fromFirst ApplyGhcOptions
AGOLocals ConfigMonoid
configMonoid.applyGhcOptions
applyProgOptions :: ApplyProgOptions
applyProgOptions =
ApplyProgOptions -> First ApplyProgOptions -> ApplyProgOptions
forall a. a -> First a -> a
fromFirst ApplyProgOptions
APOLocals ConfigMonoid
configMonoid.applyProgOptions
allowNewer :: Bool
allowNewer = Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst Bool
False ConfigMonoid
configMonoid.allowNewer
allowNewerDeps :: Maybe [PackageName]
allowNewerDeps = Maybe AllowNewerDeps -> Maybe [PackageName]
forall a b. Coercible a b => a -> b
coerce ConfigMonoid
configMonoid.allowNewerDeps
defaultTemplate :: Maybe TemplateName
defaultTemplate = First TemplateName -> Maybe TemplateName
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.defaultTemplate
dumpLogs :: DumpLogs
dumpLogs = DumpLogs -> First DumpLogs -> DumpLogs
forall a. a -> First a -> a
fromFirst DumpLogs
DumpWarningLogs ConfigMonoid
configMonoid.dumpLogs
saveHackageCreds :: Bool
saveHackageCreds =
Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst Bool
True ConfigMonoid
configMonoid.saveHackageCreds
hackageBaseUrl :: Text
hackageBaseUrl =
Text -> First Text -> Text
forall a. a -> First a -> a
fromFirst Text
Constants.hackageBaseUrl ConfigMonoid
configMonoid.hackageBaseUrl
hideSourcePaths :: Bool
hideSourcePaths = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.hideSourcePaths
recommendUpgrade :: Bool
recommendUpgrade = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.recommendUpgrade
notifyIfNixOnPath :: Bool
notifyIfNixOnPath = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.notifyIfNixOnPath
notifyIfGhcUntested :: Bool
notifyIfGhcUntested = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.notifyIfGhcUntested
notifyIfCabalUntested :: Bool
notifyIfCabalUntested = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.notifyIfCabalUntested
notifyIfArchUnknown :: Bool
notifyIfArchUnknown = FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.notifyIfArchUnknown
noRunCompile :: Bool
noRunCompile = FirstFalse -> Bool
fromFirstFalse ConfigMonoid
configMonoid.noRunCompile
Bool
allowDifferentUser <-
case First Bool -> Maybe Bool
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.allowDifferentUser of
Just Bool
True -> Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
Maybe Bool
_ -> RIO env Bool
forall (m :: * -> *). MonadIO m => m Bool
getInContainer
Runner
configRunner' <- Getting Runner env Runner -> RIO env Runner
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Runner env Runner
forall env. HasRunner env => Lens' env Runner
Lens' env Runner
runnerL
Bool
useAnsi <- IO Bool -> RIO env Bool
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RIO env Bool) -> IO Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hNowSupportsANSI Handle
stderr
let stylesUpdate' :: StylesUpdate
stylesUpdate' = (Runner
configRunner' Runner -> Getting StylesUpdate Runner StylesUpdate -> StylesUpdate
forall s a. s -> Getting a s a -> a
^. Getting StylesUpdate Runner StylesUpdate
forall env. HasStylesUpdate env => Lens' env StylesUpdate
Lens' Runner StylesUpdate
stylesUpdateL) StylesUpdate -> StylesUpdate -> StylesUpdate
forall a. Semigroup a => a -> a -> a
<>
ConfigMonoid
configMonoid.styles
useColor' :: Bool
useColor' = Runner
configRunner'.useColor
mUseColor :: Maybe Bool
mUseColor = do
ColorWhen
colorWhen <- First ColorWhen -> Maybe ColorWhen
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.colorWhen
Bool -> Maybe Bool
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ case ColorWhen
colorWhen of
ColorWhen
ColorNever -> Bool
False
ColorWhen
ColorAlways -> Bool
True
ColorWhen
ColorAuto -> Bool
useAnsi
useColor'' :: Bool
useColor'' = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
useColor' Maybe Bool
mUseColor
configRunner'' :: Runner
configRunner'' = Runner
configRunner'
Runner -> (Runner -> Runner) -> Runner
forall a b. a -> (a -> b) -> b
& (ProcessContext -> Identity ProcessContext)
-> Runner -> Identity Runner
forall env. HasProcessContext env => Lens' env ProcessContext
Lens' Runner ProcessContext
processContextL ((ProcessContext -> Identity ProcessContext)
-> Runner -> Identity Runner)
-> ProcessContext -> Runner -> Runner
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ProcessContext
origEnv
Runner -> (Runner -> Runner) -> Runner
forall a b. a -> (a -> b) -> b
& (StylesUpdate -> Identity StylesUpdate)
-> Runner -> Identity Runner
forall env. HasStylesUpdate env => Lens' env StylesUpdate
Lens' Runner StylesUpdate
stylesUpdateL ((StylesUpdate -> Identity StylesUpdate)
-> Runner -> Identity Runner)
-> StylesUpdate -> Runner -> Runner
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StylesUpdate
stylesUpdate'
Runner -> (Runner -> Runner) -> Runner
forall a b. a -> (a -> b) -> b
& (Bool -> Identity Bool) -> Runner -> Identity Runner
forall env. HasTerm env => Lens' env Bool
Lens' Runner Bool
useColorL ((Bool -> Identity Bool) -> Runner -> Identity Runner)
-> Bool -> Runner -> Runner
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
useColor''
go :: GlobalOpts
go = Runner
configRunner'.globalOpts
PackageIndexConfig
pic <-
case First PackageIndexConfig -> Maybe PackageIndexConfig
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.packageIndex of
Maybe PackageIndexConfig
Nothing ->
case First [PackageIndexConfig] -> Maybe [PackageIndexConfig]
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.packageIndices of
Maybe [PackageIndexConfig]
Nothing -> PackageIndexConfig -> RIO env PackageIndexConfig
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIndexConfig
defaultPackageIndexConfig
Just [PackageIndexConfig
pic] -> do
StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn StyleDoc
packageIndicesWarning
PackageIndexConfig -> RIO env PackageIndexConfig
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIndexConfig
pic
Just [PackageIndexConfig]
x -> ConfigPrettyException -> RIO env PackageIndexConfig
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (ConfigPrettyException -> RIO env PackageIndexConfig)
-> ConfigPrettyException -> RIO env PackageIndexConfig
forall a b. (a -> b) -> a -> b
$ [PackageIndexConfig] -> ConfigPrettyException
MultiplePackageIndices [PackageIndexConfig]
x
Just PackageIndexConfig
pic -> PackageIndexConfig -> RIO env PackageIndexConfig
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIndexConfig
pic
Maybe String
mpantryRoot <- IO (Maybe String) -> RIO env (Maybe String)
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> RIO env (Maybe String))
-> IO (Maybe String) -> RIO env (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
pantryRootEnvVar
Path Abs Dir
pantryRoot <-
case Maybe String
mpantryRoot of
Just String
dir ->
case String -> Maybe (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir String
dir of
Maybe (Path Abs Dir)
Nothing -> ParseAbsolutePathException -> RIO env (Path Abs Dir)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (ParseAbsolutePathException -> RIO env (Path Abs Dir))
-> ParseAbsolutePathException -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ String -> String -> ParseAbsolutePathException
ParseAbsolutePathException String
pantryRootEnvVar String
dir
Just Path Abs Dir
x -> Path Abs Dir -> RIO env (Path Abs Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
x
Maybe String
Nothing -> Path Abs Dir -> RIO env (Path Abs Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir -> RIO env (Path Abs Dir))
-> Path Abs Dir -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
stackRoot Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirPantry
let snapLoc :: SnapName -> RawSnapshotLocation
snapLoc =
case First Text -> Maybe Text
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.snapshotLocation of
Maybe Text
Nothing -> SnapName -> RawSnapshotLocation
defaultSnapshotLocation
Just Text
addr ->
SnapName -> RawSnapshotLocation
customSnapshotLocation
where
customSnapshotLocation :: SnapName -> RawSnapshotLocation
customSnapshotLocation (LTS Int
x Int
y) =
Utf8Builder -> RawSnapshotLocation
mkRSLUrl (Utf8Builder -> RawSnapshotLocation)
-> Utf8Builder -> RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ Utf8Builder
addr'
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/lts/" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
x
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
y Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".yaml"
customSnapshotLocation (Nightly Day
date) =
let (Year
year, Int
month, Int
day) = Day -> (Year, Int, Int)
toGregorian Day
date
in Utf8Builder -> RawSnapshotLocation
mkRSLUrl (Utf8Builder -> RawSnapshotLocation)
-> Utf8Builder -> RawSnapshotLocation
forall a b. (a -> b) -> a -> b
$ Utf8Builder
addr'
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/nightly/"
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Year -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Year
year
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
month
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
day Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".yaml"
mkRSLUrl :: Utf8Builder -> RawSnapshotLocation
mkRSLUrl Utf8Builder
builder = Text -> Maybe BlobKey -> RawSnapshotLocation
RSLUrl (Utf8Builder -> Text
utf8BuilderToText Utf8Builder
builder) Maybe BlobKey
forall a. Maybe a
Nothing
addr' :: Utf8Builder
addr' = Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Text -> Utf8Builder) -> Text -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/') Text
addr
let stackDeveloperMode :: Bool
stackDeveloperMode = Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst
Bool
stackDeveloperModeDefault
ConfigMonoid
configMonoid.stackDeveloperMode
casa :: Maybe (CasaRepoPrefix, Int)
casa =
if FirstTrue -> Bool
fromFirstTrue ConfigMonoid
configMonoid.casaOpts.enable
then
let casaRepoPrefix :: CasaRepoPrefix
casaRepoPrefix = CasaRepoPrefix -> First CasaRepoPrefix -> CasaRepoPrefix
forall a. a -> First a -> a
fromFirst
(CasaRepoPrefix -> First CasaRepoPrefix -> CasaRepoPrefix
forall a. a -> First a -> a
fromFirst CasaRepoPrefix
defaultCasaRepoPrefix ConfigMonoid
configMonoid.casaRepoPrefix)
ConfigMonoid
configMonoid.casaOpts.repoPrefix
casaMaxKeysPerRequest :: Int
casaMaxKeysPerRequest = Int -> First Int -> Int
forall a. a -> First a -> a
fromFirst
Int
defaultCasaMaxPerRequest
ConfigMonoid
configMonoid.casaOpts.maxKeysPerRequest
in (CasaRepoPrefix, Int) -> Maybe (CasaRepoPrefix, Int)
forall a. a -> Maybe a
Just (CasaRepoPrefix
casaRepoPrefix, Int
casaMaxKeysPerRequest)
else Maybe (CasaRepoPrefix, Int)
forall a. Maybe a
Nothing
GlobalOpts
-> Bool -> StylesUpdate -> (LogFunc -> RIO env a) -> RIO env a
forall (m :: * -> *) a.
MonadUnliftIO m =>
GlobalOpts -> Bool -> StylesUpdate -> (LogFunc -> m a) -> m a
withNewLogFunc GlobalOpts
go Bool
useColor'' StylesUpdate
stylesUpdate' ((LogFunc -> RIO env a) -> RIO env a)
-> (LogFunc -> RIO env a) -> RIO env a
forall a b. (a -> b) -> a -> b
$ \LogFunc
logFunc -> do
let runner :: Runner
runner = Runner
configRunner'' Runner -> (Runner -> Runner) -> Runner
forall a b. a -> (a -> b) -> b
& (LogFunc -> Identity LogFunc) -> Runner -> Identity Runner
forall env. HasLogFunc env => Lens' env LogFunc
Lens' Runner LogFunc
logFuncL ((LogFunc -> Identity LogFunc) -> Runner -> Identity Runner)
-> LogFunc -> Runner -> Runner
forall s t a b. ASetter s t a b -> b -> s -> t
.~ LogFunc
logFunc
LogFunc -> RIO env a -> RIO env a
forall env a. HasLogFunc env => LogFunc -> RIO env a -> RIO env a
withLocalLogFunc LogFunc
logFunc (RIO env a -> RIO env a) -> RIO env a -> RIO env a
forall a b. (a -> b) -> a -> b
$ RIO env a -> RIO env a
forall env a. HasLogFunc env => RIO env a -> RIO env a
handleMigrationException (RIO env a -> RIO env a) -> RIO env a -> RIO env a
forall a b. (a -> b) -> a -> b
$ do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ case Maybe (CasaRepoPrefix, Int)
casa of
Maybe (CasaRepoPrefix, Int)
Nothing -> Utf8Builder
"Use of Casa server disabled."
Just (CasaRepoPrefix
repoPrefix, Int
maxKeys) ->
Utf8Builder
"Use of Casa server enabled: ("
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (CasaRepoPrefix -> String
forall a. Show a => a -> String
show CasaRepoPrefix
repoPrefix)
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Int -> String
forall a. Show a => a -> String
show Int
maxKeys)
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")."
Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
forall env a.
HasLogFunc env =>
Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig'
Path Abs Dir
pantryRoot
PackageIndexConfig
pic
(HpackExecutable
-> (String -> HpackExecutable) -> Maybe String -> HpackExecutable
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HpackExecutable
HpackBundled String -> HpackExecutable
HpackCommand (Maybe String -> HpackExecutable)
-> Maybe String -> HpackExecutable
forall a b. (a -> b) -> a -> b
$ First String -> Maybe String
forall a. First a -> Maybe a
getFirst ConfigMonoid
configMonoid.overrideHpack)
Int
clConnectionCount
Maybe (CasaRepoPrefix, Int)
casa
SnapName -> RawSnapshotLocation
snapLoc
(\PantryConfig
pantryConfig -> Path Abs File -> (UserStorage -> RIO env a) -> RIO env a
forall env a.
HasLogFunc env =>
Path Abs File -> (UserStorage -> RIO env a) -> RIO env a
initUserStorage
(Path Abs Dir
stackRoot Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileStorage)
( \UserStorage
userStorage -> Config -> RIO env a
inner Config
{ Path Rel Dir
workDir :: Path Rel Dir
$sel:workDir:Config :: Path Rel Dir
workDir
, Path Abs File
userConfigPath :: Path Abs File
$sel:userConfigPath:Config :: Path Abs File
userConfigPath
, BuildOpts
build :: BuildOpts
$sel:build:Config :: BuildOpts
build
, DockerOpts
docker :: DockerOpts
$sel:docker:Config :: DockerOpts
docker
, NixOpts
nix :: NixOpts
$sel:nix:Config :: NixOpts
nix
, EnvSettings -> IO ProcessContext
processContextSettings :: EnvSettings -> IO ProcessContext
$sel:processContextSettings:Config :: EnvSettings -> IO ProcessContext
processContextSettings
, Path Abs Dir
localProgramsBase :: Path Abs Dir
$sel:localProgramsBase:Config :: Path Abs Dir
localProgramsBase
, Path Abs Dir
localPrograms :: Path Abs Dir
$sel:localPrograms:Config :: Path Abs Dir
localPrograms
, Bool
hideTHLoading :: Bool
$sel:hideTHLoading:Config :: Bool
hideTHLoading
, Bool
prefixTimestamps :: Bool
$sel:prefixTimestamps:Config :: Bool
prefixTimestamps
, Platform
platform :: Platform
$sel:platform:Config :: Platform
platform
, PlatformVariant
platformVariant :: PlatformVariant
$sel:platformVariant:Config :: PlatformVariant
platformVariant
, Maybe GHCVariant
ghcVariant :: Maybe GHCVariant
$sel:ghcVariant:Config :: Maybe GHCVariant
ghcVariant
, Maybe CompilerBuild
ghcBuild :: Maybe CompilerBuild
$sel:ghcBuild:Config :: Maybe CompilerBuild
ghcBuild
, Text
latestSnapshot :: Text
$sel:latestSnapshot:Config :: Text
latestSnapshot
, Bool
systemGHC :: Bool
$sel:systemGHC:Config :: Bool
systemGHC
, Bool
installGHC :: Bool
$sel:installGHC:Config :: Bool
installGHC
, Bool
skipGHCCheck :: Bool
$sel:skipGHCCheck:Config :: Bool
skipGHCCheck
, Bool
skipMsys :: Bool
$sel:skipMsys:Config :: Bool
skipMsys
, VersionCheck
compilerCheck :: VersionCheck
$sel:compilerCheck:Config :: VersionCheck
compilerCheck
, CompilerRepository
compilerRepository :: CompilerRepository
$sel:compilerRepository:Config :: CompilerRepository
compilerRepository
, Path Abs Dir
localBin :: Path Abs Dir
$sel:localBin:Config :: Path Abs Dir
localBin
, VersionRange
requireStackVersion :: VersionRange
$sel:requireStackVersion:Config :: VersionRange
requireStackVersion
, Int
jobs :: Int
$sel:jobs:Config :: Int
jobs
, Maybe (Path Abs File)
overrideGccPath :: Maybe (Path Abs File)
$sel:overrideGccPath:Config :: Maybe (Path Abs File)
overrideGccPath
, [String]
extraIncludeDirs :: [String]
$sel:extraIncludeDirs:Config :: [String]
extraIncludeDirs
, [String]
extraLibDirs :: [String]
$sel:extraLibDirs:Config :: [String]
extraLibDirs
, [Text]
customPreprocessorExts :: [Text]
$sel:customPreprocessorExts:Config :: [Text]
customPreprocessorExts
, Bool
concurrentTests :: Bool
$sel:concurrentTests:Config :: Bool
concurrentTests
, Map Text Text
templateParams :: Map Text Text
$sel:templateParams:Config :: Map Text Text
templateParams
, Maybe SCM
scmInit :: Maybe SCM
$sel:scmInit:Config :: Maybe SCM
scmInit
, Map PackageName [Text]
ghcOptionsByName :: Map PackageName [Text]
$sel:ghcOptionsByName:Config :: Map PackageName [Text]
ghcOptionsByName
, Map ApplyGhcOptions [Text]
ghcOptionsByCat :: Map ApplyGhcOptions [Text]
$sel:ghcOptionsByCat:Config :: Map ApplyGhcOptions [Text]
ghcOptionsByCat
, Map CabalConfigKey [Text]
cabalConfigOpts :: Map CabalConfigKey [Text]
$sel:cabalConfigOpts:Config :: Map CabalConfigKey [Text]
cabalConfigOpts
, [String]
setupInfoLocations :: [String]
$sel:setupInfoLocations:Config :: [String]
setupInfoLocations
, SetupInfo
setupInfoInline :: SetupInfo
$sel:setupInfoInline:Config :: SetupInfo
setupInfoInline
, PvpBounds
pvpBounds :: PvpBounds
$sel:pvpBounds:Config :: PvpBounds
pvpBounds
, Bool
modifyCodePage :: Bool
$sel:modifyCodePage:Config :: Bool
modifyCodePage
, Bool
rebuildGhcOptions :: Bool
$sel:rebuildGhcOptions:Config :: Bool
rebuildGhcOptions
, ApplyGhcOptions
applyGhcOptions :: ApplyGhcOptions
$sel:applyGhcOptions:Config :: ApplyGhcOptions
applyGhcOptions
, ApplyProgOptions
applyProgOptions :: ApplyProgOptions
$sel:applyProgOptions:Config :: ApplyProgOptions
applyProgOptions
, Bool
allowNewer :: Bool
$sel:allowNewer:Config :: Bool
allowNewer
, Maybe [PackageName]
allowNewerDeps :: Maybe [PackageName]
$sel:allowNewerDeps:Config :: Maybe [PackageName]
allowNewerDeps
, Maybe TemplateName
defaultTemplate :: Maybe TemplateName
$sel:defaultTemplate:Config :: Maybe TemplateName
defaultTemplate
, Bool
allowDifferentUser :: Bool
$sel:allowDifferentUser:Config :: Bool
allowDifferentUser
, DumpLogs
dumpLogs :: DumpLogs
$sel:dumpLogs:Config :: DumpLogs
dumpLogs
, ProjectConfig (Project, Path Abs File)
project :: ProjectConfig (Project, Path Abs File)
$sel:project:Config :: ProjectConfig (Project, Path Abs File)
project
, Bool
allowLocals :: Bool
$sel:allowLocals:Config :: Bool
allowLocals
, Bool
saveHackageCreds :: Bool
$sel:saveHackageCreds:Config :: Bool
saveHackageCreds
, Text
hackageBaseUrl :: Text
$sel:hackageBaseUrl:Config :: Text
hackageBaseUrl
, Runner
runner :: Runner
$sel:runner:Config :: Runner
runner
, PantryConfig
pantryConfig :: PantryConfig
$sel:pantryConfig:Config :: PantryConfig
pantryConfig
, Path Abs Dir
stackRoot :: Path Abs Dir
$sel:stackRoot:Config :: Path Abs Dir
stackRoot
, Maybe AbstractResolver
resolver :: Maybe AbstractResolver
$sel:resolver:Config :: Maybe AbstractResolver
resolver
, UserStorage
userStorage :: UserStorage
$sel:userStorage:Config :: UserStorage
userStorage
, Bool
hideSourcePaths :: Bool
$sel:hideSourcePaths:Config :: Bool
hideSourcePaths
, Bool
recommendUpgrade :: Bool
$sel:recommendUpgrade:Config :: Bool
recommendUpgrade
, Bool
notifyIfNixOnPath :: Bool
$sel:notifyIfNixOnPath:Config :: Bool
notifyIfNixOnPath
, Bool
notifyIfGhcUntested :: Bool
$sel:notifyIfGhcUntested:Config :: Bool
notifyIfGhcUntested
, Bool
notifyIfCabalUntested :: Bool
$sel:notifyIfCabalUntested:Config :: Bool
notifyIfCabalUntested
, Bool
notifyIfArchUnknown :: Bool
$sel:notifyIfArchUnknown:Config :: Bool
notifyIfArchUnknown
, Bool
noRunCompile :: Bool
$sel:noRunCompile:Config :: Bool
noRunCompile
, Bool
stackDeveloperMode :: Bool
$sel:stackDeveloperMode:Config :: Bool
stackDeveloperMode
, Maybe (CasaRepoPrefix, Int)
casa :: Maybe (CasaRepoPrefix, Int)
$sel:casa:Config :: Maybe (CasaRepoPrefix, Int)
casa
}
)
)
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)
withNewLogFunc :: MonadUnliftIO m
=> GlobalOpts
-> Bool
-> 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
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
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
loadConfig ::
(HasRunner env, HasTerm env)
=> (Config -> RIO env a)
-> RIO env a
loadConfig :: forall env a.
(HasRunner env, HasTerm env) =>
(Config -> RIO env a) -> RIO env a
loadConfig Config -> RIO env a
inner = do
StackYamlLoc
mstackYaml <- Getting StackYamlLoc env StackYamlLoc -> RIO env StackYamlLoc
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting StackYamlLoc env StackYamlLoc -> RIO env StackYamlLoc)
-> Getting StackYamlLoc env StackYamlLoc -> RIO env StackYamlLoc
forall a b. (a -> b) -> a -> b
$ (GlobalOpts -> Const StackYamlLoc GlobalOpts)
-> env -> Const StackYamlLoc env
forall env. HasRunner env => Lens' env GlobalOpts
Lens' env GlobalOpts
globalOptsL ((GlobalOpts -> Const StackYamlLoc GlobalOpts)
-> env -> Const StackYamlLoc env)
-> ((StackYamlLoc -> Const StackYamlLoc StackYamlLoc)
-> GlobalOpts -> Const StackYamlLoc GlobalOpts)
-> Getting StackYamlLoc env StackYamlLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GlobalOpts -> StackYamlLoc)
-> SimpleGetter GlobalOpts StackYamlLoc
forall s a. (s -> a) -> SimpleGetter s a
to (.stackYaml)
ProjectConfig (Project, Path Abs File, ConfigMonoid)
mproject <- StackYamlLoc
-> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid))
forall env.
HasTerm env =>
StackYamlLoc
-> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid))
loadProjectConfig StackYamlLoc
mstackYaml
Maybe AbstractResolver
mresolver <- Getting (Maybe AbstractResolver) env (Maybe AbstractResolver)
-> RIO env (Maybe AbstractResolver)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Maybe AbstractResolver) env (Maybe AbstractResolver)
-> RIO env (Maybe AbstractResolver))
-> Getting (Maybe AbstractResolver) env (Maybe AbstractResolver)
-> RIO env (Maybe AbstractResolver)
forall a b. (a -> b) -> a -> b
$ (GlobalOpts -> Const (Maybe AbstractResolver) GlobalOpts)
-> env -> Const (Maybe AbstractResolver) env
forall env. HasRunner env => Lens' env GlobalOpts
Lens' env GlobalOpts
globalOptsL ((GlobalOpts -> Const (Maybe AbstractResolver) GlobalOpts)
-> env -> Const (Maybe AbstractResolver) env)
-> ((Maybe AbstractResolver
-> Const (Maybe AbstractResolver) (Maybe AbstractResolver))
-> GlobalOpts -> Const (Maybe AbstractResolver) GlobalOpts)
-> Getting (Maybe AbstractResolver) env (Maybe AbstractResolver)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GlobalOpts -> Maybe AbstractResolver)
-> SimpleGetter GlobalOpts (Maybe AbstractResolver)
forall s a. (s -> a) -> SimpleGetter s a
to (.resolver)
ConfigMonoid
configArgs <- Getting ConfigMonoid env ConfigMonoid -> RIO env ConfigMonoid
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting ConfigMonoid env ConfigMonoid -> RIO env ConfigMonoid)
-> Getting ConfigMonoid env ConfigMonoid -> RIO env ConfigMonoid
forall a b. (a -> b) -> a -> b
$ (GlobalOpts -> Const ConfigMonoid GlobalOpts)
-> env -> Const ConfigMonoid env
forall env. HasRunner env => Lens' env GlobalOpts
Lens' env GlobalOpts
globalOptsL ((GlobalOpts -> Const ConfigMonoid GlobalOpts)
-> env -> Const ConfigMonoid env)
-> ((ConfigMonoid -> Const ConfigMonoid ConfigMonoid)
-> GlobalOpts -> Const ConfigMonoid GlobalOpts)
-> Getting ConfigMonoid env ConfigMonoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GlobalOpts -> ConfigMonoid)
-> SimpleGetter GlobalOpts ConfigMonoid
forall s a. (s -> a) -> SimpleGetter s a
to (.configMonoid)
(Path Abs Dir
configRoot, Path Abs Dir
stackRoot, Bool
userOwnsStackRoot) <-
ConfigMonoid -> RIO env (Path Abs Dir, Path Abs Dir, Bool)
forall (m :: * -> *).
MonadIO m =>
ConfigMonoid -> m (Path Abs Dir, Path Abs Dir, Bool)
determineStackRootAndOwnership ConfigMonoid
configArgs
let (ProjectConfig (Project, Path Abs File)
mproject', [ConfigMonoid] -> [ConfigMonoid]
addConfigMonoid) =
case ProjectConfig (Project, Path Abs File, ConfigMonoid)
mproject of
PCProject (Project
proj, Path Abs File
fp, ConfigMonoid
cm) -> ((Project, Path Abs File) -> ProjectConfig (Project, Path Abs File)
forall a. a -> ProjectConfig a
PCProject (Project
proj, Path Abs File
fp), (ConfigMonoid
cm:))
ProjectConfig (Project, Path Abs File, ConfigMonoid)
PCGlobalProject -> (ProjectConfig (Project, Path Abs File)
forall a. ProjectConfig a
PCGlobalProject, [ConfigMonoid] -> [ConfigMonoid]
forall a. a -> a
id)
PCNoProject [PackageIdentifierRevision]
deps -> ([PackageIdentifierRevision]
-> ProjectConfig (Project, Path Abs File)
forall a. [PackageIdentifierRevision] -> ProjectConfig a
PCNoProject [PackageIdentifierRevision]
deps, [ConfigMonoid] -> [ConfigMonoid]
forall a. a -> a
id)
Path Abs File
userConfigPath <- Path Abs Dir -> RIO env (Path Abs File)
forall env. HasTerm env => Path Abs Dir -> RIO env (Path Abs File)
getDefaultUserConfigPath Path Abs Dir
configRoot
[ConfigMonoid]
extraConfigs0 <- Path Abs File -> RIO env [Path Abs File]
forall env. HasTerm env => Path Abs File -> RIO env [Path Abs File]
getExtraConfigs Path Abs File
userConfigPath RIO env [Path Abs File]
-> ([Path Abs File] -> RIO env [ConfigMonoid])
-> RIO env [ConfigMonoid]
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(Path Abs File -> RIO env ConfigMonoid)
-> [Path Abs File] -> RIO env [ConfigMonoid]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\Path Abs File
file -> (Value -> Parser (WithJSONWarnings ConfigMonoid))
-> Path Abs File -> RIO env ConfigMonoid
forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env a
loadConfigYaml (Path Abs Dir -> Value -> Parser (WithJSONWarnings ConfigMonoid)
parseConfigMonoid (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
file)) Path Abs File
file)
let extraConfigs :: [ConfigMonoid]
extraConfigs =
(ConfigMonoid -> ConfigMonoid) -> [ConfigMonoid] -> [ConfigMonoid]
forall a b. (a -> b) -> [a] -> [b]
map
(\ConfigMonoid
c -> ConfigMonoid
c {dockerOpts = c.dockerOpts { defaultEnable = Any False }})
[ConfigMonoid]
extraConfigs0
let withConfig :: (Config -> RIO env a) -> RIO env a
withConfig =
Path Abs Dir
-> Path Abs File
-> Maybe AbstractResolver
-> ProjectConfig (Project, Path Abs File)
-> ConfigMonoid
-> (Config -> RIO env a)
-> RIO env a
forall env a.
(HasRunner env, HasTerm env) =>
Path Abs Dir
-> Path Abs File
-> Maybe AbstractResolver
-> ProjectConfig (Project, Path Abs File)
-> ConfigMonoid
-> (Config -> RIO env a)
-> RIO env a
configFromConfigMonoid
Path Abs Dir
stackRoot
Path Abs File
userConfigPath
Maybe AbstractResolver
mresolver
ProjectConfig (Project, Path Abs File)
mproject'
([ConfigMonoid] -> ConfigMonoid
forall a. Monoid a => [a] -> a
mconcat ([ConfigMonoid] -> ConfigMonoid) -> [ConfigMonoid] -> ConfigMonoid
forall a b. (a -> b) -> a -> b
$ ConfigMonoid
configArgs ConfigMonoid -> [ConfigMonoid] -> [ConfigMonoid]
forall a. a -> [a] -> [a]
: [ConfigMonoid] -> [ConfigMonoid]
addConfigMonoid [ConfigMonoid]
extraConfigs)
(Config -> RIO env a) -> RIO env a
withConfig ((Config -> RIO env a) -> RIO env a)
-> (Config -> RIO env a) -> RIO env a
forall a b. (a -> b) -> a -> b
$ \Config
config -> do
let Platform Arch
arch OS
_ = Config
config.platform
case Arch
arch of
OtherArch String
unknownArch
| Config
config.notifyIfArchUnknown ->
[StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
[ String -> StyleDoc
flow String
"Unknown value for architecture setting:"
, Style -> StyleDoc -> StyleDoc
style Style
Shell (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
unknownArch) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
, String -> StyleDoc
flow String
"To mute this message in future, set"
, Style -> StyleDoc -> StyleDoc
style Style
Shell (String -> StyleDoc
flow String
"notify-if-arch-unknown: false")
, String -> StyleDoc
flow String
"in Stack's configuration."
]
Arch
_ -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Version
stackVersion Version -> VersionRange -> Bool
`withinRange` Config
config.requireStackVersion)
(ConfigException -> RIO env ()
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (VersionRange -> ConfigException
BadStackVersionException Config
config.requireStackVersion))
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Config
config.allowDifferentUser (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
userOwnsStackRoot (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
ConfigException -> RIO env ()
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (Path Abs Dir -> ConfigException
UserDoesn'tOwnDirectory Path Abs Dir
stackRoot)
Maybe (Path Abs Dir) -> (Path Abs Dir -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Config -> Maybe (Path Abs Dir)
configProjectRoot Config
config) ((Path Abs Dir -> RIO env ()) -> RIO env ())
-> (Path Abs Dir -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir ->
Path Abs Dir -> RIO env ()
forall (m :: * -> *). MonadIO m => Path Abs Dir -> m ()
checkOwnership (Path Abs Dir
dir Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Config
config.workDir)
Config -> RIO env a
inner Config
config
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
Maybe RawSnapshotLocation
mresolver <- Maybe AbstractResolver
-> (AbstractResolver -> RIO Config RawSnapshotLocation)
-> RIO Config (Maybe RawSnapshotLocation)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Config
config.resolver ((AbstractResolver -> RIO Config RawSnapshotLocation)
-> RIO Config (Maybe RawSnapshotLocation))
-> (AbstractResolver -> RIO Config RawSnapshotLocation)
-> RIO Config (Maybe RawSnapshotLocation)
forall a b. (a -> b) -> a -> b
$ \AbstractResolver
aresolver -> do
Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Using resolver: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> AbstractResolver -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display AbstractResolver
aresolver Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" specified on command line")
AbstractResolver -> RIO Config RawSnapshotLocation
forall env.
HasConfig env =>
AbstractResolver -> RIO env RawSnapshotLocation
makeConcreteResolver AbstractResolver
aresolver
(Project
project', Path Abs File
stackYaml) <- case Config
config.project of
PCProject (Project
project, Path Abs File
fp) -> do
Maybe String -> (String -> RIO Config ()) -> RIO Config ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Project
project.userMsg String -> RIO Config ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
String -> m ()
prettyWarnS
(Project, Path Abs File) -> RIO Config (Project, Path Abs File)
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Project
project, Path Abs File
fp)
PCNoProject [PackageIdentifierRevision]
extraDeps -> do
Project
p <-
case Maybe RawSnapshotLocation
mresolver of
Maybe RawSnapshotLocation
Nothing -> ConfigException -> RIO Config Project
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ConfigException
NoResolverWhenUsingNoProject
Just RawSnapshotLocation
_ -> Maybe RawSnapshotLocation
-> [PackageIdentifierRevision] -> RIO Config Project
getEmptyProject Maybe RawSnapshotLocation
mresolver [PackageIdentifierRevision]
extraDeps
(Project, Path Abs File) -> RIO Config (Project, Path Abs File)
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Project
p, Config
config.userConfigPath)
ProjectConfig (Project, Path Abs File)
PCGlobalProject -> do
Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Run from outside a project, using implicit global project config"
Path Abs Dir
destDir <- Config -> RIO Config (Path Abs Dir)
forall env. HasTerm env => Config -> RIO env (Path Abs Dir)
getImplicitGlobalProjectDir Config
config
let dest :: Path Abs File
dest :: Path Abs File
dest = Path Abs Dir
destDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
stackDotYaml
dest' :: FilePath
dest' :: String
dest' = Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
dest
Path Abs Dir -> RIO Config ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
destDir
Bool
exists <- Path Abs File -> RIO Config Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
dest
if Bool
exists
then do
IO ProjectAndConfigMonoid
iopc <- (Value -> Parser (WithJSONWarnings (IO ProjectAndConfigMonoid)))
-> Path Abs File -> RIO Config (IO ProjectAndConfigMonoid)
forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env a
loadConfigYaml (Path Abs Dir
-> Value -> Parser (WithJSONWarnings (IO ProjectAndConfigMonoid))
parseProjectAndConfigMonoid Path Abs Dir
destDir) Path Abs File
dest
ProjectAndConfigMonoid Project
project ConfigMonoid
_ <- IO ProjectAndConfigMonoid -> RIO Config ProjectAndConfigMonoid
forall a. IO a -> RIO Config a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ProjectAndConfigMonoid
iopc
Bool -> RIO Config () -> RIO Config ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Getting Bool Config Bool -> Config -> Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool Config Bool
forall env. HasRunner env => Lens' env Bool
Lens' Config Bool
terminalL Config
config) (RIO Config () -> RIO Config ()) -> RIO Config () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$
case Config
config.resolver of
Maybe AbstractResolver
Nothing ->
Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO Config ()) -> Utf8Builder -> RIO Config ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Using resolver: "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Project
project.resolver
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" from implicit global project's config file: "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString String
dest'
Just AbstractResolver
_ -> () -> RIO Config ()
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Project, Path Abs File) -> RIO Config (Project, Path Abs File)
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Project
project, Path Abs File
dest)
else do
[StyleDoc] -> RIO Config ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
[ String -> StyleDoc
flow String
"Writing the configuration file for the implicit \
\global project to:"
, Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
dest StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
, String -> StyleDoc
flow String
"Note: You can change the snapshot via the"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"resolver"
, String -> StyleDoc
flow String
"field there."
]
Project
p <- Maybe RawSnapshotLocation
-> [PackageIdentifierRevision] -> RIO Config Project
getEmptyProject Maybe RawSnapshotLocation
mresolver []
IO () -> RIO Config ()
forall a. IO a -> RIO Config a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO Config ()) -> IO () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ do
Path Abs File -> Builder -> IO ()
forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
dest (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S.concat
[ ByteString
"# This is the implicit global project's config file, which is only used when\n"
, ByteString
"# 'stack' is run outside of a real project. Settings here do _not_ act as\n"
, ByteString
"# defaults for all projects. To change Stack's default settings, edit\n"
, ByteString
"# '", Text -> ByteString
encodeUtf8 (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
forall b t. Path b t -> String
toFilePath Config
config.userConfigPath), ByteString
"' instead.\n"
, ByteString
"#\n"
, ByteString
"# For more information about Stack's configuration, see\n"
, ByteString
"# http://docs.haskellstack.org/en/stable/yaml_configuration/\n"
, ByteString
"#\n"
, Project -> ByteString
forall a. ToJSON a => a -> ByteString
Yaml.encode Project
p]
Path Abs File -> Builder -> IO ()
forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
dest Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileReadmeTxt) (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$
Builder
"This is the implicit global project, which is " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
Builder
"used only when 'stack' is run\noutside of a " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
Builder
"real project.\n"
(Project, Path Abs File) -> RIO Config (Project, Path Abs File)
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Project
p, Path Abs File
dest)
Maybe WantedCompiler
mcompiler <- Getting (Maybe WantedCompiler) Config (Maybe WantedCompiler)
-> RIO Config (Maybe WantedCompiler)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Maybe WantedCompiler) Config (Maybe WantedCompiler)
-> RIO Config (Maybe WantedCompiler))
-> Getting (Maybe WantedCompiler) Config (Maybe WantedCompiler)
-> RIO Config (Maybe WantedCompiler)
forall a b. (a -> b) -> a -> b
$ (GlobalOpts -> Const (Maybe WantedCompiler) GlobalOpts)
-> Config -> Const (Maybe WantedCompiler) Config
forall env. HasRunner env => Lens' env GlobalOpts
Lens' Config GlobalOpts
globalOptsL ((GlobalOpts -> Const (Maybe WantedCompiler) GlobalOpts)
-> Config -> Const (Maybe WantedCompiler) Config)
-> ((Maybe WantedCompiler
-> Const (Maybe WantedCompiler) (Maybe WantedCompiler))
-> GlobalOpts -> Const (Maybe WantedCompiler) GlobalOpts)
-> Getting (Maybe WantedCompiler) Config (Maybe WantedCompiler)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GlobalOpts -> Maybe WantedCompiler)
-> SimpleGetter GlobalOpts (Maybe WantedCompiler)
forall s a. (s -> a) -> SimpleGetter s a
to (.compiler)
let project :: Project
project :: Project
project = Project
project'
{ Project.compiler = mcompiler <|> project'.compiler
, Project.resolver = fromMaybe project'.resolver mresolver
}
[Path Abs Dir]
extraPackageDBs <- (String -> RIO Config (Path Abs Dir))
-> [String] -> RIO Config [Path Abs Dir]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> RIO Config (Path Abs Dir)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' Project
project.extraPackageDBs
SMWanted
smWanted <- Path Abs File
-> RawSnapshotLocation
-> (Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO Config DepPackage)
-> RIO Config (SMWanted, [CompletedPLI]))
-> RIO Config SMWanted
forall env.
(HasPantryConfig env, HasRunner env) =>
Path Abs File
-> RawSnapshotLocation
-> (Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO env DepPackage)
-> RIO env (SMWanted, [CompletedPLI]))
-> RIO env SMWanted
lockCachedWanted Path Abs File
stackYaml Project
project.resolver ((Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO Config DepPackage)
-> RIO Config (SMWanted, [CompletedPLI]))
-> RIO Config SMWanted)
-> (Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO Config DepPackage)
-> RIO Config (SMWanted, [CompletedPLI]))
-> RIO Config SMWanted
forall a b. (a -> b) -> a -> b
$
Path Abs File
-> Config
-> Project
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO Config DepPackage)
-> RIO Config (SMWanted, [CompletedPLI])
forall env t.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
Path Abs t
-> Config
-> Project
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO env DepPackage)
-> RIO env (SMWanted, [CompletedPLI])
fillProjectWanted Path Abs File
stackYaml Config
config Project
project
Path Rel Dir
workDir <- Getting (Path Rel Dir) Config (Path Rel Dir)
-> RIO Config (Path Rel Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Rel Dir) Config (Path Rel Dir)
forall env. HasConfig env => Lens' env (Path Rel Dir)
Lens' Config (Path Rel Dir)
workDirL
let projectStorageFile :: Path Abs File
projectStorageFile = Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
stackYaml Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
workDir Path Rel Dir -> Path Rel File -> Path Rel File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileStorage
Path Abs File -> (ProjectStorage -> RIO Config a) -> RIO Config a
forall env a.
HasLogFunc env =>
Path Abs File -> (ProjectStorage -> RIO env a) -> RIO env a
initProjectStorage Path Abs File
projectStorageFile ((ProjectStorage -> RIO Config a) -> RIO Config a)
-> (ProjectStorage -> RIO Config a) -> RIO Config a
forall a b. (a -> b) -> a -> b
$ \ProjectStorage
projectStorage -> do
let bc :: BuildConfig
bc = BuildConfig
{ Config
config :: Config
$sel:config:BuildConfig :: Config
config
, SMWanted
smWanted :: SMWanted
$sel:smWanted:BuildConfig :: SMWanted
smWanted
, [Path Abs Dir]
extraPackageDBs :: [Path Abs Dir]
$sel:extraPackageDBs:BuildConfig :: [Path Abs Dir]
extraPackageDBs
, Path Abs File
stackYaml :: Path Abs File
$sel:stackYaml:BuildConfig :: Path Abs File
stackYaml
, $sel:curator:BuildConfig :: Maybe Curator
curator = Project
project.curator
, ProjectStorage
projectStorage :: ProjectStorage
$sel:projectStorage:BuildConfig :: ProjectStorage
projectStorage
}
BuildConfig -> RIO BuildConfig a -> RIO Config a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO BuildConfig
bc RIO BuildConfig a
inner
where
getEmptyProject ::
Maybe RawSnapshotLocation
-> [PackageIdentifierRevision]
-> RIO Config Project
getEmptyProject :: Maybe RawSnapshotLocation
-> [PackageIdentifierRevision] -> RIO Config Project
getEmptyProject Maybe RawSnapshotLocation
mresolver [PackageIdentifierRevision]
extraDeps = do
RawSnapshotLocation
r <- case Maybe RawSnapshotLocation
mresolver of
Just RawSnapshotLocation
resolver -> do
[StyleDoc] -> RIO Config ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
[ String -> StyleDoc
flow String
"Using the snapshot"
, Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> Text
forall a. Display a => a -> Text
textDisplay RawSnapshotLocation
resolver)
, String -> StyleDoc
flow String
"specified on the command line."
]
RawSnapshotLocation -> RIO Config RawSnapshotLocation
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshotLocation
resolver
Maybe RawSnapshotLocation
Nothing -> do
RawSnapshotLocation
r'' <- RIO Config RawSnapshotLocation
forall env. HasConfig env => RIO env RawSnapshotLocation
getLatestResolver
[StyleDoc] -> RIO Config ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
[ String -> StyleDoc
flow String
"Using the latest snapshot"
, Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> Text
forall a. Display a => a -> Text
textDisplay RawSnapshotLocation
r'') StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
RawSnapshotLocation -> RIO Config RawSnapshotLocation
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshotLocation
r''
Project -> RIO Config Project
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Project
{ $sel:userMsg:Project :: Maybe String
userMsg = Maybe String
forall a. Maybe a
Nothing
, $sel:packages:Project :: [RelFilePath]
packages = []
, $sel:extraDeps:Project :: [RawPackageLocation]
extraDeps = (PackageIdentifierRevision -> RawPackageLocation)
-> [PackageIdentifierRevision] -> [RawPackageLocation]
forall a b. (a -> b) -> [a] -> [b]
map (RawPackageLocationImmutable -> RawPackageLocation
RPLImmutable (RawPackageLocationImmutable -> RawPackageLocation)
-> (PackageIdentifierRevision -> RawPackageLocationImmutable)
-> PackageIdentifierRevision
-> RawPackageLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageIdentifierRevision
-> Maybe TreeKey -> RawPackageLocationImmutable)
-> Maybe TreeKey
-> PackageIdentifierRevision
-> RawPackageLocationImmutable
forall a b c. (a -> b -> c) -> b -> a -> c
flip PackageIdentifierRevision
-> Maybe TreeKey -> RawPackageLocationImmutable
RPLIHackage Maybe TreeKey
forall a. Maybe a
Nothing) [PackageIdentifierRevision]
extraDeps
, $sel:flagsByPkg:Project :: Map PackageName (Map FlagName Bool)
flagsByPkg = Map PackageName (Map FlagName Bool)
forall a. Monoid a => a
mempty
, $sel:resolver:Project :: RawSnapshotLocation
resolver = RawSnapshotLocation
r
, $sel:compiler:Project :: Maybe WantedCompiler
compiler = Maybe WantedCompiler
forall a. Maybe a
Nothing
, $sel:extraPackageDBs:Project :: [String]
extraPackageDBs = []
, $sel:curator:Project :: Maybe Curator
curator = Maybe Curator
forall a. Maybe a
Nothing
, $sel:dropPackages:Project :: Set PackageName
dropPackages = Set PackageName
forall a. Monoid a => a
mempty
}
fillProjectWanted ::
(HasLogFunc env, HasPantryConfig env, HasProcessContext env)
=> Path Abs t
-> Config
-> Project
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO env DepPackage)
-> RIO env (SMWanted, [CompletedPLI])
fillProjectWanted :: forall env t.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
Path Abs t
-> Config
-> Project
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO env DepPackage)
-> RIO env (SMWanted, [CompletedPLI])
fillProjectWanted Path Abs t
stackYamlFP Config
config Project
project Map RawPackageLocationImmutable PackageLocationImmutable
locCache WantedCompiler
snapCompiler Map PackageName (Bool -> RIO env DepPackage)
snapPackages = do
let bopts :: BuildOpts
bopts = Config
config.build
[(PackageName, ProjectPackage)]
packages0 <- [RelFilePath]
-> (RelFilePath -> RIO env (PackageName, ProjectPackage))
-> RIO env [(PackageName, ProjectPackage)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Project
project.packages ((RelFilePath -> RIO env (PackageName, ProjectPackage))
-> RIO env [(PackageName, ProjectPackage)])
-> (RelFilePath -> RIO env (PackageName, ProjectPackage))
-> RIO env [(PackageName, ProjectPackage)]
forall a b. (a -> b) -> a -> b
$ \fp :: RelFilePath
fp@(RelFilePath Text
t) -> do
Path Abs Dir
abs' <- Path Abs Dir -> String -> RIO env (Path Abs Dir)
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Path Abs Dir)
resolveDir (Path Abs t -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs t
stackYamlFP) (Text -> String
T.unpack Text
t)
let resolved :: ResolvedPath Dir
resolved = RelFilePath -> Path Abs Dir -> ResolvedPath Dir
forall t. RelFilePath -> Path Abs t -> ResolvedPath t
ResolvedPath RelFilePath
fp Path Abs Dir
abs'
ProjectPackage
pp <- PrintWarnings -> ResolvedPath Dir -> Bool -> RIO env ProjectPackage
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PrintWarnings -> ResolvedPath Dir -> Bool -> RIO env ProjectPackage
mkProjectPackage PrintWarnings
YesPrintWarnings ResolvedPath Dir
resolved BuildOpts
bopts.buildHaddocks
(PackageName, ProjectPackage)
-> RIO env (PackageName, ProjectPackage)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProjectPackage
pp.projectCommon.name, ProjectPackage
pp)
let gitRepos :: [(Repo, RawPackageMetadata)]
gitRepos = (RawPackageLocation -> Maybe (Repo, RawPackageMetadata))
-> [RawPackageLocation] -> [(Repo, RawPackageMetadata)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
( \case
(RPLImmutable (RPLIRepo Repo
repo RawPackageMetadata
rpm)) -> (Repo, RawPackageMetadata) -> Maybe (Repo, RawPackageMetadata)
forall a. a -> Maybe a
Just (Repo
repo, RawPackageMetadata
rpm)
RawPackageLocation
_ -> Maybe (Repo, RawPackageMetadata)
forall a. Maybe a
Nothing
)
Project
project.extraDeps
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Prefetching git repos: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (String -> Text
T.pack ([(Repo, RawPackageMetadata)] -> String
forall a. Show a => a -> String
show [(Repo, RawPackageMetadata)]
gitRepos)))
[(Repo, RawPackageMetadata)] -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[(Repo, RawPackageMetadata)] -> RIO env ()
fetchReposRaw [(Repo, RawPackageMetadata)]
gitRepos
([(PackageName, DepPackage)]
deps0, [Maybe CompletedPLI]
mcompleted) <- ([((PackageName, DepPackage), Maybe CompletedPLI)]
-> ([(PackageName, DepPackage)], [Maybe CompletedPLI]))
-> RIO env [((PackageName, DepPackage), Maybe CompletedPLI)]
-> RIO env ([(PackageName, DepPackage)], [Maybe CompletedPLI])
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [((PackageName, DepPackage), Maybe CompletedPLI)]
-> ([(PackageName, DepPackage)], [Maybe CompletedPLI])
forall a b. [(a, b)] -> ([a], [b])
unzip (RIO env [((PackageName, DepPackage), Maybe CompletedPLI)]
-> RIO env ([(PackageName, DepPackage)], [Maybe CompletedPLI]))
-> ((RawPackageLocation
-> RIO env ((PackageName, DepPackage), Maybe CompletedPLI))
-> RIO env [((PackageName, DepPackage), Maybe CompletedPLI)])
-> (RawPackageLocation
-> RIO env ((PackageName, DepPackage), Maybe CompletedPLI))
-> RIO env ([(PackageName, DepPackage)], [Maybe CompletedPLI])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RawPackageLocation]
-> (RawPackageLocation
-> RIO env ((PackageName, DepPackage), Maybe CompletedPLI))
-> RIO env [((PackageName, DepPackage), Maybe CompletedPLI)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Project
project.extraDeps ((RawPackageLocation
-> RIO env ((PackageName, DepPackage), Maybe CompletedPLI))
-> RIO env ([(PackageName, DepPackage)], [Maybe CompletedPLI]))
-> (RawPackageLocation
-> RIO env ((PackageName, DepPackage), Maybe CompletedPLI))
-> RIO env ([(PackageName, DepPackage)], [Maybe CompletedPLI])
forall a b. (a -> b) -> a -> b
$ \RawPackageLocation
rpl -> do
(PackageLocation
pl, Maybe CompletedPLI
mCompleted) <- case RawPackageLocation
rpl of
RPLImmutable RawPackageLocationImmutable
rpli -> do
(PackageLocationImmutable
compl, Maybe PackageLocationImmutable
mcompl) <-
case RawPackageLocationImmutable
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> Maybe PackageLocationImmutable
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RawPackageLocationImmutable
rpli Map RawPackageLocationImmutable PackageLocationImmutable
locCache of
Just PackageLocationImmutable
compl -> (PackageLocationImmutable, Maybe PackageLocationImmutable)
-> RIO
env (PackageLocationImmutable, Maybe PackageLocationImmutable)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageLocationImmutable
compl, PackageLocationImmutable -> Maybe PackageLocationImmutable
forall a. a -> Maybe a
Just PackageLocationImmutable
compl)
Maybe PackageLocationImmutable
Nothing -> do
CompletePackageLocation
cpl <- RawPackageLocationImmutable -> RIO env CompletePackageLocation
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env CompletePackageLocation
completePackageLocation RawPackageLocationImmutable
rpli
if CompletePackageLocation -> Bool
cplHasCabalFile CompletePackageLocation
cpl
then (PackageLocationImmutable, Maybe PackageLocationImmutable)
-> RIO
env (PackageLocationImmutable, Maybe PackageLocationImmutable)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompletePackageLocation -> PackageLocationImmutable
cplComplete CompletePackageLocation
cpl, PackageLocationImmutable -> Maybe PackageLocationImmutable
forall a. a -> Maybe a
Just (PackageLocationImmutable -> Maybe PackageLocationImmutable)
-> PackageLocationImmutable -> Maybe PackageLocationImmutable
forall a b. (a -> b) -> a -> b
$ CompletePackageLocation -> PackageLocationImmutable
cplComplete CompletePackageLocation
cpl)
else do
RawPackageLocationImmutable -> RIO env ()
forall env.
HasLogFunc env =>
RawPackageLocationImmutable -> RIO env ()
warnMissingCabalFile RawPackageLocationImmutable
rpli
(PackageLocationImmutable, Maybe PackageLocationImmutable)
-> RIO
env (PackageLocationImmutable, Maybe PackageLocationImmutable)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompletePackageLocation -> PackageLocationImmutable
cplComplete CompletePackageLocation
cpl, Maybe PackageLocationImmutable
forall a. Maybe a
Nothing)
(PackageLocation, Maybe CompletedPLI)
-> RIO env (PackageLocation, Maybe CompletedPLI)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageLocationImmutable -> PackageLocation
PLImmutable PackageLocationImmutable
compl, RawPackageLocationImmutable
-> PackageLocationImmutable -> CompletedPLI
CompletedPLI RawPackageLocationImmutable
rpli (PackageLocationImmutable -> CompletedPLI)
-> Maybe PackageLocationImmutable -> Maybe CompletedPLI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PackageLocationImmutable
mcompl)
RPLMutable ResolvedPath Dir
p ->
(PackageLocation, Maybe CompletedPLI)
-> RIO env (PackageLocation, Maybe CompletedPLI)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResolvedPath Dir -> PackageLocation
PLMutable ResolvedPath Dir
p, Maybe CompletedPLI
forall a. Maybe a
Nothing)
DepPackage
dp <- Bool -> PackageLocation -> RIO env DepPackage
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool -> PackageLocation -> RIO env DepPackage
additionalDepPackage (BuildOpts -> Bool
shouldHaddockDeps BuildOpts
bopts) PackageLocation
pl
((PackageName, DepPackage), Maybe CompletedPLI)
-> RIO env ((PackageName, DepPackage), Maybe CompletedPLI)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((DepPackage
dp.depCommon.name, DepPackage
dp), Maybe CompletedPLI
mCompleted)
[(PackageName, PackageLocation)] -> RIO env ()
forall (m :: * -> *).
MonadThrow m =>
[(PackageName, PackageLocation)] -> m ()
checkDuplicateNames ([(PackageName, PackageLocation)] -> RIO env ())
-> [(PackageName, PackageLocation)] -> RIO env ()
forall a b. (a -> b) -> a -> b
$
((PackageName, ProjectPackage) -> (PackageName, PackageLocation))
-> [(PackageName, ProjectPackage)]
-> [(PackageName, PackageLocation)]
forall a b. (a -> b) -> [a] -> [b]
map ((ProjectPackage -> PackageLocation)
-> (PackageName, ProjectPackage) -> (PackageName, PackageLocation)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (ResolvedPath Dir -> PackageLocation
PLMutable (ResolvedPath Dir -> PackageLocation)
-> (ProjectPackage -> ResolvedPath Dir)
-> ProjectPackage
-> PackageLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.resolvedDir))) [(PackageName, ProjectPackage)]
packages0 [(PackageName, PackageLocation)]
-> [(PackageName, PackageLocation)]
-> [(PackageName, PackageLocation)]
forall a. [a] -> [a] -> [a]
++
((PackageName, DepPackage) -> (PackageName, PackageLocation))
-> [(PackageName, DepPackage)] -> [(PackageName, PackageLocation)]
forall a b. (a -> b) -> [a] -> [b]
map ((DepPackage -> PackageLocation)
-> (PackageName, DepPackage) -> (PackageName, PackageLocation)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (.location)) [(PackageName, DepPackage)]
deps0
let packages1 :: Map PackageName ProjectPackage
packages1 = [(PackageName, ProjectPackage)] -> Map PackageName ProjectPackage
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName, ProjectPackage)]
packages0
snPackages :: Map PackageName (Bool -> RIO env DepPackage)
snPackages = Map PackageName (Bool -> RIO env DepPackage)
snapPackages
Map PackageName (Bool -> RIO env DepPackage)
-> Map PackageName ProjectPackage
-> Map PackageName (Bool -> RIO env DepPackage)
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map PackageName ProjectPackage
packages1
Map PackageName (Bool -> RIO env DepPackage)
-> Map PackageName DepPackage
-> Map PackageName (Bool -> RIO env DepPackage)
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` [(PackageName, DepPackage)] -> Map PackageName DepPackage
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName, DepPackage)]
deps0
Map PackageName (Bool -> RIO env DepPackage)
-> Set PackageName -> Map PackageName (Bool -> RIO env DepPackage)
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.withoutKeys` Project
project.dropPackages
Map PackageName DepPackage
snDeps <- Map PackageName (Bool -> RIO env DepPackage)
-> ((Bool -> RIO env DepPackage) -> RIO env DepPackage)
-> RIO env (Map PackageName DepPackage)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Map PackageName (Bool -> RIO env DepPackage)
snPackages (((Bool -> RIO env DepPackage) -> RIO env DepPackage)
-> RIO env (Map PackageName DepPackage))
-> ((Bool -> RIO env DepPackage) -> RIO env DepPackage)
-> RIO env (Map PackageName DepPackage)
forall a b. (a -> b) -> a -> b
$ \Bool -> RIO env DepPackage
getDep -> Bool -> RIO env DepPackage
getDep (BuildOpts -> Bool
shouldHaddockDeps BuildOpts
bopts)
let deps1 :: Map PackageName DepPackage
deps1 = [(PackageName, DepPackage)] -> Map PackageName DepPackage
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName, DepPackage)]
deps0 Map PackageName DepPackage
-> Map PackageName DepPackage -> Map PackageName DepPackage
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map PackageName DepPackage
snDeps
let mergeApply :: Map k c -> Map k b -> (k -> c -> b -> c) -> Map k c
mergeApply Map k c
m1 Map k b
m2 k -> c -> b -> c
f =
SimpleWhenMissing k c c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k c b c
-> Map k c
-> Map k b
-> Map k c
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
MS.merge SimpleWhenMissing k c c
forall (f :: * -> *) k x. Applicative f => WhenMissing f k x x
MS.preserveMissing SimpleWhenMissing k b c
forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
MS.dropMissing ((k -> c -> b -> c) -> SimpleWhenMatched k c b c
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
MS.zipWithMatched k -> c -> b -> c
f) Map k c
m1 Map k b
m2
pFlags :: Map PackageName (Map FlagName Bool)
pFlags = Project
project.flagsByPkg
packages2 :: Map PackageName ProjectPackage
packages2 = Map PackageName ProjectPackage
-> Map PackageName (Map FlagName Bool)
-> (PackageName
-> ProjectPackage -> Map FlagName Bool -> ProjectPackage)
-> Map PackageName ProjectPackage
forall {k} {c} {b}.
Ord k =>
Map k c -> Map k b -> (k -> c -> b -> c) -> Map k c
mergeApply Map PackageName ProjectPackage
packages1 Map PackageName (Map FlagName Bool)
pFlags ((PackageName
-> ProjectPackage -> Map FlagName Bool -> ProjectPackage)
-> Map PackageName ProjectPackage)
-> (PackageName
-> ProjectPackage -> Map FlagName Bool -> ProjectPackage)
-> Map PackageName ProjectPackage
forall a b. (a -> b) -> a -> b
$ \PackageName
_ ProjectPackage
p Map FlagName Bool
flags ->
ProjectPackage
p { projectCommon = p.projectCommon { flags = flags } }
deps2 :: Map PackageName DepPackage
deps2 = Map PackageName DepPackage
-> Map PackageName (Map FlagName Bool)
-> (PackageName -> DepPackage -> Map FlagName Bool -> DepPackage)
-> Map PackageName DepPackage
forall {k} {c} {b}.
Ord k =>
Map k c -> Map k b -> (k -> c -> b -> c) -> Map k c
mergeApply Map PackageName DepPackage
deps1 Map PackageName (Map FlagName Bool)
pFlags ((PackageName -> DepPackage -> Map FlagName Bool -> DepPackage)
-> Map PackageName DepPackage)
-> (PackageName -> DepPackage -> Map FlagName Bool -> DepPackage)
-> Map PackageName DepPackage
forall a b. (a -> b) -> a -> b
$ \PackageName
_ DepPackage
d Map FlagName Bool
flags ->
DepPackage
d { depCommon = d.depCommon { flags = flags } }
Map PackageName (Map FlagName Bool)
-> FlagSource
-> Map PackageName ProjectPackage
-> Map PackageName DepPackage
-> RIO env ()
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Map PackageName (Map FlagName Bool)
-> FlagSource
-> Map PackageName ProjectPackage
-> Map PackageName DepPackage
-> m ()
checkFlagsUsedThrowing Map PackageName (Map FlagName Bool)
pFlags FlagSource
FSStackYaml Map PackageName ProjectPackage
packages1 Map PackageName DepPackage
deps1
let pkgGhcOptions :: Map PackageName [Text]
pkgGhcOptions = Config
config.ghcOptionsByName
deps :: Map PackageName DepPackage
deps = Map PackageName DepPackage
-> Map PackageName [Text]
-> (PackageName -> DepPackage -> [Text] -> DepPackage)
-> Map PackageName DepPackage
forall {k} {c} {b}.
Ord k =>
Map k c -> Map k b -> (k -> c -> b -> c) -> Map k c
mergeApply Map PackageName DepPackage
deps2 Map PackageName [Text]
pkgGhcOptions ((PackageName -> DepPackage -> [Text] -> DepPackage)
-> Map PackageName DepPackage)
-> (PackageName -> DepPackage -> [Text] -> DepPackage)
-> Map PackageName DepPackage
forall a b. (a -> b) -> a -> b
$ \PackageName
_ DepPackage
d [Text]
options ->
DepPackage
d { depCommon = d.depCommon { ghcOptions = options } }
packages :: Map PackageName ProjectPackage
packages = Map PackageName ProjectPackage
-> Map PackageName [Text]
-> (PackageName -> ProjectPackage -> [Text] -> ProjectPackage)
-> Map PackageName ProjectPackage
forall {k} {c} {b}.
Ord k =>
Map k c -> Map k b -> (k -> c -> b -> c) -> Map k c
mergeApply Map PackageName ProjectPackage
packages2 Map PackageName [Text]
pkgGhcOptions ((PackageName -> ProjectPackage -> [Text] -> ProjectPackage)
-> Map PackageName ProjectPackage)
-> (PackageName -> ProjectPackage -> [Text] -> ProjectPackage)
-> Map PackageName ProjectPackage
forall a b. (a -> b) -> a -> b
$ \PackageName
_ ProjectPackage
p [Text]
options ->
ProjectPackage
p { projectCommon = p.projectCommon { ghcOptions = options } }
unusedPkgGhcOptions :: Map PackageName [Text]
unusedPkgGhcOptions =
Map PackageName [Text]
pkgGhcOptions Map PackageName [Text] -> Set PackageName -> Map PackageName [Text]
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Map PackageName ProjectPackage -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet Map PackageName ProjectPackage
packages2
Map PackageName [Text] -> Set PackageName -> Map PackageName [Text]
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Map PackageName DepPackage -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet Map PackageName DepPackage
deps2
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Map PackageName [Text] -> Bool
forall k a. Map k a -> Bool
Map.null Map PackageName [Text]
unusedPkgGhcOptions) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
BuildException -> RIO env ()
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (BuildException -> RIO env ()) -> BuildException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [PackageName] -> BuildException
InvalidGhcOptionsSpecification (Map PackageName [Text] -> [PackageName]
forall k a. Map k a -> [k]
Map.keys Map PackageName [Text]
unusedPkgGhcOptions)
let wanted :: SMWanted
wanted = SMWanted
{ $sel:compiler:SMWanted :: WantedCompiler
compiler = WantedCompiler -> Maybe WantedCompiler -> WantedCompiler
forall a. a -> Maybe a -> a
fromMaybe WantedCompiler
snapCompiler Project
project.compiler
, $sel:project:SMWanted :: Map PackageName ProjectPackage
project = Map PackageName ProjectPackage
packages
, $sel:deps:SMWanted :: Map PackageName DepPackage
deps = Map PackageName DepPackage
deps
, $sel:snapshotLocation:SMWanted :: RawSnapshotLocation
snapshotLocation = Project
project.resolver
}
(SMWanted, [CompletedPLI]) -> RIO env (SMWanted, [CompletedPLI])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SMWanted
wanted, [Maybe CompletedPLI] -> [CompletedPLI]
forall a. [Maybe a] -> [a]
catMaybes [Maybe CompletedPLI]
mcompleted)
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
determineStackRootAndOwnership ::
MonadIO m
=> ConfigMonoid
-> 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 :: 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 ::
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)
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)
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)
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)
getExtraConfigs :: HasTerm env
=> Path Abs File
-> RIO env [Path Abs File]
Path Abs File
userConfigPath = do
Maybe (Path Abs File)
defaultStackGlobalConfigPath <- RIO env (Maybe (Path Abs File))
forall env. HasTerm env => RIO env (Maybe (Path Abs File))
getDefaultGlobalConfigPath
IO [Path Abs File] -> RIO env [Path Abs File]
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Path Abs File] -> RIO env [Path Abs File])
-> IO [Path Abs File] -> RIO env [Path Abs File]
forall a b. (a -> b) -> a -> b
$ do
[(String, String)]
env <- IO [(String, String)]
getEnvironment
Maybe (Path Abs File)
mstackConfig <-
IO (Maybe (Path Abs File))
-> (String -> IO (Maybe (Path Abs File)))
-> Maybe String
-> IO (Maybe (Path Abs File))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe (Path Abs File) -> IO (Maybe (Path Abs File))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs File)
forall a. Maybe a
Nothing) ((Path Abs File -> Maybe (Path Abs File))
-> IO (Path Abs File) -> IO (Maybe (Path Abs File))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just (IO (Path Abs File) -> IO (Maybe (Path Abs File)))
-> (String -> IO (Path Abs File))
-> String
-> IO (Maybe (Path Abs File))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Path Abs File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile)
(Maybe String -> IO (Maybe (Path Abs File)))
-> Maybe String -> IO (Maybe (Path Abs File))
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"STACK_CONFIG" [(String, String)]
env
Maybe (Path Abs File)
mstackGlobalConfig <-
IO (Maybe (Path Abs File))
-> (String -> IO (Maybe (Path Abs File)))
-> Maybe String
-> IO (Maybe (Path Abs File))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe (Path Abs File) -> IO (Maybe (Path Abs File))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs File)
forall a. Maybe a
Nothing) ((Path Abs File -> Maybe (Path Abs File))
-> IO (Path Abs File) -> IO (Maybe (Path Abs File))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just (IO (Path Abs File) -> IO (Maybe (Path Abs File)))
-> (String -> IO (Path Abs File))
-> String
-> IO (Maybe (Path Abs File))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Path Abs File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile)
(Maybe String -> IO (Maybe (Path Abs File)))
-> Maybe String -> IO (Maybe (Path Abs File))
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"STACK_GLOBAL_CONFIG" [(String, String)]
env
(Path Abs File -> IO Bool) -> [Path Abs File] -> IO [Path Abs File]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Path Abs File -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist
([Path Abs File] -> IO [Path Abs File])
-> [Path Abs File] -> IO [Path Abs File]
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Maybe (Path Abs File) -> Path Abs File
forall a. a -> Maybe a -> a
fromMaybe Path Abs File
userConfigPath Maybe (Path Abs File)
mstackConfig
Path Abs File -> [Path Abs File] -> [Path Abs File]
forall a. a -> [a] -> [a]
: [Path Abs File]
-> (Path Abs File -> [Path Abs File])
-> Maybe (Path Abs File)
-> [Path Abs File]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Path Abs File -> [Path Abs File]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Path Abs File)
mstackGlobalConfig Maybe (Path Abs File)
-> Maybe (Path Abs File) -> Maybe (Path Abs File)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Path Abs File)
defaultStackGlobalConfigPath)
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
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)
getProjectConfig :: HasTerm env
=> StackYamlLoc
-> RIO env (ProjectConfig (Path Abs File))
getProjectConfig :: forall env.
HasTerm env =>
StackYamlLoc -> RIO env (ProjectConfig (Path Abs File))
getProjectConfig (SYLOverride Path Abs File
stackYaml) = ProjectConfig (Path Abs File)
-> RIO env (ProjectConfig (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProjectConfig (Path Abs File)
-> RIO env (ProjectConfig (Path Abs File)))
-> ProjectConfig (Path Abs File)
-> RIO env (ProjectConfig (Path Abs File))
forall a b. (a -> b) -> a -> b
$ Path Abs File -> ProjectConfig (Path Abs File)
forall a. a -> ProjectConfig a
PCProject Path Abs File
stackYaml
getProjectConfig StackYamlLoc
SYLGlobalProject = ProjectConfig (Path Abs File)
-> RIO env (ProjectConfig (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectConfig (Path Abs File)
forall a. ProjectConfig a
PCGlobalProject
getProjectConfig StackYamlLoc
SYLDefault = do
[(String, String)]
env <- IO [(String, String)] -> RIO env [(String, String)]
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(String, String)]
getEnvironment
case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"STACK_YAML" [(String, String)]
env of
Just String
fp -> do
String -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
String -> m ()
prettyInfoS
String
"Getting the project-level configuration file from the \
\STACK_YAML environment variable."
Path Abs File -> ProjectConfig (Path Abs File)
forall a. a -> ProjectConfig a
PCProject (Path Abs File -> ProjectConfig (Path Abs File))
-> RIO env (Path Abs File)
-> RIO env (ProjectConfig (Path Abs File))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> RIO env (Path Abs File)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs File)
resolveFile' String
fp
Maybe String
Nothing -> do
Path Abs Dir
currDir <- RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
ProjectConfig (Path Abs File)
-> (Path Abs File -> ProjectConfig (Path Abs File))
-> Maybe (Path Abs File)
-> ProjectConfig (Path Abs File)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ProjectConfig (Path Abs File)
forall a. ProjectConfig a
PCGlobalProject Path Abs File -> ProjectConfig (Path Abs File)
forall a. a -> ProjectConfig a
PCProject (Maybe (Path Abs File) -> ProjectConfig (Path Abs File))
-> RIO env (Maybe (Path Abs File))
-> RIO env (ProjectConfig (Path Abs File))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Path Abs Dir -> RIO env (Maybe (Path Abs File)))
-> Path Abs Dir -> RIO env (Maybe (Path Abs File))
forall (m :: * -> *) a.
MonadIO m =>
(Path Abs Dir -> m (Maybe a)) -> Path Abs Dir -> m (Maybe a)
findInParents Path Abs Dir -> RIO env (Maybe (Path Abs File))
forall {m :: * -> *} {env} {b}.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
Path b Dir -> m (Maybe (Path b File))
getStackDotYaml Path Abs Dir
currDir
where
getStackDotYaml :: Path b Dir -> m (Maybe (Path b File))
getStackDotYaml Path b Dir
dir = do
let fp :: Path b File
fp = Path b Dir
dir Path b Dir -> Path Rel File -> Path b File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
stackDotYaml
fp' :: String
fp' = Path b File -> String
forall b t. Path b t -> String
toFilePath Path b File
fp
Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Checking for project config at: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString String
fp'
Bool
exists <- Path b File -> m Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path b File
fp
if Bool
exists
then Maybe (Path b File) -> m (Maybe (Path b File))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Path b File) -> m (Maybe (Path b File)))
-> Maybe (Path b File) -> m (Maybe (Path b File))
forall a b. (a -> b) -> a -> b
$ Path b File -> Maybe (Path b File)
forall a. a -> Maybe a
Just Path b File
fp
else Maybe (Path b File) -> m (Maybe (Path b File))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path b File)
forall a. Maybe a
Nothing
getProjectConfig (SYLNoProject [PackageIdentifierRevision]
extraDeps) = ProjectConfig (Path Abs File)
-> RIO env (ProjectConfig (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProjectConfig (Path Abs File)
-> RIO env (ProjectConfig (Path Abs File)))
-> ProjectConfig (Path Abs File)
-> RIO env (ProjectConfig (Path Abs File))
forall a b. (a -> b) -> a -> b
$ [PackageIdentifierRevision] -> ProjectConfig (Path Abs File)
forall a. [PackageIdentifierRevision] -> ProjectConfig a
PCNoProject [PackageIdentifierRevision]
extraDeps
loadProjectConfig ::
HasTerm env
=> StackYamlLoc
-> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid))
loadProjectConfig :: forall env.
HasTerm env =>
StackYamlLoc
-> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid))
loadProjectConfig StackYamlLoc
mstackYaml = do
ProjectConfig (Path Abs File)
mfp <- StackYamlLoc -> RIO env (ProjectConfig (Path Abs File))
forall env.
HasTerm env =>
StackYamlLoc -> RIO env (ProjectConfig (Path Abs File))
getProjectConfig StackYamlLoc
mstackYaml
case ProjectConfig (Path Abs File)
mfp of
PCProject Path Abs File
fp -> do
Path Abs Dir
currDir <- RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Loading project config file " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
String -> Utf8Builder
forall a. IsString a => String -> a
fromString (String
-> (Path Rel File -> String) -> Maybe (Path Rel File) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
fp) Path Rel File -> String
forall b t. Path b t -> String
toFilePath (Path Abs Dir -> Path Abs File -> Maybe (Path Rel File)
forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix Path Abs Dir
currDir Path Abs File
fp))
(Project, Path Abs File, ConfigMonoid)
-> ProjectConfig (Project, Path Abs File, ConfigMonoid)
forall a. a -> ProjectConfig a
PCProject ((Project, Path Abs File, ConfigMonoid)
-> ProjectConfig (Project, Path Abs File, ConfigMonoid))
-> RIO env (Project, Path Abs File, ConfigMonoid)
-> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs File -> RIO env (Project, Path Abs File, ConfigMonoid)
forall {env}.
HasLogFunc env =>
Path Abs File -> RIO env (Project, Path Abs File, ConfigMonoid)
load Path Abs File
fp
ProjectConfig (Path Abs File)
PCGlobalProject -> do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"No project config file found, using defaults."
ProjectConfig (Project, Path Abs File, ConfigMonoid)
-> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectConfig (Project, Path Abs File, ConfigMonoid)
forall a. ProjectConfig a
PCGlobalProject
PCNoProject [PackageIdentifierRevision]
extraDeps -> do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Ignoring config files"
ProjectConfig (Project, Path Abs File, ConfigMonoid)
-> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProjectConfig (Project, Path Abs File, ConfigMonoid)
-> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid)))
-> ProjectConfig (Project, Path Abs File, ConfigMonoid)
-> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid))
forall a b. (a -> b) -> a -> b
$ [PackageIdentifierRevision]
-> ProjectConfig (Project, Path Abs File, ConfigMonoid)
forall a. [PackageIdentifierRevision] -> ProjectConfig a
PCNoProject [PackageIdentifierRevision]
extraDeps
where
load :: Path Abs File -> RIO env (Project, Path Abs File, ConfigMonoid)
load Path Abs File
fp = do
IO ProjectAndConfigMonoid
iopc <- (Value -> Parser (WithJSONWarnings (IO ProjectAndConfigMonoid)))
-> Path Abs File -> RIO env (IO ProjectAndConfigMonoid)
forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env a
loadConfigYaml (Path Abs Dir
-> Value -> Parser (WithJSONWarnings (IO ProjectAndConfigMonoid))
parseProjectAndConfigMonoid (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
fp)) Path Abs File
fp
ProjectAndConfigMonoid Project
project ConfigMonoid
config <- IO ProjectAndConfigMonoid -> RIO env ProjectAndConfigMonoid
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ProjectAndConfigMonoid
iopc
(Project, Path Abs File, ConfigMonoid)
-> RIO env (Project, Path Abs File, ConfigMonoid)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Project
project, Path Abs File
fp, ConfigMonoid
config)
getDefaultGlobalConfigPath ::
HasTerm env
=> RIO env (Maybe (Path Abs File))
getDefaultGlobalConfigPath :: forall env. HasTerm env => RIO env (Maybe (Path Abs File))
getDefaultGlobalConfigPath =
case (Maybe (Path Abs File)
defaultGlobalConfigPath, Maybe (Path Abs File)
defaultGlobalConfigPathDeprecated) of
(Just Path Abs File
new, Just Path Abs File
old) ->
Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just (Path Abs File -> Maybe (Path Abs File))
-> ((Path Abs File, Bool) -> Path Abs File)
-> (Path Abs File, Bool)
-> Maybe (Path Abs File)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path Abs File, Bool) -> Path Abs File
forall a b. (a, b) -> a
fst ((Path Abs File, Bool) -> Maybe (Path Abs File))
-> RIO env (Path Abs File, Bool) -> RIO env (Maybe (Path Abs File))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Maybe Text
-> (Path Abs File -> RIO env Bool)
-> Path Abs File
-> Path Abs File
-> RIO env (Path Abs File, Bool)
forall env a.
HasTerm env =>
Maybe Text
-> (Path Abs a -> RIO env Bool)
-> Path Abs a
-> Path Abs a
-> RIO env (Path Abs a, Bool)
tryDeprecatedPath
(Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"non-project global configuration file")
Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist
Path Abs File
new
Path Abs File
old
(Just Path Abs File
new,Maybe (Path Abs File)
Nothing) -> Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just Path Abs File
new)
(Maybe (Path Abs File), Maybe (Path Abs File))
_ -> Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs File)
forall a. Maybe a
Nothing
getDefaultUserConfigPath ::
HasTerm env
=> Path Abs Dir
-> RIO env (Path Abs File)
getDefaultUserConfigPath :: forall env. HasTerm env => Path Abs Dir -> RIO env (Path Abs File)
getDefaultUserConfigPath Path Abs Dir
stackRoot = do
(Path Abs File
path, Bool
exists) <- Maybe Text
-> (Path Abs File -> RIO env Bool)
-> Path Abs File
-> Path Abs File
-> RIO env (Path Abs File, Bool)
forall env a.
HasTerm env =>
Maybe Text
-> (Path Abs a -> RIO env Bool)
-> Path Abs a
-> Path Abs a
-> RIO env (Path Abs a, Bool)
tryDeprecatedPath
(Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"non-project configuration file")
Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist
(Path Abs Dir -> Path Abs File
defaultUserConfigPath Path Abs Dir
stackRoot)
(Path Abs Dir -> Path Abs File
defaultUserConfigPathDeprecated Path Abs Dir
stackRoot)
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
path)
IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Builder -> IO ()
forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
path Builder
forall s. (IsString s, Semigroup s) => s
defaultConfigYaml
Path Abs File -> RIO env (Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
path
packagesParser :: Parser [String]
packagesParser :: Parser [String]
packagesParser = Parser String -> Parser [String]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
(String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"package" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<>
String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"PACKAGE" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<>
String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Add a package (can be specified multiple times)"))
defaultConfigYaml :: (IsString s, Semigroup s) => s
defaultConfigYaml :: forall s. (IsString s, Semigroup s) => s
defaultConfigYaml =
s
"# This file contains default non-project-specific settings for Stack, used\n" s -> s -> s
forall a. Semigroup a => a -> a -> a
<>
s
"# in all projects. For more information about Stack's configuration, see\n" s -> s -> s
forall a. Semigroup a => a -> a -> a
<>
s
"# http://docs.haskellstack.org/en/stable/yaml_configuration/\n" s -> s -> s
forall a. Semigroup a => a -> a -> a
<>
s
"\n" s -> s -> s
forall a. Semigroup a => a -> a -> a
<>
s
"# The following parameters are used by 'stack new' to automatically fill fields\n" s -> s -> s
forall a. Semigroup a => a -> a -> a
<>
s
"# in the Cabal file. We recommend uncommenting them and filling them out if\n" s -> s -> s
forall a. Semigroup a => a -> a -> a
<>
s
"# you intend to use 'stack new'.\n" s -> s -> s
forall a. Semigroup a => a -> a -> a
<>
s
"# See https://docs.haskellstack.org/en/stable/yaml_configuration/#templates\n" s -> s -> s
forall a. Semigroup a => a -> a -> a
<>
s
"templates:\n" s -> s -> s
forall a. Semigroup a => a -> a -> a
<>
s
" params:\n" s -> s -> s
forall a. Semigroup a => a -> a -> a
<>
s
"# author-name:\n" s -> s -> s
forall a. Semigroup a => a -> a -> a
<>
s
"# author-email:\n" s -> s -> s
forall a. Semigroup a => a -> a -> a
<>
s
"# copyright:\n" s -> s -> s
forall a. Semigroup a => a -> a -> a
<>
s
"# github-username:\n" s -> s -> s
forall a. Semigroup a => a -> a -> a
<>
s
"\n" s -> s -> s
forall a. Semigroup a => a -> a -> a
<>
s
"# The following parameter specifies Stack's output styles; STYLES is a\n" s -> s -> s
forall a. Semigroup a => a -> a -> a
<>
s
"# colon-delimited sequence of key=value, where 'key' is a style name and\n" s -> s -> s
forall a. Semigroup a => a -> a -> a
<>
s
"# 'value' is a semicolon-delimited list of 'ANSI' SGR (Select Graphic\n" s -> s -> s
forall a. Semigroup a => a -> a -> a
<>
s
"# Rendition) control codes (in decimal). Use 'stack ls stack-colors --basic'\n" s -> s -> s
forall a. Semigroup a => a -> a -> a
<>
s
"# to see the current sequence.\n" s -> s -> s
forall a. Semigroup a => a -> a -> a
<>
s
"# stack-colors: STYLES\n"