{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Stack.Config
( loadConfig
, loadConfigYaml
, packagesParser
, getImplicitGlobalProjectDir
, getSnapshots
, makeConcreteResolver
, checkOwnership
, getInContainer
, getInNixShell
, defaultConfigYaml
, getProjectConfig
, withBuildConfig
, withNewLogFunc
) where
import Control.Monad.Extra ( firstJustM )
import Data.Array.IArray ( (!), (//) )
import qualified Data.ByteString as S
import Data.ByteString.Builder ( byteString )
import Data.Coerce ( coerce )
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import qualified Data.Map.Merge.Strict as MS
import qualified Data.Monoid
import Data.Monoid.Map ( MonoidMap (..) )
import qualified Data.Text as T
import qualified Data.Yaml as Yaml
import Distribution.System
( Arch (OtherArch), OS (..), Platform (..), buildPlatform )
import qualified Distribution.Text
import Distribution.Version ( simplifyVersionRange )
import GHC.Conc ( getNumProcessors )
import Network.HTTP.StackClient
( httpJSON, parseUrlThrow, getResponseBody )
import Options.Applicative ( Parser, help, long, metavar, strOption )
import Pantry.Internal.AesonExtended
import Path
import Path.Extra ( toFilePathNoTrailingSep )
import Path.Find ( findInParents )
import Path.IO
import RIO.List ( unzip )
import RIO.Process
import RIO.Time ( toGregorian )
import Stack.Build.Haddock ( shouldHaddockDeps )
import Stack.Config.Build
import Stack.Config.Docker
import Stack.Config.Nix
import Stack.Constants
import Stack.Lock ( lockCachedWanted )
import Stack.Prelude
import Stack.SourceMap
import Stack.Storage.Project ( initProjectStorage )
import Stack.Storage.User ( initUserStorage )
import Stack.Storage.Util ( handleMigrationException )
import Stack.Types.Build
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.Docker
import Stack.Types.Nix
import Stack.Types.Resolver
import Stack.Types.SourceMap
import Stack.Types.Version
( IntersectingVersionRange (..), VersionCheck (..)
, stackVersion, withinRange
)
import System.Console.ANSI
( hSupportsANSIWithoutEmulation, setSGRCode )
import System.Environment
import System.Info.ShortPathName ( getShortPathName )
import System.PosixCompat.Files ( fileOwner, getFileStatus )
import System.PosixCompat.User ( getEffectiveUserID )
tryDeprecatedPath ::
HasLogFunc 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.
HasLogFunc env =>
Maybe Text
-> (Path Abs a -> RIO env Bool)
-> Path Abs a
-> Path Abs a
-> RIO env (Path Abs a, Bool)
tryDeprecatedPath Maybe Text
mWarningDesc Path Abs a -> RIO env Bool
exists Path Abs a
new Path Abs a
old = do
Bool
newExists <- Path Abs a -> RIO env Bool
exists Path Abs a
new
if Bool
newExists
then forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs a
new, Bool
True)
else do
Bool
oldExists <- Path Abs a -> RIO env Bool
exists Path Abs a
old
if Bool
oldExists
then do
case Maybe Text
mWarningDesc of
Maybe Text
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just Text
desc ->
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Warning: Location of " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
desc forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" at '" forall a. Semigroup a => a -> a -> a
<>
forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs a
old) forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"' is deprecated; rename it to '" forall a. Semigroup a => a -> a -> a
<>
forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs a
new) forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"' instead"
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs a
old, Bool
True)
else forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs a
new, Bool
False)
getImplicitGlobalProjectDir ::
HasLogFunc env
=> Config -> RIO env (Path Abs Dir)
getImplicitGlobalProjectDir :: forall env. HasLogFunc env => Config -> RIO env (Path Abs Dir)
getImplicitGlobalProjectDir Config
config =
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall env a.
HasLogFunc env =>
Maybe Text
-> (Path Abs a -> RIO env Bool)
-> Path Abs a
-> Path Abs a
-> RIO env (Path Abs a, Bool)
tryDeprecatedPath
forall a. Maybe a
Nothing
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist
(Path Abs Dir -> Path Abs Dir
implicitGlobalProjectDir Path Abs Dir
stackRoot)
(Path Abs Dir -> Path Abs Dir
implicitGlobalProjectDirDeprecated Path Abs Dir
stackRoot)
where
stackRoot :: Path Abs Dir
stackRoot = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s (Path Abs Dir)
stackRootL Config
config
getSnapshots :: HasConfig env => RIO env Snapshots
getSnapshots :: forall env. HasConfig env => RIO env Snapshots
getSnapshots = do
Text
latestUrlText <- forall env (m :: * -> *).
(MonadReader env m, HasConfig env) =>
m Text
askLatestSnapshotUrl
Request
latestUrl <- forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (Text -> String
T.unpack Text
latestUrlText)
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Downloading snapshot versions file from " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
latestUrlText
Response Snapshots
result <- forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON Request
latestUrl
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Done downloading and parsing snapshot versions file"
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Response a -> a
getResponseBody Response Snapshots
result
makeConcreteResolver ::
HasConfig env
=> AbstractResolver
-> RIO env RawSnapshotLocation
makeConcreteResolver :: forall env.
HasConfig env =>
AbstractResolver -> RIO env RawSnapshotLocation
makeConcreteResolver (ARResolver RawSnapshotLocation
r) = forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshotLocation
r
makeConcreteResolver AbstractResolver
ar = do
RawSnapshotLocation
r <-
case AbstractResolver
ar of
AbstractResolver
ARGlobal -> do
Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
Path Abs Dir
implicitGlobalDir <- forall env. HasLogFunc env => Config -> RIO env (Path Abs Dir)
getImplicitGlobalProjectDir Config
config
let fp :: Path Abs File
fp = Path Abs Dir
implicitGlobalDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
stackDotYaml
IO ProjectAndConfigMonoid
iopc <- forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env a
loadConfigYaml (Path Abs Dir
-> Value -> Parser (WithJSONWarnings (IO ProjectAndConfigMonoid))
parseProjectAndConfigMonoid (forall b t. Path b t -> Path b Dir
parent Path Abs File
fp)) Path Abs File
fp
ProjectAndConfigMonoid Project
project ConfigMonoid
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ProjectAndConfigMonoid
iopc
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Project -> RawSnapshotLocation
projectResolver Project
project
AbstractResolver
ARLatestNightly -> SnapName -> RawSnapshotLocation
RSLSynonym forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> SnapName
Nightly forall b c a. (b -> c) -> (a -> b) -> a -> c
. Snapshots -> Day
snapshotsNightly forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env. HasConfig env => RIO env Snapshots
getSnapshots
ARLatestLTSMajor Int
x -> do
Snapshots
snapshots <- forall env. HasConfig env => RIO env Snapshots
getSnapshots
case forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
x forall a b. (a -> b) -> a -> b
$ Snapshots -> IntMap Int
snapshotsLts Snapshots
snapshots of
Maybe Int
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Int -> ConfigException
NoLTSWithMajorVersion Int
x
Just Int
y -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SnapName -> RawSnapshotLocation
RSLSynonym forall a b. (a -> b) -> a -> b
$ Int -> Int -> SnapName
LTS Int
x Int
y
AbstractResolver
ARLatestLTS -> do
Snapshots
snapshots <- forall env. HasConfig env => RIO env Snapshots
getSnapshots
if forall a. IntMap a -> Bool
IntMap.null forall a b. (a -> b) -> a -> b
$ Snapshots -> IntMap Int
snapshotsLts Snapshots
snapshots
then forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ConfigException
NoLTSFound
else let (Int
x, Int
y) = forall a. IntMap a -> (Int, a)
IntMap.findMax forall a b. (a -> b) -> a -> b
$ Snapshots -> IntMap Int
snapshotsLts Snapshots
snapshots
in forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SnapName -> RawSnapshotLocation
RSLSynonym forall a b. (a -> b) -> a -> b
$ Int -> Int -> SnapName
LTS Int
x Int
y
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Selected resolver: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
r
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 <- forall env. HasConfig env => RIO env Snapshots
getSnapshots
let mlts :: Maybe SnapName
mlts = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> SnapName
LTS forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
forall a. [a] -> Maybe a
listToMaybe (forall a. [a] -> [a]
reverse (forall a. IntMap a -> [(Int, a)]
IntMap.toList (Snapshots -> IntMap Int
snapshotsLts Snapshots
snapshots)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SnapName -> RawSnapshotLocation
RSLSynonym forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (Day -> SnapName
Nightly (Snapshots -> Day
snapshotsNightly Snapshots
snapshots)) Maybe SnapName
mlts
configFromConfigMonoid ::
HasRunner 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 =>
Path Abs Dir
-> Path Abs File
-> Maybe AbstractResolver
-> ProjectConfig (Project, Path Abs File)
-> ConfigMonoid
-> (Config -> RIO env a)
-> RIO env a
configFromConfigMonoid
Path Abs Dir
configStackRoot Path Abs File
configUserConfigPath Maybe AbstractResolver
configResolver
ProjectConfig (Project, Path Abs File)
configProject ConfigMonoid{[String]
[Text]
[Path Abs Dir]
Maybe AllowNewerDeps
Map Text Text
First Bool
First Int
First String
First [PackageIndexConfig]
First Text
First CasaRepoPrefix
First PackageIndexConfig
First (Path Abs File)
First (Path Abs Dir)
First (Path Rel Dir)
First CompilerBuild
First TemplateName
First VersionCheck
First CompilerRepository
First PvpBounds
First GHCVariant
First SCM
First DumpLogs
First ApplyGhcOptions
First ColorWhen
StylesUpdate
FirstFalse
FirstTrue
MonoidMap PackageName (Dual [Text])
MonoidMap ApplyGhcOptions (Dual [Text])
MonoidMap CabalConfigKey (Dual [Text])
BuildOptsMonoid
NixOptsMonoid
IntersectingVersionRange
DockerOptsMonoid
SetupInfo
configMonoidStackDeveloperMode :: ConfigMonoid -> First Bool
configMonoidNoRunCompile :: ConfigMonoid -> FirstFalse
configMonoidSnapshotLocation :: ConfigMonoid -> First Text
configMonoidCasaRepoPrefix :: ConfigMonoid -> First CasaRepoPrefix
configMonoidRecommendUpgrade :: ConfigMonoid -> FirstTrue
configMonoidHideSourcePaths :: ConfigMonoid -> FirstTrue
configMonoidStyles :: ConfigMonoid -> StylesUpdate
configMonoidColorWhen :: ConfigMonoid -> First ColorWhen
configMonoidHackageBaseUrl :: ConfigMonoid -> First Text
configMonoidSaveHackageCreds :: ConfigMonoid -> First Bool
configMonoidDumpLogs :: ConfigMonoid -> First DumpLogs
configMonoidAllowDifferentUser :: ConfigMonoid -> First Bool
configMonoidDefaultTemplate :: ConfigMonoid -> First TemplateName
configMonoidAllowNewerDeps :: ConfigMonoid -> Maybe AllowNewerDeps
configMonoidAllowNewer :: ConfigMonoid -> First Bool
configMonoidApplyGhcOptions :: ConfigMonoid -> First ApplyGhcOptions
configMonoidRebuildGhcOptions :: ConfigMonoid -> FirstFalse
configMonoidModifyCodePage :: ConfigMonoid -> FirstTrue
configMonoidPvpBounds :: ConfigMonoid -> First PvpBounds
configMonoidLocalProgramsBase :: ConfigMonoid -> First (Path Abs Dir)
configMonoidSetupInfoInline :: ConfigMonoid -> SetupInfo
configMonoidSetupInfoLocations :: ConfigMonoid -> [String]
configMonoidExtraPath :: ConfigMonoid -> [Path Abs Dir]
configMonoidCabalConfigOpts :: ConfigMonoid -> MonoidMap CabalConfigKey (Dual [Text])
configMonoidGhcOptionsByCat :: ConfigMonoid -> MonoidMap ApplyGhcOptions (Dual [Text])
configMonoidGhcOptionsByName :: ConfigMonoid -> MonoidMap PackageName (Dual [Text])
configMonoidScmInit :: ConfigMonoid -> First SCM
configMonoidTemplateParameters :: ConfigMonoid -> Map Text Text
configMonoidLocalBinPath :: ConfigMonoid -> First String
configMonoidConcurrentTests :: ConfigMonoid -> First Bool
configMonoidOverrideHpack :: ConfigMonoid -> First String
configMonoidOverrideGccPath :: ConfigMonoid -> First (Path Abs File)
configMonoidCustomPreprocessorExts :: ConfigMonoid -> [Text]
configMonoidExtraLibDirs :: ConfigMonoid -> [String]
configMonoidExtraIncludeDirs :: ConfigMonoid -> [String]
configMonoidJobs :: ConfigMonoid -> First Int
configMonoidGHCBuild :: ConfigMonoid -> First CompilerBuild
configMonoidGHCVariant :: ConfigMonoid -> First GHCVariant
configMonoidArch :: ConfigMonoid -> First String
configMonoidRequireStackVersion :: ConfigMonoid -> IntersectingVersionRange
configMonoidCompilerRepository :: ConfigMonoid -> First CompilerRepository
configMonoidCompilerCheck :: ConfigMonoid -> First VersionCheck
configMonoidSkipMsys :: ConfigMonoid -> FirstFalse
configMonoidSkipGHCCheck :: ConfigMonoid -> FirstFalse
configMonoidInstallGHC :: ConfigMonoid -> FirstTrue
configMonoidSystemGHC :: ConfigMonoid -> First Bool
configMonoidPackageIndices :: ConfigMonoid -> First [PackageIndexConfig]
configMonoidPackageIndex :: ConfigMonoid -> First PackageIndexConfig
configMonoidLatestSnapshot :: ConfigMonoid -> First Text
configMonoidPrefixTimestamps :: ConfigMonoid -> First Bool
configMonoidHideTHLoading :: ConfigMonoid -> FirstTrue
configMonoidConnectionCount :: ConfigMonoid -> First Int
configMonoidNixOpts :: ConfigMonoid -> NixOptsMonoid
configMonoidDockerOpts :: ConfigMonoid -> DockerOptsMonoid
configMonoidBuildOpts :: ConfigMonoid -> BuildOptsMonoid
configMonoidWorkDir :: ConfigMonoid -> First (Path Rel Dir)
configMonoidStackRoot :: ConfigMonoid -> First (Path Abs Dir)
configMonoidStackDeveloperMode :: First Bool
configMonoidNoRunCompile :: FirstFalse
configMonoidSnapshotLocation :: First Text
configMonoidCasaRepoPrefix :: First CasaRepoPrefix
configMonoidRecommendUpgrade :: FirstTrue
configMonoidHideSourcePaths :: FirstTrue
configMonoidStyles :: StylesUpdate
configMonoidColorWhen :: First ColorWhen
configMonoidHackageBaseUrl :: First Text
configMonoidSaveHackageCreds :: First Bool
configMonoidDumpLogs :: First DumpLogs
configMonoidAllowDifferentUser :: First Bool
configMonoidDefaultTemplate :: First TemplateName
configMonoidAllowNewerDeps :: Maybe AllowNewerDeps
configMonoidAllowNewer :: First Bool
configMonoidApplyGhcOptions :: First ApplyGhcOptions
configMonoidRebuildGhcOptions :: FirstFalse
configMonoidModifyCodePage :: FirstTrue
configMonoidPvpBounds :: First PvpBounds
configMonoidLocalProgramsBase :: First (Path Abs Dir)
configMonoidSetupInfoInline :: SetupInfo
configMonoidSetupInfoLocations :: [String]
configMonoidExtraPath :: [Path Abs Dir]
configMonoidCabalConfigOpts :: MonoidMap CabalConfigKey (Dual [Text])
configMonoidGhcOptionsByCat :: MonoidMap ApplyGhcOptions (Dual [Text])
configMonoidGhcOptionsByName :: MonoidMap PackageName (Dual [Text])
configMonoidScmInit :: First SCM
configMonoidTemplateParameters :: Map Text Text
configMonoidLocalBinPath :: First String
configMonoidConcurrentTests :: First Bool
configMonoidOverrideHpack :: First String
configMonoidOverrideGccPath :: First (Path Abs File)
configMonoidCustomPreprocessorExts :: [Text]
configMonoidExtraLibDirs :: [String]
configMonoidExtraIncludeDirs :: [String]
configMonoidJobs :: First Int
configMonoidGHCBuild :: First CompilerBuild
configMonoidGHCVariant :: First GHCVariant
configMonoidArch :: First String
configMonoidRequireStackVersion :: IntersectingVersionRange
configMonoidCompilerRepository :: First CompilerRepository
configMonoidCompilerCheck :: First VersionCheck
configMonoidSkipMsys :: FirstFalse
configMonoidSkipGHCCheck :: FirstFalse
configMonoidInstallGHC :: FirstTrue
configMonoidSystemGHC :: First Bool
configMonoidPackageIndices :: First [PackageIndexConfig]
configMonoidPackageIndex :: First PackageIndexConfig
configMonoidLatestSnapshot :: First Text
configMonoidPrefixTimestamps :: First Bool
configMonoidHideTHLoading :: FirstTrue
configMonoidConnectionCount :: First Int
configMonoidNixOpts :: NixOptsMonoid
configMonoidDockerOpts :: DockerOptsMonoid
configMonoidBuildOpts :: BuildOptsMonoid
configMonoidWorkDir :: First (Path Rel Dir)
configMonoidStackRoot :: First (Path Abs Dir)
..} Config -> RIO env a
inner = do
Maybe String
mstackWorkEnv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
stackWorkEnvVar
let mproject :: Maybe (Project, Path Abs File)
mproject =
case ProjectConfig (Project, Path Abs File)
configProject of
PCProject (Project, Path Abs File)
pair -> forall a. a -> Maybe a
Just (Project, Path Abs File)
pair
ProjectConfig (Project, Path Abs File)
PCGlobalProject -> forall a. Maybe a
Nothing
PCNoProject [PackageIdentifierRevision]
_deps -> forall a. Maybe a
Nothing
configAllowLocals :: Bool
configAllowLocals =
case ProjectConfig (Project, Path Abs File)
configProject of
PCProject (Project, Path Abs File)
_ -> Bool
True
ProjectConfig (Project, Path Abs File)
PCGlobalProject -> Bool
True
PCNoProject [PackageIdentifierRevision]
_ -> Bool
False
Path Rel Dir
configWorkDir0 <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Rel Dir
relDirStackWork) (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir) Maybe String
mstackWorkEnv
let configWorkDir :: Path Rel Dir
configWorkDir = forall a. a -> First a -> a
fromFirst Path Rel Dir
configWorkDir0 First (Path Rel Dir)
configMonoidWorkDir
configLatestSnapshot :: Text
configLatestSnapshot = forall a. a -> First a -> a
fromFirst
Text
"https://s3.amazonaws.com/haddock.stackage.org/snapshots.json"
First Text
configMonoidLatestSnapshot
clConnectionCount :: Int
clConnectionCount = forall a. a -> First a -> a
fromFirst Int
8 First Int
configMonoidConnectionCount
configHideTHLoading :: Bool
configHideTHLoading = FirstTrue -> Bool
fromFirstTrue FirstTrue
configMonoidHideTHLoading
configPrefixTimestamps :: Bool
configPrefixTimestamps = forall a. a -> First a -> a
fromFirst Bool
False First Bool
configMonoidPrefixTimestamps
configGHCVariant :: Maybe GHCVariant
configGHCVariant = forall a. First a -> Maybe a
getFirst First GHCVariant
configMonoidGHCVariant
configCompilerRepository :: CompilerRepository
configCompilerRepository = forall a. a -> First a -> a
fromFirst
CompilerRepository
defaultCompilerRepository
First CompilerRepository
configMonoidCompilerRepository
configGHCBuild :: Maybe CompilerBuild
configGHCBuild = forall a. First a -> Maybe a
getFirst First CompilerBuild
configMonoidGHCBuild
configInstallGHC :: Bool
configInstallGHC = FirstTrue -> Bool
fromFirstTrue FirstTrue
configMonoidInstallGHC
configSkipGHCCheck :: Bool
configSkipGHCCheck = FirstFalse -> Bool
fromFirstFalse FirstFalse
configMonoidSkipGHCCheck
configSkipMsys :: Bool
configSkipMsys = FirstFalse -> Bool
fromFirstFalse FirstFalse
configMonoidSkipMsys
configExtraIncludeDirs :: [String]
configExtraIncludeDirs = [String]
configMonoidExtraIncludeDirs
configExtraLibDirs :: [String]
configExtraLibDirs = [String]
configMonoidExtraLibDirs
configCustomPreprocessorExts :: [Text]
configCustomPreprocessorExts = [Text]
configMonoidCustomPreprocessorExts
configOverrideGccPath :: Maybe (Path Abs File)
configOverrideGccPath = forall a. First a -> Maybe a
getFirst First (Path Abs File)
configMonoidOverrideGccPath
(Platform Arch
defArch OS
defOS) = Platform
buildPlatform
arch :: Arch
arch = forall a. a -> Maybe a -> a
fromMaybe Arch
defArch
forall a b. (a -> b) -> a -> b
$ forall a. First a -> Maybe a
getFirst First String
configMonoidArch forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Parsec a => String -> Maybe a
Distribution.Text.simpleParse
os :: OS
os = OS
defOS
configPlatform :: Platform
configPlatform = Arch -> OS -> Platform
Platform Arch
arch OS
os
configRequireStackVersion :: VersionRange
configRequireStackVersion = VersionRange -> VersionRange
simplifyVersionRange (IntersectingVersionRange -> VersionRange
getIntersectingVersionRange IntersectingVersionRange
configMonoidRequireStackVersion)
configCompilerCheck :: VersionCheck
configCompilerCheck = forall a. a -> First a -> a
fromFirst VersionCheck
MatchMinor First VersionCheck
configMonoidCompilerCheck
case Arch
arch of
OtherArch String
"aarch64" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
OtherArch String
unk -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Warning: Unknown value for architecture setting: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow String
unk
Arch
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
PlatformVariant
configPlatformVariant <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PlatformVariant
PlatformVariantNone String -> PlatformVariant
PlatformVariant forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
platformVariantEnvVar
let configBuild :: BuildOpts
configBuild = BuildOptsMonoid -> BuildOpts
buildOptsFromMonoid BuildOptsMonoid
configMonoidBuildOpts
DockerOpts
configDocker <-
forall (m :: * -> *).
MonadThrow m =>
Maybe Project
-> Maybe AbstractResolver -> DockerOptsMonoid -> m DockerOpts
dockerOptsFromMonoid (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst Maybe (Project, Path Abs File)
mproject) Maybe AbstractResolver
configResolver DockerOptsMonoid
configMonoidDockerOpts
NixOpts
configNix <- forall env. HasRunner env => NixOptsMonoid -> OS -> RIO env NixOpts
nixOptsFromMonoid NixOptsMonoid
configMonoidNixOpts OS
os
Bool
configSystemGHC <-
case (forall a. First a -> Maybe a
getFirst First Bool
configMonoidSystemGHC, NixOpts -> Bool
nixEnable NixOpts
configNix) of
(Just Bool
False, Bool
True) ->
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ConfigException
NixRequiresSystemGhc
(Maybe Bool, Bool)
_ ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(forall a. a -> First a -> a
fromFirst
(DockerOpts -> Bool
dockerEnable DockerOpts
configDocker Bool -> Bool -> Bool
|| NixOpts -> Bool
nixEnable NixOpts
configNix)
First Bool
configMonoidSystemGHC)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe GHCVariant
configGHCVariant Bool -> Bool -> Bool
&& Bool
configSystemGHC) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ConfigException
ManualGHCVariantSettingsAreIncompatibleWithSystemGHC
[(String, String)]
rawEnv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(String, String)]
getEnvironment
Map Text Text
pathsEnv <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall (f :: * -> *) a. Applicative f => a -> f a
pure
forall a b. (a -> b) -> a -> b
$ [String]
-> Map Text Text -> Either ProcessException (Map Text Text)
augmentPathMap (forall a b. (a -> b) -> [a] -> [b]
map forall b t. Path b t -> String
toFilePath [Path Abs Dir]
configMonoidExtraPath)
(forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** String -> Text
T.pack) [(String, String)]
rawEnv))
ProcessContext
origEnv <- forall (m :: * -> *).
MonadIO m =>
Map Text Text -> m ProcessContext
mkProcessContext Map Text Text
pathsEnv
let configProcessContextSettings :: EnvSettings -> IO ProcessContext
configProcessContextSettings EnvSettings
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessContext
origEnv
Path Abs Dir
configLocalProgramsBase <- case forall a. First a -> Maybe a
getFirst First (Path Abs Dir)
configMonoidLocalProgramsBase of
Maybe (Path Abs Dir)
Nothing -> forall (m :: * -> *).
MonadThrow m =>
Path Abs Dir -> Platform -> ProcessContext -> m (Path Abs Dir)
getDefaultLocalProgramsBase Path Abs Dir
configStackRoot Platform
configPlatform ProcessContext
origEnv
Just Path Abs Dir
path -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
path
let localProgramsFilePath :: String
localProgramsFilePath = forall b t. Path b t -> String
toFilePath Path Abs Dir
configLocalProgramsBase
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
osIsWindows Bool -> Bool -> Bool
&& Char
' ' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
localProgramsFilePath) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
configLocalProgramsBase
String
shortLocalProgramsFilePath <-
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO String
getShortPathName String
localProgramsFilePath
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char
' ' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
shortLocalProgramsFilePath) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Error: [S-8432]\n"forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"Stack's 'programs' path contains a space character and has no " forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"alternative short ('8 dot 3') name. This will cause problems " forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"with packages that use the GNU project's 'configure' shell " forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"script. Use the 'local-programs-path' configuration option to " forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"specify an alternative path. The current path is: " forall a. Semigroup a => a -> a -> a
<>
forall a. Display a => a -> Utf8Builder
display (String -> Text
T.pack String
localProgramsFilePath)
Path Rel Dir
platformOnlyDir <- forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall env (m :: * -> *).
(MonadReader env m, HasPlatform env, MonadThrow m) =>
m (Path Rel Dir)
platformOnlyRelDir (Platform
configPlatform, PlatformVariant
configPlatformVariant)
let configLocalPrograms :: Path Abs Dir
configLocalPrograms = Path Abs Dir
configLocalProgramsBase forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
platformOnlyDir
Path Abs Dir
configLocalBin <-
case forall a. First a -> Maybe a
getFirst First String
configMonoidLocalBinPath of
Maybe String
Nothing -> do
Path Abs Dir
localDir <- forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
getAppUserDataDir String
"local"
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Path Abs Dir
localDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirBin
Just String
userPath ->
(case Maybe (Project, Path Abs File)
mproject of
Maybe (Project, Path Abs File)
Nothing -> forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' String
userPath
Just (Project
_, Path Abs File
configYaml) -> forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Path Abs Dir)
resolveDir (forall b t. Path b t -> Path b Dir
parent Path Abs File
configYaml) String
userPath)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny`
forall a b. a -> b -> a
const (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (String -> ConfigException
NoSuchDirectory String
userPath))
Int
configJobs <-
case forall a. First a -> Maybe a
getFirst First Int
configMonoidJobs of
Maybe Int
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumProcessors
Just Int
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
i
let configConcurrentTests :: Bool
configConcurrentTests = forall a. a -> First a -> a
fromFirst Bool
True First Bool
configMonoidConcurrentTests
let configTemplateParams :: Map Text Text
configTemplateParams = Map Text Text
configMonoidTemplateParameters
configScmInit :: Maybe SCM
configScmInit = forall a. First a -> Maybe a
getFirst First SCM
configMonoidScmInit
configCabalConfigOpts :: Map CabalConfigKey [Text]
configCabalConfigOpts = coerce :: forall a b. Coercible a b => a -> b
coerce MonoidMap CabalConfigKey (Dual [Text])
configMonoidCabalConfigOpts
configGhcOptionsByName :: Map PackageName [Text]
configGhcOptionsByName = coerce :: forall a b. Coercible a b => a -> b
coerce MonoidMap PackageName (Dual [Text])
configMonoidGhcOptionsByName
configGhcOptionsByCat :: Map ApplyGhcOptions [Text]
configGhcOptionsByCat = coerce :: forall a b. Coercible a b => a -> b
coerce MonoidMap ApplyGhcOptions (Dual [Text])
configMonoidGhcOptionsByCat
configSetupInfoLocations :: [String]
configSetupInfoLocations = [String]
configMonoidSetupInfoLocations
configSetupInfoInline :: SetupInfo
configSetupInfoInline = SetupInfo
configMonoidSetupInfoInline
configPvpBounds :: PvpBounds
configPvpBounds = forall a. a -> First a -> a
fromFirst (PvpBoundsType -> Bool -> PvpBounds
PvpBounds PvpBoundsType
PvpBoundsNone Bool
False) First PvpBounds
configMonoidPvpBounds
configModifyCodePage :: Bool
configModifyCodePage = FirstTrue -> Bool
fromFirstTrue FirstTrue
configMonoidModifyCodePage
configRebuildGhcOptions :: Bool
configRebuildGhcOptions = FirstFalse -> Bool
fromFirstFalse FirstFalse
configMonoidRebuildGhcOptions
configApplyGhcOptions :: ApplyGhcOptions
configApplyGhcOptions = forall a. a -> First a -> a
fromFirst ApplyGhcOptions
AGOLocals First ApplyGhcOptions
configMonoidApplyGhcOptions
configAllowNewer :: Bool
configAllowNewer = forall a. a -> First a -> a
fromFirst Bool
False First Bool
configMonoidAllowNewer
configAllowNewerDeps :: Maybe [PackageName]
configAllowNewerDeps = coerce :: forall a b. Coercible a b => a -> b
coerce Maybe AllowNewerDeps
configMonoidAllowNewerDeps
configDefaultTemplate :: Maybe TemplateName
configDefaultTemplate = forall a. First a -> Maybe a
getFirst First TemplateName
configMonoidDefaultTemplate
configDumpLogs :: DumpLogs
configDumpLogs = forall a. a -> First a -> a
fromFirst DumpLogs
DumpWarningLogs First DumpLogs
configMonoidDumpLogs
configSaveHackageCreds :: Bool
configSaveHackageCreds = forall a. a -> First a -> a
fromFirst Bool
True First Bool
configMonoidSaveHackageCreds
configHackageBaseUrl :: Text
configHackageBaseUrl = forall a. a -> First a -> a
fromFirst Text
"https://hackage.haskell.org/" First Text
configMonoidHackageBaseUrl
configHideSourcePaths :: Bool
configHideSourcePaths = FirstTrue -> Bool
fromFirstTrue FirstTrue
configMonoidHideSourcePaths
configRecommendUpgrade :: Bool
configRecommendUpgrade = FirstTrue -> Bool
fromFirstTrue FirstTrue
configMonoidRecommendUpgrade
configNoRunCompile :: Bool
configNoRunCompile = FirstFalse -> Bool
fromFirstFalse FirstFalse
configMonoidNoRunCompile
Bool
configAllowDifferentUser <-
case forall a. First a -> Maybe a
getFirst First Bool
configMonoidAllowDifferentUser of
Just Bool
True -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
Maybe Bool
_ -> forall (m :: * -> *). MonadIO m => m Bool
getInContainer
Runner
configRunner' <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasRunner env => Lens' env Runner
runnerL
Bool
useAnsi <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Bool
True forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Handle -> IO (Maybe Bool)
hSupportsANSIWithoutEmulation Handle
stderr
let stylesUpdate' :: StylesUpdate
stylesUpdate' = (Runner
configRunner' forall s a. s -> Getting a s a -> a
^. forall env. HasStylesUpdate env => Lens' env StylesUpdate
stylesUpdateL) forall a. Semigroup a => a -> a -> a
<>
StylesUpdate
configMonoidStyles
useColor' :: Bool
useColor' = Runner -> Bool
runnerUseColor Runner
configRunner'
mUseColor :: Maybe Bool
mUseColor = do
ColorWhen
colorWhen <- forall a. First a -> Maybe a
getFirst First ColorWhen
configMonoidColorWhen
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case ColorWhen
colorWhen of
ColorWhen
ColorNever -> Bool
False
ColorWhen
ColorAlways -> Bool
True
ColorWhen
ColorAuto -> Bool
useAnsi
useColor'' :: Bool
useColor'' = forall a. a -> Maybe a -> a
fromMaybe Bool
useColor' Maybe Bool
mUseColor
configRunner'' :: Runner
configRunner'' = Runner
configRunner'
forall a b. a -> (a -> b) -> b
& forall env. HasProcessContext env => Lens' env ProcessContext
processContextL forall s t a b. ASetter s t a b -> b -> s -> t
.~ ProcessContext
origEnv
forall a b. a -> (a -> b) -> b
& forall env. HasStylesUpdate env => Lens' env StylesUpdate
stylesUpdateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ StylesUpdate
stylesUpdate'
forall a b. a -> (a -> b) -> b
& forall env. HasTerm env => Lens' env Bool
useColorL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
useColor''
go :: GlobalOpts
go = Runner -> GlobalOpts
runnerGlobalOpts Runner
configRunner'
PackageIndexConfig
pic <-
case forall a. First a -> Maybe a
getFirst First PackageIndexConfig
configMonoidPackageIndex of
Maybe PackageIndexConfig
Nothing ->
case forall a. First a -> Maybe a
getFirst First [PackageIndexConfig]
configMonoidPackageIndices of
Maybe [PackageIndexConfig]
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIndexConfig
defaultPackageIndexConfig
Just [PackageIndexConfig
pic] -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString String
packageIndicesWarning
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIndexConfig
pic
Just [PackageIndexConfig]
x -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ [PackageIndexConfig] -> ConfigException
MultiplePackageIndices [PackageIndexConfig]
x
Just PackageIndexConfig
pic -> forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIndexConfig
pic
Maybe String
mpantryRoot <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
pantryRootEnvVar
Path Abs Dir
pantryRoot <-
case Maybe String
mpantryRoot of
Just String
dir ->
case forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir String
dir of
Maybe (Path Abs Dir)
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ String -> String -> ParseAbsolutePathException
ParseAbsolutePathException String
pantryRootEnvVar String
dir
Just Path Abs Dir
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
x
Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Path Abs Dir
configStackRoot forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirPantry
let snapLoc :: SnapName -> RawSnapshotLocation
snapLoc =
case forall a. First a -> Maybe a
getFirst First Text
configMonoidSnapshotLocation of
Maybe Text
Nothing -> SnapName -> RawSnapshotLocation
defaultSnapshotLocation
Just Text
addr -> SnapName -> RawSnapshotLocation
customSnapshotLocation
where
customSnapshotLocation :: SnapName -> RawSnapshotLocation
customSnapshotLocation (LTS Int
x Int
y) =
Utf8Builder -> RawSnapshotLocation
mkRSLUrl forall a b. (a -> b) -> a -> b
$ Utf8Builder
addr'
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/lts/" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
x
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
y forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".yaml"
customSnapshotLocation (Nightly Day
date) =
let (Year
year, Int
month, Int
day) = Day -> (Year, Int, Int)
toGregorian Day
date
in Utf8Builder -> RawSnapshotLocation
mkRSLUrl forall a b. (a -> b) -> a -> b
$ Utf8Builder
addr'
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/nightly/"
forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Year
year
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
month
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
day forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".yaml"
mkRSLUrl :: Utf8Builder -> RawSnapshotLocation
mkRSLUrl Utf8Builder
builder = Text -> Maybe BlobKey -> RawSnapshotLocation
RSLUrl (Utf8Builder -> Text
utf8BuilderToText Utf8Builder
builder) forall a. Maybe a
Nothing
addr' :: Utf8Builder
addr' = forall a. Display a => a -> Utf8Builder
display forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhileEnd (forall a. Eq a => a -> a -> Bool
==Char
'/') Text
addr
let configStackDeveloperMode :: Bool
configStackDeveloperMode = forall a. a -> First a -> a
fromFirst Bool
stackDeveloperModeDefault First Bool
configMonoidStackDeveloperMode
forall (m :: * -> *) a.
MonadUnliftIO m =>
GlobalOpts -> Bool -> StylesUpdate -> (LogFunc -> m a) -> m a
withNewLogFunc GlobalOpts
go Bool
useColor'' StylesUpdate
stylesUpdate' forall a b. (a -> b) -> a -> b
$ \LogFunc
logFunc -> do
let configRunner :: Runner
configRunner = Runner
configRunner'' forall a b. a -> (a -> b) -> b
& forall env. HasLogFunc env => Lens' env LogFunc
logFuncL forall s t a b. ASetter s t a b -> b -> s -> t
.~ LogFunc
logFunc
forall env a. HasLogFunc env => LogFunc -> RIO env a -> RIO env a
withLocalLogFunc LogFunc
logFunc forall a b. (a -> b) -> a -> b
$ forall env a. HasLogFunc env => RIO env a -> RIO env a
handleMigrationException forall a b. (a -> b) -> a -> b
$
forall env a.
HasLogFunc env =>
Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Int
-> CasaRepoPrefix
-> Int
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig
Path Abs Dir
pantryRoot
PackageIndexConfig
pic
(forall b a. b -> (a -> b) -> Maybe a -> b
maybe HpackExecutable
HpackBundled String -> HpackExecutable
HpackCommand forall a b. (a -> b) -> a -> b
$ forall a. First a -> Maybe a
getFirst First String
configMonoidOverrideHpack)
Int
clConnectionCount
(forall a. a -> First a -> a
fromFirst CasaRepoPrefix
defaultCasaRepoPrefix First CasaRepoPrefix
configMonoidCasaRepoPrefix)
Int
defaultCasaMaxPerRequest
SnapName -> RawSnapshotLocation
snapLoc
(\PantryConfig
configPantryConfig -> forall env a.
HasLogFunc env =>
Path Abs File -> (UserStorage -> RIO env a) -> RIO env a
initUserStorage
(Path Abs Dir
configStackRoot forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileStorage)
(\UserStorage
configUserStorage -> Config -> RIO env a
inner Config {Bool
Int
[String]
[Text]
Maybe [PackageName]
Maybe (Path Abs File)
Maybe CompilerBuild
Maybe AbstractResolver
Maybe TemplateName
Maybe GHCVariant
Maybe SCM
Platform
VersionRange
Map PackageName [Text]
Map Text Text
Map ApplyGhcOptions [Text]
Map CabalConfigKey [Text]
Text
PantryConfig
Path Abs File
Path Abs Dir
Path Rel Dir
BuildOpts
NixOpts
VersionCheck
DockerOpts
CompilerRepository
PvpBounds
SetupInfo
PlatformVariant
ProjectConfig (Project, Path Abs File)
DumpLogs
ApplyGhcOptions
UserStorage
Runner
EnvSettings -> IO ProcessContext
configStackDeveloperMode :: Bool
configNoRunCompile :: Bool
configRecommendUpgrade :: Bool
configHideSourcePaths :: Bool
configUserStorage :: UserStorage
configResolver :: Maybe AbstractResolver
configStackRoot :: Path Abs Dir
configPantryConfig :: PantryConfig
configRunner :: Runner
configHackageBaseUrl :: Text
configSaveHackageCreds :: Bool
configAllowLocals :: Bool
configProject :: ProjectConfig (Project, Path Abs File)
configDumpLogs :: DumpLogs
configAllowDifferentUser :: Bool
configDefaultTemplate :: Maybe TemplateName
configAllowNewerDeps :: Maybe [PackageName]
configAllowNewer :: Bool
configApplyGhcOptions :: ApplyGhcOptions
configRebuildGhcOptions :: Bool
configModifyCodePage :: Bool
configPvpBounds :: PvpBounds
configSetupInfoInline :: SetupInfo
configSetupInfoLocations :: [String]
configCabalConfigOpts :: Map CabalConfigKey [Text]
configGhcOptionsByCat :: Map ApplyGhcOptions [Text]
configGhcOptionsByName :: Map PackageName [Text]
configScmInit :: Maybe SCM
configTemplateParams :: Map Text Text
configConcurrentTests :: Bool
configCustomPreprocessorExts :: [Text]
configExtraLibDirs :: [String]
configExtraIncludeDirs :: [String]
configOverrideGccPath :: Maybe (Path Abs File)
configJobs :: Int
configRequireStackVersion :: VersionRange
configLocalBin :: Path Abs Dir
configCompilerRepository :: CompilerRepository
configCompilerCheck :: VersionCheck
configSkipMsys :: Bool
configSkipGHCCheck :: Bool
configInstallGHC :: Bool
configSystemGHC :: Bool
configLatestSnapshot :: Text
configGHCBuild :: Maybe CompilerBuild
configGHCVariant :: Maybe GHCVariant
configPlatformVariant :: PlatformVariant
configPlatform :: Platform
configPrefixTimestamps :: Bool
configHideTHLoading :: Bool
configLocalPrograms :: Path Abs Dir
configLocalProgramsBase :: Path Abs Dir
configProcessContextSettings :: EnvSettings -> IO ProcessContext
configNix :: NixOpts
configDocker :: DockerOpts
configBuild :: BuildOpts
configUserConfigPath :: Path Abs File
configWorkDir :: Path Rel Dir
configUserStorage :: UserStorage
configPantryConfig :: PantryConfig
configRunner :: Runner
configStackDeveloperMode :: Bool
configAllowDifferentUser :: Bool
configNoRunCompile :: Bool
configRecommendUpgrade :: Bool
configHideSourcePaths :: Bool
configHackageBaseUrl :: Text
configSaveHackageCreds :: Bool
configDumpLogs :: DumpLogs
configDefaultTemplate :: Maybe TemplateName
configAllowNewerDeps :: Maybe [PackageName]
configAllowNewer :: Bool
configApplyGhcOptions :: ApplyGhcOptions
configRebuildGhcOptions :: Bool
configModifyCodePage :: Bool
configPvpBounds :: PvpBounds
configSetupInfoInline :: SetupInfo
configSetupInfoLocations :: [String]
configGhcOptionsByCat :: Map ApplyGhcOptions [Text]
configGhcOptionsByName :: Map PackageName [Text]
configCabalConfigOpts :: Map CabalConfigKey [Text]
configScmInit :: Maybe SCM
configTemplateParams :: Map Text Text
configConcurrentTests :: Bool
configJobs :: Int
configLocalBin :: Path Abs Dir
configLocalPrograms :: Path Abs Dir
configLocalProgramsBase :: Path Abs Dir
configProcessContextSettings :: EnvSettings -> IO ProcessContext
configSystemGHC :: Bool
configNix :: NixOpts
configDocker :: DockerOpts
configBuild :: BuildOpts
configPlatformVariant :: PlatformVariant
configCompilerCheck :: VersionCheck
configRequireStackVersion :: VersionRange
configPlatform :: Platform
configOverrideGccPath :: Maybe (Path Abs File)
configCustomPreprocessorExts :: [Text]
configExtraLibDirs :: [String]
configExtraIncludeDirs :: [String]
configSkipMsys :: Bool
configSkipGHCCheck :: Bool
configInstallGHC :: Bool
configGHCBuild :: Maybe CompilerBuild
configCompilerRepository :: CompilerRepository
configGHCVariant :: Maybe GHCVariant
configPrefixTimestamps :: Bool
configHideTHLoading :: Bool
configLatestSnapshot :: Text
configWorkDir :: Path Rel Dir
configAllowLocals :: Bool
configProject :: ProjectConfig (Project, Path Abs File)
configResolver :: Maybe AbstractResolver
configUserConfigPath :: Path Abs File
configStackRoot :: Path Abs Dir
..}))
withLocalLogFunc :: HasLogFunc env => LogFunc -> RIO env a -> RIO env a
withLocalLogFunc :: forall env a. HasLogFunc env => LogFunc -> RIO env a -> RIO env a
withLocalLogFunc LogFunc
logFunc = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (forall s t a b. ASetter s t a b -> b -> s -> t
set forall env. HasLogFunc env => Lens' env LogFunc
logFuncL LogFunc
logFunc)
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 <- forall (m :: * -> *). MonadIO m => Handle -> Bool -> m LogOptions
logOptionsHandle Handle
stderr Bool
False
let logOptions :: LogOptions
logOptions
= Bool -> LogOptions -> LogOptions
setLogUseColor Bool
useColor
forall a b. (a -> b) -> a -> b
$ (LogLevel -> Utf8Builder) -> LogOptions -> LogOptions
setLogLevelColors LogLevel -> Utf8Builder
logLevelColors
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> LogOptions -> LogOptions
setLogSecondaryColor Utf8Builder
secondaryColor
forall a b. (a -> b) -> a -> b
$ (Int -> Utf8Builder) -> LogOptions -> LogOptions
setLogAccentColors (forall a b. a -> b -> a
const Utf8Builder
highlightColor)
forall a b. (a -> b) -> a -> b
$ Bool -> LogOptions -> LogOptions
setLogUseTime (GlobalOpts -> Bool
globalTimeInLog GlobalOpts
go)
forall a b. (a -> b) -> a -> b
$ LogLevel -> LogOptions -> LogOptions
setLogMinLevel (GlobalOpts -> LogLevel
globalLogLevel GlobalOpts
go)
forall a b. (a -> b) -> a -> b
$ Bool -> LogOptions -> LogOptions
setLogVerboseFormat (GlobalOpts -> LogLevel
globalLogLevel GlobalOpts
go forall a. Ord a => a -> a -> Bool
<= LogLevel
LevelDebug)
forall a b. (a -> b) -> a -> b
$ Bool -> LogOptions -> LogOptions
setLogTerminal (GlobalOpts -> Bool
globalTerminal GlobalOpts
go)
LogOptions
logOptions0
forall (m :: * -> *) a.
MonadUnliftIO m =>
LogOptions -> (LogFunc -> m a) -> m a
withLogFunc LogOptions
logOptions LogFunc -> m a
inner
where
styles :: Array Style StyleSpec
styles = Array Style StyleSpec
defaultStyles forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)] -> a i e
// [(Style, StyleSpec)]
update
logLevelColors :: LogLevel -> Utf8Builder
logLevelColors :: LogLevel -> Utf8Builder
logLevelColors LogLevel
level =
forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Array Style StyleSpec
styles forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! LogLevel -> Style
logLevelToStyle LogLevel
level
secondaryColor :: Utf8Builder
secondaryColor = forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Array Style StyleSpec
styles forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Style
Secondary
highlightColor :: Utf8Builder
highlightColor = forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Array Style StyleSpec
styles forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Style
Highlight
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 = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env.
HasProcessContext env =>
SimpleGetter env (Map Text Text)
envVarsL ProcessContext
override
case Text -> String
T.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"LOCALAPPDATA" Map Text Text
envVars of
Just String
t -> case forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir String
t of
Maybe (Path Abs Dir)
Nothing ->
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> String -> ParseAbsolutePathException
ParseAbsolutePathException String
"LOCALAPPDATA" String
t
Just Path Abs Dir
lad ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Path Abs Dir
lad forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirUpperPrograms forall b t. Path b Dir -> Path Rel t -> Path b t
</>
Path Rel Dir
relDirStackProgName
Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
defaultBase
Platform
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
defaultBase
where
defaultBase :: Path Abs Dir
defaultBase = Path Abs Dir
configStackRoot forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirPrograms
loadConfig :: HasRunner env => (Config -> RIO env a) -> RIO env a
loadConfig :: forall env a. HasRunner env => (Config -> RIO env a) -> RIO env a
loadConfig Config -> RIO env a
inner = do
StackYamlLoc
mstackYaml <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasRunner env => Lens' env GlobalOpts
globalOptsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to GlobalOpts -> StackYamlLoc
globalStackYaml
ProjectConfig (Project, Path Abs File, ConfigMonoid)
mproject <- forall env.
HasLogFunc env =>
StackYamlLoc
-> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid))
loadProjectConfig StackYamlLoc
mstackYaml
Maybe AbstractResolver
mresolver <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasRunner env => Lens' env GlobalOpts
globalOptsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to GlobalOpts -> Maybe AbstractResolver
globalResolver
ConfigMonoid
configArgs <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasRunner env => Lens' env GlobalOpts
globalOptsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to GlobalOpts -> ConfigMonoid
globalConfigMonoid
(Path Abs Dir
configRoot, Path Abs Dir
stackRoot, Bool
userOwnsStackRoot) <- forall (m :: * -> *).
MonadIO m =>
ConfigMonoid -> m (Path Abs Dir, Path Abs Dir, Bool)
determineStackRootAndOwnership ConfigMonoid
configArgs
let (ProjectConfig (Project, Path Abs File)
mproject', [ConfigMonoid] -> [ConfigMonoid]
addConfigMonoid) =
case ProjectConfig (Project, Path Abs File, ConfigMonoid)
mproject of
PCProject (Project
proj, Path Abs File
fp, ConfigMonoid
cm) -> (forall a. a -> ProjectConfig a
PCProject (Project
proj, Path Abs File
fp), (ConfigMonoid
cmforall a. a -> [a] -> [a]
:))
ProjectConfig (Project, Path Abs File, ConfigMonoid)
PCGlobalProject -> (forall a. ProjectConfig a
PCGlobalProject, forall a. a -> a
id)
PCNoProject [PackageIdentifierRevision]
deps -> (forall a. [PackageIdentifierRevision] -> ProjectConfig a
PCNoProject [PackageIdentifierRevision]
deps, forall a. a -> a
id)
Path Abs File
userConfigPath <- forall env.
HasLogFunc env =>
Path Abs Dir -> RIO env (Path Abs File)
getDefaultUserConfigPath Path Abs Dir
configRoot
[ConfigMonoid]
extraConfigs0 <- forall env.
HasLogFunc env =>
Path Abs File -> RIO env [Path Abs File]
getExtraConfigs Path Abs File
userConfigPath forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Path Abs File
file -> forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env a
loadConfigYaml (Path Abs Dir -> Value -> Parser (WithJSONWarnings ConfigMonoid)
parseConfigMonoid (forall b t. Path b t -> Path b Dir
parent Path Abs File
file)) Path Abs File
file)
let extraConfigs :: [ConfigMonoid]
extraConfigs =
forall a b. (a -> b) -> [a] -> [b]
map (\ConfigMonoid
c -> ConfigMonoid
c {configMonoidDockerOpts :: DockerOptsMonoid
configMonoidDockerOpts =
(ConfigMonoid -> DockerOptsMonoid
configMonoidDockerOpts ConfigMonoid
c) {dockerMonoidDefaultEnable :: Any
dockerMonoidDefaultEnable = Bool -> Any
Any Bool
False}})
[ConfigMonoid]
extraConfigs0
let withConfig :: (Config -> RIO env a) -> RIO env a
withConfig =
forall env a.
HasRunner env =>
Path Abs Dir
-> Path Abs File
-> Maybe AbstractResolver
-> ProjectConfig (Project, Path Abs File)
-> ConfigMonoid
-> (Config -> RIO env a)
-> RIO env a
configFromConfigMonoid
Path Abs Dir
stackRoot
Path Abs File
userConfigPath
Maybe AbstractResolver
mresolver
ProjectConfig (Project, Path Abs File)
mproject'
(forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ ConfigMonoid
configArgs forall a. a -> [a] -> [a]
: [ConfigMonoid] -> [ConfigMonoid]
addConfigMonoid [ConfigMonoid]
extraConfigs)
(Config -> RIO env a) -> RIO env a
withConfig forall a b. (a -> b) -> a -> b
$ \Config
config -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Version
stackVersion Version -> VersionRange -> Bool
`withinRange` Config -> VersionRange
configRequireStackVersion Config
config)
(forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (VersionRange -> ConfigException
BadStackVersionException (Config -> VersionRange
configRequireStackVersion Config
config)))
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Config -> Bool
configAllowDifferentUser Config
config) forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
userOwnsStackRoot forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Path Abs Dir -> ConfigException
UserDoesn'tOwnDirectory Path Abs Dir
stackRoot)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Config -> Maybe (Path Abs Dir)
configProjectRoot Config
config) forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir ->
forall (m :: * -> *). MonadIO m => Path Abs Dir -> m ()
checkOwnership (Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Config -> Path Rel Dir
configWorkDir Config
config)
Config -> RIO env a
inner Config
config
withBuildConfig ::
RIO BuildConfig a
-> RIO Config a
withBuildConfig :: forall a. RIO BuildConfig a -> RIO Config a
withBuildConfig RIO BuildConfig a
inner = do
Config
config <- forall r (m :: * -> *). MonadReader r m => m r
ask
Maybe RawSnapshotLocation
mresolver <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Config -> Maybe AbstractResolver
configResolver Config
config) forall a b. (a -> b) -> a -> b
$ \AbstractResolver
aresolver -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Using resolver: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display AbstractResolver
aresolver forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" specified on command line")
forall env.
HasConfig env =>
AbstractResolver -> RIO env RawSnapshotLocation
makeConcreteResolver AbstractResolver
aresolver
(Project
project', Path Abs File
stackYamlFP) <- case Config -> ProjectConfig (Project, Path Abs File)
configProject Config
config of
PCProject (Project
project, Path Abs File
fp) -> do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Project -> Maybe String
projectUserMsg Project
project) (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Project
project, Path Abs File
fp)
PCNoProject [PackageIdentifierRevision]
extraDeps -> do
Project
p <-
case Maybe RawSnapshotLocation
mresolver of
Maybe RawSnapshotLocation
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ConfigException
NoResolverWhenUsingNoProject
Just RawSnapshotLocation
_ -> Maybe RawSnapshotLocation
-> [PackageIdentifierRevision] -> RIO Config Project
getEmptyProject Maybe RawSnapshotLocation
mresolver [PackageIdentifierRevision]
extraDeps
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Project
p, Config -> Path Abs File
configUserConfigPath Config
config)
ProjectConfig (Project, Path Abs File)
PCGlobalProject -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Run from outside a project, using implicit global project config"
Path Abs Dir
destDir <- forall env. HasLogFunc env => Config -> RIO env (Path Abs Dir)
getImplicitGlobalProjectDir Config
config
let dest :: Path Abs File
dest :: Path Abs File
dest = Path Abs Dir
destDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
stackDotYaml
dest' :: FilePath
dest' :: String
dest' = forall b t. Path b t -> String
toFilePath Path Abs File
dest
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
destDir
Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
dest
if Bool
exists
then do
IO ProjectAndConfigMonoid
iopc <- forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env a
loadConfigYaml (Path Abs Dir
-> Value -> Parser (WithJSONWarnings (IO ProjectAndConfigMonoid))
parseProjectAndConfigMonoid Path Abs Dir
destDir) Path Abs File
dest
ProjectAndConfigMonoid Project
project ConfigMonoid
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ProjectAndConfigMonoid
iopc
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasRunner env => Lens' env Bool
terminalL Config
config) forall a b. (a -> b) -> a -> b
$
case Config -> Maybe AbstractResolver
configResolver Config
config of
Maybe AbstractResolver
Nothing ->
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Using resolver: " forall a. Semigroup a => a -> a -> a
<>
forall a. Display a => a -> Utf8Builder
display (Project -> RawSnapshotLocation
projectResolver Project
project) forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
" from implicit global project's config file: " forall a. Semigroup a => a -> a -> a
<>
forall a. IsString a => String -> a
fromString String
dest'
Just AbstractResolver
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Project
project, Path Abs File
dest)
else do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder
"Writing implicit global project config file to: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString String
dest')
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Note: You can change the snapshot via the resolver field there."
Project
p <- Maybe RawSnapshotLocation
-> [PackageIdentifierRevision] -> RIO Config Project
getEmptyProject Maybe RawSnapshotLocation
mresolver []
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
dest forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S.concat
[ ByteString
"# This is the implicit global project's config file, which is only used when\n"
, ByteString
"# 'stack' is run outside of a real project. Settings here do _not_ act as\n"
, ByteString
"# defaults for all projects. To change Stack's default settings, edit\n"
, ByteString
"# '", Text -> ByteString
encodeUtf8 (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> String
toFilePath forall a b. (a -> b) -> a -> b
$ Config -> Path Abs File
configUserConfigPath Config
config), ByteString
"' instead.\n"
, ByteString
"#\n"
, ByteString
"# For more information about Stack's configuration, see\n"
, ByteString
"# http://docs.haskellstack.org/en/stable/yaml_configuration/\n"
, ByteString
"#\n"
, forall a. ToJSON a => a -> ByteString
Yaml.encode Project
p]
forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic (forall b t. Path b t -> Path b Dir
parent Path Abs File
dest forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileReadmeTxt) forall a b. (a -> b) -> a -> b
$
Builder
"This is the implicit global project, which is " forall a. Semigroup a => a -> a -> a
<>
Builder
"used only when 'stack' is run\noutside of a " forall a. Semigroup a => a -> a -> a
<>
Builder
"real project.\n"
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Project
p, Path Abs File
dest)
Maybe WantedCompiler
mcompiler <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasRunner env => Lens' env GlobalOpts
globalOptsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to GlobalOpts -> Maybe WantedCompiler
globalCompiler
let project :: Project
project = Project
project'
{ projectCompiler :: Maybe WantedCompiler
projectCompiler = Maybe WantedCompiler
mcompiler forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Project -> Maybe WantedCompiler
projectCompiler Project
project'
, projectResolver :: RawSnapshotLocation
projectResolver = forall a. a -> Maybe a -> a
fromMaybe (Project -> RawSnapshotLocation
projectResolver Project
project') Maybe RawSnapshotLocation
mresolver
}
[Path Abs Dir]
extraPackageDBs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' (Project -> [String]
projectExtraPackageDBs Project
project)
SMWanted
wanted <- forall env.
(HasPantryConfig env, HasRunner env) =>
Path Abs File
-> RawSnapshotLocation
-> (Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO env DepPackage)
-> RIO env (SMWanted, [CompletedPLI]))
-> RIO env SMWanted
lockCachedWanted Path Abs File
stackYamlFP (Project -> RawSnapshotLocation
projectResolver Project
project) forall a b. (a -> b) -> a -> b
$
forall env t.
(HasProcessContext env, HasLogFunc env, HasPantryConfig env) =>
Path Abs t
-> Config
-> Project
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO env DepPackage)
-> RIO env (SMWanted, [CompletedPLI])
fillProjectWanted Path Abs File
stackYamlFP Config
config Project
project
Path Rel Dir
workDir <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env (Path Rel Dir)
workDirL
let projectStorageFile :: Path Abs File
projectStorageFile = forall b t. Path b t -> Path b Dir
parent Path Abs File
stackYamlFP forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
workDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileStorage
forall env a.
HasLogFunc env =>
Path Abs File -> (ProjectStorage -> RIO env a) -> RIO env a
initProjectStorage Path Abs File
projectStorageFile forall a b. (a -> b) -> a -> b
$ \ProjectStorage
projectStorage -> do
let bc :: BuildConfig
bc = BuildConfig
{ bcConfig :: Config
bcConfig = Config
config
, bcSMWanted :: SMWanted
bcSMWanted = SMWanted
wanted
, bcExtraPackageDBs :: [Path Abs Dir]
bcExtraPackageDBs = [Path Abs Dir]
extraPackageDBs
, bcStackYaml :: Path Abs File
bcStackYaml = Path Abs File
stackYamlFP
, bcCurator :: Maybe Curator
bcCurator = Project -> Maybe Curator
projectCurator Project
project
, bcProjectStorage :: ProjectStorage
bcProjectStorage = ProjectStorage
projectStorage
}
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO BuildConfig
bc RIO BuildConfig a
inner
where
getEmptyProject :: Maybe RawSnapshotLocation -> [PackageIdentifierRevision] -> RIO Config Project
getEmptyProject :: Maybe RawSnapshotLocation
-> [PackageIdentifierRevision] -> RIO Config Project
getEmptyProject Maybe RawSnapshotLocation
mresolver [PackageIdentifierRevision]
extraDeps = do
RawSnapshotLocation
r <- case Maybe RawSnapshotLocation
mresolver of
Just RawSnapshotLocation
resolver -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder
"Using resolver: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
resolver forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" specified on command line")
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshotLocation
resolver
Maybe RawSnapshotLocation
Nothing -> do
RawSnapshotLocation
r'' <- forall env. HasConfig env => RIO env RawSnapshotLocation
getLatestResolver
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder
"Using latest snapshot resolver: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
r'')
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshotLocation
r''
forall (f :: * -> *) a. Applicative f => a -> f a
pure Project
{ projectUserMsg :: Maybe String
projectUserMsg = forall a. Maybe a
Nothing
, projectPackages :: [RelFilePath]
projectPackages = []
, projectDependencies :: [RawPackageLocation]
projectDependencies = forall a b. (a -> b) -> [a] -> [b]
map (RawPackageLocationImmutable -> RawPackageLocation
RPLImmutable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip PackageIdentifierRevision
-> Maybe TreeKey -> RawPackageLocationImmutable
RPLIHackage forall a. Maybe a
Nothing) [PackageIdentifierRevision]
extraDeps
, projectFlags :: Map PackageName (Map FlagName Bool)
projectFlags = forall a. Monoid a => a
mempty
, projectResolver :: RawSnapshotLocation
projectResolver = RawSnapshotLocation
r
, projectCompiler :: Maybe WantedCompiler
projectCompiler = forall a. Maybe a
Nothing
, projectExtraPackageDBs :: [String]
projectExtraPackageDBs = []
, projectCurator :: Maybe Curator
projectCurator = forall a. Maybe a
Nothing
, projectDropPackages :: Set PackageName
projectDropPackages = forall a. Monoid a => a
mempty
}
fillProjectWanted ::
(HasProcessContext env, HasLogFunc env, HasPantryConfig env)
=> Path Abs t
-> Config
-> Project
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO env DepPackage)
-> RIO env (SMWanted, [CompletedPLI])
fillProjectWanted :: forall env t.
(HasProcessContext env, HasLogFunc env, HasPantryConfig env) =>
Path Abs t
-> Config
-> Project
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO env DepPackage)
-> RIO env (SMWanted, [CompletedPLI])
fillProjectWanted Path Abs t
stackYamlFP Config
config Project
project Map RawPackageLocationImmutable PackageLocationImmutable
locCache WantedCompiler
snapCompiler Map PackageName (Bool -> RIO env DepPackage)
snapPackages = do
let bopts :: BuildOpts
bopts = Config -> BuildOpts
configBuild Config
config
[(PackageName, ProjectPackage)]
packages0 <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Project -> [RelFilePath]
projectPackages Project
project) forall a b. (a -> b) -> a -> b
$ \fp :: RelFilePath
fp@(RelFilePath Text
t) -> do
Path Abs Dir
abs' <- forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Path Abs Dir)
resolveDir (forall b t. Path b t -> Path b Dir
parent Path Abs t
stackYamlFP) (Text -> String
T.unpack Text
t)
let resolved :: ResolvedPath Dir
resolved = forall t. RelFilePath -> Path Abs t -> ResolvedPath t
ResolvedPath RelFilePath
fp Path Abs Dir
abs'
ProjectPackage
pp <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PrintWarnings -> ResolvedPath Dir -> Bool -> RIO env ProjectPackage
mkProjectPackage PrintWarnings
YesPrintWarnings ResolvedPath Dir
resolved (BuildOpts -> Bool
boptsHaddock BuildOpts
bopts)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommonPackage -> PackageName
cpName forall a b. (a -> b) -> a -> b
$ ProjectPackage -> CommonPackage
ppCommon ProjectPackage
pp, ProjectPackage
pp)
let gitRepos :: [(Repo, RawPackageMetadata)]
gitRepos = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case
(RPLImmutable (RPLIRepo Repo
repo RawPackageMetadata
rpm)) -> forall a. a -> Maybe a
Just (Repo
repo, RawPackageMetadata
rpm)
RawPackageLocation
_ -> forall a. Maybe a
Nothing) (Project -> [RawPackageLocation]
projectDependencies Project
project)
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Prefetching git repos: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (String -> Text
T.pack (forall a. Show a => a -> String
show [(Repo, RawPackageMetadata)]
gitRepos)))
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[(Repo, RawPackageMetadata)] -> RIO env ()
fetchReposRaw [(Repo, RawPackageMetadata)]
gitRepos
([(PackageName, DepPackage)]
deps0, [Maybe CompletedPLI]
mcompleted) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Project -> [RawPackageLocation]
projectDependencies Project
project) forall a b. (a -> b) -> a -> b
$ \RawPackageLocation
rpl -> do
(PackageLocation
pl, Maybe CompletedPLI
mCompleted) <- case RawPackageLocation
rpl of
RPLImmutable RawPackageLocationImmutable
rpli -> do
(PackageLocationImmutable
compl, Maybe PackageLocationImmutable
mcompl) <-
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RawPackageLocationImmutable
rpli Map RawPackageLocationImmutable PackageLocationImmutable
locCache of
Just PackageLocationImmutable
compl -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageLocationImmutable
compl, forall a. a -> Maybe a
Just PackageLocationImmutable
compl)
Maybe PackageLocationImmutable
Nothing -> do
CompletePackageLocation
cpl <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env CompletePackageLocation
completePackageLocation RawPackageLocationImmutable
rpli
if CompletePackageLocation -> Bool
cplHasCabalFile CompletePackageLocation
cpl
then forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompletePackageLocation -> PackageLocationImmutable
cplComplete CompletePackageLocation
cpl, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ CompletePackageLocation -> PackageLocationImmutable
cplComplete CompletePackageLocation
cpl)
else do
forall env.
HasLogFunc env =>
RawPackageLocationImmutable -> RIO env ()
warnMissingCabalFile RawPackageLocationImmutable
rpli
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompletePackageLocation -> PackageLocationImmutable
cplComplete CompletePackageLocation
cpl, forall a. Maybe a
Nothing)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageLocationImmutable -> PackageLocation
PLImmutable PackageLocationImmutable
compl, RawPackageLocationImmutable
-> PackageLocationImmutable -> CompletedPLI
CompletedPLI RawPackageLocationImmutable
rpli forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PackageLocationImmutable
mcompl)
RPLMutable ResolvedPath Dir
p ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResolvedPath Dir -> PackageLocation
PLMutable ResolvedPath Dir
p, forall a. Maybe a
Nothing)
DepPackage
dp <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool -> PackageLocation -> RIO env DepPackage
additionalDepPackage (BuildOpts -> Bool
shouldHaddockDeps BuildOpts
bopts) PackageLocation
pl
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((CommonPackage -> PackageName
cpName forall a b. (a -> b) -> a -> b
$ DepPackage -> CommonPackage
dpCommon DepPackage
dp, DepPackage
dp), Maybe CompletedPLI
mCompleted)
forall (m :: * -> *).
MonadThrow m =>
[(PackageName, PackageLocation)] -> m ()
checkDuplicateNames forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (ResolvedPath Dir -> PackageLocation
PLMutable forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> ResolvedPath Dir
ppResolvedDir)) [(PackageName, ProjectPackage)]
packages0 forall a. [a] -> [a] -> [a]
++
forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second DepPackage -> PackageLocation
dpLocation) [(PackageName, DepPackage)]
deps0
let packages1 :: Map PackageName ProjectPackage
packages1 = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName, ProjectPackage)]
packages0
snPackages :: Map PackageName (Bool -> RIO env DepPackage)
snPackages = Map PackageName (Bool -> RIO env DepPackage)
snapPackages
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map PackageName ProjectPackage
packages1
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName, DepPackage)]
deps0
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.withoutKeys` Project -> Set PackageName
projectDropPackages Project
project
Map PackageName DepPackage
snDeps <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Map PackageName (Bool -> RIO env DepPackage)
snPackages forall a b. (a -> b) -> a -> b
$ \Bool -> RIO env DepPackage
getDep -> Bool -> RIO env DepPackage
getDep (BuildOpts -> Bool
shouldHaddockDeps BuildOpts
bopts)
let deps1 :: Map PackageName DepPackage
deps1 = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName, DepPackage)]
deps0 forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map PackageName DepPackage
snDeps
let mergeApply :: Map k c -> Map k b -> (k -> c -> b -> c) -> Map k c
mergeApply Map k c
m1 Map k b
m2 k -> c -> b -> c
f =
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
MS.merge forall (f :: * -> *) k x. Applicative f => WhenMissing f k x x
MS.preserveMissing forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
MS.dropMissing (forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
MS.zipWithMatched k -> c -> b -> c
f) Map k c
m1 Map k b
m2
pFlags :: Map PackageName (Map FlagName Bool)
pFlags = Project -> Map PackageName (Map FlagName Bool)
projectFlags Project
project
packages2 :: Map PackageName ProjectPackage
packages2 = forall {k} {c} {b}.
Ord k =>
Map k c -> Map k b -> (k -> c -> b -> c) -> Map k c
mergeApply Map PackageName ProjectPackage
packages1 Map PackageName (Map FlagName Bool)
pFlags forall a b. (a -> b) -> a -> b
$
\PackageName
_ ProjectPackage
p Map FlagName Bool
flags -> ProjectPackage
p{ppCommon :: CommonPackage
ppCommon=(ProjectPackage -> CommonPackage
ppCommon ProjectPackage
p){cpFlags :: Map FlagName Bool
cpFlags=Map FlagName Bool
flags}}
deps2 :: Map PackageName DepPackage
deps2 = forall {k} {c} {b}.
Ord k =>
Map k c -> Map k b -> (k -> c -> b -> c) -> Map k c
mergeApply Map PackageName DepPackage
deps1 Map PackageName (Map FlagName Bool)
pFlags forall a b. (a -> b) -> a -> b
$
\PackageName
_ DepPackage
d Map FlagName Bool
flags -> DepPackage
d{dpCommon :: CommonPackage
dpCommon=(DepPackage -> CommonPackage
dpCommon DepPackage
d){cpFlags :: Map FlagName Bool
cpFlags=Map FlagName Bool
flags}}
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Map PackageName (Map FlagName Bool)
-> FlagSource
-> Map PackageName ProjectPackage
-> Map PackageName DepPackage
-> m ()
checkFlagsUsedThrowing Map PackageName (Map FlagName Bool)
pFlags FlagSource
FSStackYaml Map PackageName ProjectPackage
packages1 Map PackageName DepPackage
deps1
let pkgGhcOptions :: Map PackageName [Text]
pkgGhcOptions = Config -> Map PackageName [Text]
configGhcOptionsByName Config
config
deps :: Map PackageName DepPackage
deps = forall {k} {c} {b}.
Ord k =>
Map k c -> Map k b -> (k -> c -> b -> c) -> Map k c
mergeApply Map PackageName DepPackage
deps2 Map PackageName [Text]
pkgGhcOptions forall a b. (a -> b) -> a -> b
$
\PackageName
_ DepPackage
d [Text]
options -> DepPackage
d{dpCommon :: CommonPackage
dpCommon=(DepPackage -> CommonPackage
dpCommon DepPackage
d){cpGhcOptions :: [Text]
cpGhcOptions=[Text]
options}}
packages :: Map PackageName ProjectPackage
packages = forall {k} {c} {b}.
Ord k =>
Map k c -> Map k b -> (k -> c -> b -> c) -> Map k c
mergeApply Map PackageName ProjectPackage
packages2 Map PackageName [Text]
pkgGhcOptions forall a b. (a -> b) -> a -> b
$
\PackageName
_ ProjectPackage
p [Text]
options -> ProjectPackage
p{ppCommon :: CommonPackage
ppCommon=(ProjectPackage -> CommonPackage
ppCommon ProjectPackage
p){cpGhcOptions :: [Text]
cpGhcOptions=[Text]
options}}
unusedPkgGhcOptions :: Map PackageName [Text]
unusedPkgGhcOptions = Map PackageName [Text]
pkgGhcOptions forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` forall k a. Map k a -> Set k
Map.keysSet Map PackageName ProjectPackage
packages2
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` forall k a. Map k a -> Set k
Map.keysSet Map PackageName DepPackage
deps2
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall k a. Map k a -> Bool
Map.null Map PackageName [Text]
unusedPkgGhcOptions) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ [PackageName] -> BuildException
InvalidGhcOptionsSpecification (forall k a. Map k a -> [k]
Map.keys Map PackageName [Text]
unusedPkgGhcOptions)
let wanted :: SMWanted
wanted = SMWanted
{ smwCompiler :: WantedCompiler
smwCompiler = forall a. a -> Maybe a -> a
fromMaybe WantedCompiler
snapCompiler (Project -> Maybe WantedCompiler
projectCompiler Project
project)
, smwProject :: Map PackageName ProjectPackage
smwProject = Map PackageName ProjectPackage
packages
, smwDeps :: Map PackageName DepPackage
smwDeps = Map PackageName DepPackage
deps
, smwSnapshotLocation :: RawSnapshotLocation
smwSnapshotLocation = Project -> RawSnapshotLocation
projectResolver Project
project
}
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SMWanted
wanted, forall a. [Maybe a] -> [a]
catMaybes [Maybe CompletedPLI]
mcompleted)
checkDuplicateNames :: MonadThrow m => [(PackageName, PackageLocation)] -> m ()
checkDuplicateNames :: forall (m :: * -> *).
MonadThrow m =>
[(PackageName, PackageLocation)] -> m ()
checkDuplicateNames [(PackageName, PackageLocation)]
locals =
case forall a. (a -> Bool) -> [a] -> [a]
filter forall {a} {a}. (a, [a]) -> Bool
hasMultiples forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall (f :: * -> *) a. Applicative f => a -> f a
pure) [(PackageName, PackageLocation)]
locals of
[] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
[(PackageName, [PackageLocation])]
x -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ [(PackageName, [PackageLocation])] -> ConfigException
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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
(Path Abs Dir
configRoot, Path Abs Dir
stackRoot) <- do
case forall a. First a -> Maybe a
getFirst (ConfigMonoid -> First (Path Abs Dir)
configMonoidStackRoot ConfigMonoid
clArgs) of
Just Path Abs Dir
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir
x, Path Abs Dir
x)
Maybe (Path Abs Dir)
Nothing -> do
Maybe String
mstackRoot <- String -> IO (Maybe String)
lookupEnv String
stackRootEnvVar
case Maybe String
mstackRoot of
Maybe String
Nothing -> do
String
wantXdg <- forall a. a -> Maybe a -> a
fromMaybe String
"" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
stackXdgEnvVar
if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
wantXdg)
then do
Path Rel Dir
xdgRelDir <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir String
stackProgName
(,)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadIO m =>
XdgDirectory -> Maybe (Path Rel Dir) -> m (Path Abs Dir)
getXdgDir XdgDirectory
XdgConfig (forall a. a -> Maybe a
Just Path Rel Dir
xdgRelDir)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *).
MonadIO m =>
XdgDirectory -> Maybe (Path Rel Dir) -> m (Path Abs Dir)
getXdgDir XdgDirectory
XdgData (forall a. a -> Maybe a
Just Path Rel Dir
xdgRelDir)
else do
Path Abs Dir
oldStyleRoot <- forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
getAppUserDataDir String
stackProgName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir
oldStyleRoot, Path Abs Dir
oldStyleRoot)
Just String
x -> case forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir String
x of
Maybe (Path Abs Dir)
Nothing ->
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ String -> String -> ParseAbsolutePathException
ParseAbsolutePathException String
stackRootEnvVar String
x
Just Path Abs Dir
parsed -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir
parsed, Path Abs Dir
parsed)
(Path Abs Dir
existingStackRootOrParentDir, Bool
userOwnsIt) <- do
Maybe (Path Abs Dir, Bool)
mdirAndOwnership <- forall (m :: * -> *) a.
MonadIO m =>
(Path Abs Dir -> m (Maybe a)) -> Path Abs Dir -> m (Maybe a)
findInParents forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> m (Maybe (Path Abs Dir, Bool))
getDirAndOwnership Path Abs Dir
stackRoot
case Maybe (Path Abs Dir, Bool)
mdirAndOwnership of
Just (Path Abs Dir, Bool)
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir, Bool)
x
Maybe (Path Abs Dir, Bool)
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Path Abs Dir -> ConfigException
BadStackRoot Path Abs Dir
stackRoot)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Path Abs Dir
existingStackRootOrParentDir forall a. Eq a => a -> a -> Bool
/= Path Abs Dir
stackRoot) forall a b. (a -> b) -> a -> b
$
if Bool
userOwnsIt
then forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
stackRoot
else forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$
Path Abs Dir -> Path Abs Dir -> ConfigException
Won'tCreateStackRootInDirectoryOwnedByDifferentUser
Path Abs Dir
stackRoot
Path Abs Dir
existingStackRootOrParentDir
Path Abs Dir
configRoot' <- forall path (m :: * -> *).
(AnyPath path, MonadIO m) =>
path -> m (AbsPath path)
canonicalizePath Path Abs Dir
configRoot
Path Abs Dir
stackRoot' <- forall path (m :: * -> *).
(AnyPath path, MonadIO m) =>
path -> m (AbsPath path)
canonicalizePath Path Abs Dir
stackRoot
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir
configRoot', Path Abs Dir
stackRoot', Bool
userOwnsIt)
checkOwnership :: (MonadIO m) => Path Abs Dir -> m ()
checkOwnership :: forall (m :: * -> *). MonadIO m => Path Abs Dir -> m ()
checkOwnership Path Abs Dir
dir = do
Maybe (Path Abs Dir, Bool)
mdirAndOwnership <- forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m (Maybe b)
firstJustM forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> m (Maybe (Path Abs Dir, Bool))
getDirAndOwnership [Path Abs Dir
dir, forall b t. Path b t -> Path b Dir
parent Path Abs Dir
dir]
case Maybe (Path Abs Dir, Bool)
mdirAndOwnership of
Just (Path Abs Dir
_, Bool
True) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just (Path Abs Dir
dir', Bool
False) -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Path Abs Dir -> ConfigException
UserDoesn'tOwnDirectory Path Abs Dir
dir')
Maybe (Path Abs Dir, Bool)
Nothing ->
(forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ConfigException
NoSuchDirectory) forall a b. (a -> b) -> a -> b
$ (forall loc. Path loc Dir -> String
toFilePathNoTrailingSep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> Path b Dir
parent) Path Abs Dir
dir
getDirAndOwnership ::
(MonadIO m)
=> Path Abs Dir
-> m (Maybe (Path Abs Dir, Bool))
getDirAndOwnership :: forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> m (Maybe (Path Abs Dir, Bool))
getDirAndOwnership Path Abs Dir
dir = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
m a -> m (Maybe a)
forgivingAbsence forall a b. (a -> b) -> a -> b
$ do
Bool
ownership <- forall (m :: * -> *) t. MonadIO m => Path Abs t -> m Bool
isOwnedByUser Path Abs Dir
dir
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir
dir, Bool
ownership)
isOwnedByUser :: MonadIO m => Path Abs t -> m Bool
isOwnedByUser :: forall (m :: * -> *) t. MonadIO m => Path Abs t -> m Bool
isOwnedByUser Path Abs t
path = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
if Bool
osIsWindows
then forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
else do
FileStatus
fileStatus <- String -> IO FileStatus
getFileStatus (forall b t. Path b t -> String
toFilePath Path Abs t
path)
UserID
user <- IO UserID
getEffectiveUserID
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UserID
user forall a. Eq a => a -> a -> Bool
== FileStatus -> UserID
fileOwner FileStatus
fileStatus)
getInContainer :: (MonadIO m) => m Bool
getInContainer :: forall (m :: * -> *). MonadIO m => m Bool
getInContainer = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
inContainerEnvVar)
getInNixShell :: (MonadIO m) => m Bool
getInNixShell :: forall (m :: * -> *). MonadIO m => m Bool
getInNixShell = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
inNixShellEnvVar)
getExtraConfigs :: HasLogFunc env
=> Path Abs File
-> RIO env [Path Abs File]
Path Abs File
userConfigPath = do
Maybe (Path Abs File)
defaultStackGlobalConfigPath <- forall env. HasLogFunc env => RIO env (Maybe (Path Abs File))
getDefaultGlobalConfigPath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
[(String, String)]
env <- IO [(String, String)]
getEnvironment
Maybe (Path Abs File)
mstackConfig <-
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile)
forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"STACK_CONFIG" [(String, String)]
env
Maybe (Path Abs File)
mstackGlobalConfig <-
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile)
forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"STACK_GLOBAL_CONFIG" [(String, String)]
env
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist
forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Path Abs File
userConfigPath Maybe (Path Abs File)
mstackConfig
forall a. a -> [a] -> [a]
: forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Path Abs File)
mstackGlobalConfig forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Path Abs File)
defaultStackGlobalConfigPath)
loadConfigYaml ::
HasLogFunc env
=> (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> RIO env a
loadConfigYaml :: forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env a
loadConfigYaml Value -> Parser (WithJSONWarnings a)
parser Path Abs File
path = do
Either ParseException a
eres <- forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env (Either ParseException a)
loadYaml Value -> Parser (WithJSONWarnings a)
parser Path Abs File
path
case Either ParseException a
eres of
Left ParseException
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException (Path Abs File -> ParseException -> ConfigPrettyException
ParseConfigFileException Path Abs File
path ParseException
err)
Right a
res -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res
loadYaml ::
HasLogFunc env
=> (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> RIO env (Either Yaml.ParseException a)
loadYaml :: forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env (Either ParseException a)
loadYaml Value -> Parser (WithJSONWarnings a)
parser Path Abs File
path = do
Either ParseException Value
eres <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => String -> IO (Either ParseException a)
Yaml.decodeFileEither (forall b t. Path b t -> String
toFilePath Path Abs File
path)
case Either ParseException Value
eres of
Left ParseException
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left ParseException
err)
Right Value
val ->
case forall a b. (a -> Parser b) -> a -> Either String b
Yaml.parseEither Value -> Parser (WithJSONWarnings a)
parser Value
val of
Left String
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left (String -> ParseException
Yaml.AesonException String
err))
Right (WithJSONWarnings a
res [JSONWarning]
warnings) -> do
forall env (m :: * -> *).
(MonadReader env m, HasLogFunc env, HasCallStack, MonadIO m) =>
String -> [JSONWarning] -> m ()
logJSONWarnings (forall b t. Path b t -> String
toFilePath Path Abs File
path) [JSONWarning]
warnings
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right a
res)
getProjectConfig :: HasLogFunc env
=> StackYamlLoc
-> RIO env (ProjectConfig (Path Abs File))
getProjectConfig :: forall env.
HasLogFunc env =>
StackYamlLoc -> RIO env (ProjectConfig (Path Abs File))
getProjectConfig (SYLOverride Path Abs File
stackYaml) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> ProjectConfig a
PCProject Path Abs File
stackYaml
getProjectConfig StackYamlLoc
SYLGlobalProject = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. ProjectConfig a
PCGlobalProject
getProjectConfig StackYamlLoc
SYLDefault = do
[(String, String)]
env <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(String, String)]
getEnvironment
case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"STACK_YAML" [(String, String)]
env of
Just String
fp -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Getting project config file from STACK_YAML environment"
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. a -> ProjectConfig a
PCProject forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => String -> m (Path Abs File)
resolveFile' String
fp
Maybe String
Nothing -> do
Path Abs Dir
currDir <- forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. ProjectConfig a
PCGlobalProject forall a. a -> ProjectConfig a
PCProject forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
MonadIO m =>
(Path Abs Dir -> m (Maybe a)) -> Path Abs Dir -> m (Maybe a)
findInParents forall {m :: * -> *} {env} {b}.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
Path b Dir -> m (Maybe (Path b File))
getStackDotYaml Path Abs Dir
currDir
where
getStackDotYaml :: Path b Dir -> m (Maybe (Path b File))
getStackDotYaml Path b Dir
dir = do
let fp :: Path b File
fp = Path b Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
stackDotYaml
fp' :: String
fp' = forall b t. Path b t -> String
toFilePath Path b File
fp
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Checking for project config at: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString String
fp'
Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path b File
fp
if Bool
exists
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Path b File
fp
else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
getProjectConfig (SYLNoProject [PackageIdentifierRevision]
extraDeps) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [PackageIdentifierRevision] -> ProjectConfig a
PCNoProject [PackageIdentifierRevision]
extraDeps
loadProjectConfig :: HasLogFunc env
=> StackYamlLoc
-> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid))
loadProjectConfig :: forall env.
HasLogFunc env =>
StackYamlLoc
-> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid))
loadProjectConfig StackYamlLoc
mstackYaml = do
ProjectConfig (Path Abs File)
mfp <- forall env.
HasLogFunc env =>
StackYamlLoc -> RIO env (ProjectConfig (Path Abs File))
getProjectConfig StackYamlLoc
mstackYaml
case ProjectConfig (Path Abs File)
mfp of
PCProject Path Abs File
fp -> do
Path Abs Dir
currDir <- forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Loading project config file " forall a. Semigroup a => a -> a -> a
<>
forall a. IsString a => String -> a
fromString (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall b t. Path b t -> String
toFilePath Path Abs File
fp) forall b t. Path b t -> String
toFilePath (forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix Path Abs Dir
currDir Path Abs File
fp))
forall a. a -> ProjectConfig a
PCProject forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {env}.
HasLogFunc env =>
Path Abs File -> RIO env (Project, Path Abs File, ConfigMonoid)
load Path Abs File
fp
ProjectConfig (Path Abs File)
PCGlobalProject -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"No project config file found, using defaults."
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. ProjectConfig a
PCGlobalProject
PCNoProject [PackageIdentifierRevision]
extraDeps -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Ignoring config files"
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [PackageIdentifierRevision] -> ProjectConfig a
PCNoProject [PackageIdentifierRevision]
extraDeps
where
load :: Path Abs File -> RIO env (Project, Path Abs File, ConfigMonoid)
load Path Abs File
fp = do
IO ProjectAndConfigMonoid
iopc <- forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env a
loadConfigYaml (Path Abs Dir
-> Value -> Parser (WithJSONWarnings (IO ProjectAndConfigMonoid))
parseProjectAndConfigMonoid (forall b t. Path b t -> Path b Dir
parent Path Abs File
fp)) Path Abs File
fp
ProjectAndConfigMonoid Project
project ConfigMonoid
config <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ProjectAndConfigMonoid
iopc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Project
project, Path Abs File
fp, ConfigMonoid
config)
getDefaultGlobalConfigPath ::
HasLogFunc env
=> RIO env (Maybe (Path Abs File))
getDefaultGlobalConfigPath :: forall env. HasLogFunc env => RIO env (Maybe (Path Abs File))
getDefaultGlobalConfigPath =
case (Maybe (Path Abs File)
defaultGlobalConfigPath, Maybe (Path Abs File)
defaultGlobalConfigPathDeprecated) of
(Just Path Abs File
new,Just Path Abs File
old) ->
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst ) forall a b. (a -> b) -> a -> b
$
forall env a.
HasLogFunc env =>
Maybe Text
-> (Path Abs a -> RIO env Bool)
-> Path Abs a
-> Path Abs a
-> RIO env (Path Abs a, Bool)
tryDeprecatedPath
(forall a. a -> Maybe a
Just Text
"non-project global configuration file")
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist
Path Abs File
new
Path Abs File
old
(Just Path Abs File
new,Maybe (Path Abs File)
Nothing) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Path Abs File
new)
(Maybe (Path Abs File), Maybe (Path Abs File))
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
getDefaultUserConfigPath ::
HasLogFunc env
=> Path Abs Dir -> RIO env (Path Abs File)
getDefaultUserConfigPath :: forall env.
HasLogFunc env =>
Path Abs Dir -> RIO env (Path Abs File)
getDefaultUserConfigPath Path Abs Dir
stackRoot = do
(Path Abs File
path, Bool
exists) <- forall env a.
HasLogFunc env =>
Maybe Text
-> (Path Abs a -> RIO env Bool)
-> Path Abs a
-> Path Abs a
-> RIO env (Path Abs a, Bool)
tryDeprecatedPath
(forall a. a -> Maybe a
Just Text
"non-project configuration file")
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist
(Path Abs Dir -> Path Abs File
defaultUserConfigPath Path Abs Dir
stackRoot)
(Path Abs Dir -> Path Abs File
defaultUserConfigPathDeprecated Path Abs Dir
stackRoot)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (forall b t. Path b t -> Path b Dir
parent Path Abs File
path)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
path forall s. (IsString s, Semigroup s) => s
defaultConfigYaml
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
path
packagesParser :: Parser [String]
packagesParser :: Parser [String]
packagesParser = forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall s. IsString s => Mod OptionFields s -> Parser s
strOption
(forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"package" forall a. Semigroup a => a -> a -> a
<>
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"PACKAGE" forall a. Semigroup a => a -> a -> a
<>
forall (f :: * -> *) a. String -> Mod f a
help String
"Add a package (can be specified multiple times)"))
defaultConfigYaml :: (IsString s, Semigroup s) => s
defaultConfigYaml :: forall s. (IsString s, Semigroup s) => s
defaultConfigYaml =
s
"# This file contains default non-project-specific settings for Stack, used\n" forall a. Semigroup a => a -> a -> a
<>
s
"# in all projects. For more information about Stack's configuration, see\n" forall a. Semigroup a => a -> a -> a
<>
s
"# http://docs.haskellstack.org/en/stable/yaml_configuration/\n" forall a. Semigroup a => a -> a -> a
<>
s
"\n" forall a. Semigroup a => a -> a -> a
<>
s
"# The following parameters are used by 'stack new' to automatically fill fields\n" forall a. Semigroup a => a -> a -> a
<>
s
"# in the Cabal file. We recommend uncommenting them and filling them out if\n" forall a. Semigroup a => a -> a -> a
<>
s
"# you intend to use 'stack new'.\n" forall a. Semigroup a => a -> a -> a
<>
s
"# See https://docs.haskellstack.org/en/stable/yaml_configuration/#templates\n" forall a. Semigroup a => a -> a -> a
<>
s
"templates:\n" forall a. Semigroup a => a -> a -> a
<>
s
" params:\n" forall a. Semigroup a => a -> a -> a
<>
s
"# author-name:\n" forall a. Semigroup a => a -> a -> a
<>
s
"# author-email:\n" forall a. Semigroup a => a -> a -> a
<>
s
"# copyright:\n" forall a. Semigroup a => a -> a -> a
<>
s
"# github-username:\n" forall a. Semigroup a => a -> a -> a
<>
s
"\n" forall a. Semigroup a => a -> a -> a
<>
s
"# The following parameter specifies Stack's output styles; STYLES is a\n" forall a. Semigroup a => a -> a -> a
<>
s
"# colon-delimited sequence of key=value, where 'key' is a style name and\n" forall a. Semigroup a => a -> a -> a
<>
s
"# 'value' is a semicolon-delimited list of 'ANSI' SGR (Select Graphic\n" forall a. Semigroup a => a -> a -> a
<>
s
"# Rendition) control codes (in decimal). Use 'stack ls stack-colors --basic'\n" forall a. Semigroup a => a -> a -> a
<>
s
"# to see the current sequence.\n" forall a. Semigroup a => a -> a -> a
<>
s
"# stack-colors: STYLES\n"