{-# LANGUAGE CPP #-}

{-# LANGUAGE ConstraintKinds #-}

{-# LANGUAGE DataKinds #-}

{-# LANGUAGE DefaultSignatures #-}

{-# LANGUAGE DeriveDataTypeable #-}

{-# LANGUAGE DeriveFoldable #-}

{-# LANGUAGE DeriveFunctor #-}

{-# LANGUAGE DeriveGeneric #-}

{-# LANGUAGE DeriveTraversable #-}

{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE FlexibleInstances #-}

{-# LANGUAGE GADTs #-}

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

{-# LANGUAGE MultiParamTypeClasses #-}

{-# LANGUAGE MultiWayIf #-}

{-# LANGUAGE NoImplicitPrelude #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE RecordWildCards #-}

{-# LANGUAGE ScopedTypeVariables #-}

{-# LANGUAGE StandaloneDeriving #-}

{-# LANGUAGE TemplateHaskell #-}

{-# LANGUAGE TupleSections #-}

{-# LANGUAGE TypeFamilies #-}

-- | The Config type.

module Stack.Types.Config

(

-- * Main configuration types and classes

-- ** HasPlatform & HasStackRoot

HasPlatform(..)

,PlatformVariant(..)

-- ** Config & HasConfig

,Config(..)

,HasConfig(..)

,askLatestSnapshotUrl

,explicitSetupDeps

-- ** BuildConfig & HasBuildConfig

,BuildConfig(..)

,LocalPackages(..)

,LocalPackageView(..)

,lpvRoot

,lpvName

,lpvVersion

,lpvComponents

,stackYamlL

,projectRootL

,HasBuildConfig(..)

-- ** GHCVariant & HasGHCVariant

,GHCVariant(..)

,ghcVariantName

,ghcVariantSuffix

,parseGHCVariant

,HasGHCVariant(..)

,snapshotsDir

-- ** EnvConfig & HasEnvConfig

,EnvConfig(..)

,HasEnvConfig(..)

,getCompilerPath

-- * Details

-- ** ApplyGhcOptions

,ApplyGhcOptions(..)

-- ** ConfigException

,HpackExecutable(..)

,ConfigException(..)

-- ** WhichSolverCmd

,WhichSolverCmd(..)

-- ** ConfigMonoid

,ConfigMonoid(..)

,configMonoidInstallGHCName

,configMonoidSystemGHCName

,parseConfigMonoid

-- ** DumpLogs

,DumpLogs(..)

-- ** EnvSettings

,EnvSettings(..)

,minimalEnvSettings

,defaultEnvSettings

,plainEnvSettings

-- ** GlobalOpts & GlobalOptsMonoid

,GlobalOpts(..)

,GlobalOptsMonoid(..)

,StackYamlLoc(..)

,defaultLogLevel

-- ** LoadConfig

,LoadConfig(..)

-- ** PackageIndex, IndexName & IndexLocation

-- Re-exports

,PackageIndex(..)

,IndexName(..)

,indexNameText

-- ** Project & ProjectAndConfigMonoid

,Project(..)

,ProjectAndConfigMonoid(..)

,parseProjectAndConfigMonoid

-- ** PvpBounds

,PvpBounds(..)

,PvpBoundsType(..)

,parsePvpBounds

-- ** ColorWhen

,readColorWhen

-- ** SCM

,SCM(..)

-- * Paths

,bindirSuffix

,configInstalledCache

,configLoadedSnapshotCache

,GlobalInfoSource(..)

,getProjectWorkDir

,docDirSuffix

,flagCacheLocal

,extraBinDirs

,hpcReportDir

,installationRootDeps

,installationRootLocal

,bindirCompilerTools

,hoogleRoot

,hoogleDatabasePath

,packageDatabaseDeps

,packageDatabaseExtra

,packageDatabaseLocal

,platformOnlyRelDir

,platformGhcRelDir

,platformGhcVerOnlyRelDir

,useShaPathOnWindows

,shaPath

,workDirL

-- * Command-specific types

-- ** Eval

,EvalOpts(..)

-- ** Exec

,ExecOpts(..)

,SpecialExecCmd(..)

,ExecOptsExtra(..)

-- ** Setup

,DownloadInfo(..)

,VersionedDownloadInfo(..)

,GHCDownloadInfo(..)

,SetupInfo(..)

,SetupInfoLocation(..)

-- ** Docker entrypoint

,DockerEntrypoint(..)

,DockerUser(..)

,module X

-- * Lens helpers

,wantedCompilerVersionL

,actualCompilerVersionL

,buildOptsL

,globalOptsL

,buildOptsInstallExesL

,buildOptsMonoidHaddockL

,buildOptsMonoidTestsL

,buildOptsMonoidBenchmarksL

,buildOptsMonoidInstallExesL

,buildOptsHaddockL

,globalOptsBuildOptsMonoidL

,stackRootL

,configUrlsL

,cabalVersionL

,whichCompilerL

,envOverrideSettingsL

,loadedSnapshotL

,globalHintsL

,shouldForceGhcColorFlag

,appropriateGhcColorFlag

-- * Lens reexport

,view

,to

) where

import Control.Monad.Writer (tell)

import Crypto.Hash (hashWith, SHA1(..))

import Stack.Prelude

import Data.Aeson.Extended

(ToJSON, toJSON, FromJSON, FromJSONKey (..), parseJSON, withText, object,

(.=), (..:), (..:?), (..!=), Value(Bool, String),

withObjectWarnings, WarningParser, Object, jsonSubWarnings,

jsonSubWarningsT, jsonSubWarningsTT, WithJSONWarnings(..), noJSONWarnings,

FromJSONKeyFunction (FromJSONKeyTextParser))

import Data.Attoparsec.Args (parseArgs, EscapingMode (Escaping))

import qualified Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16))

import qualified Data.ByteString.Char8 as S8

import Data.List (stripPrefix)

import Data.List.NonEmpty (NonEmpty)

import qualified Data.List.NonEmpty as NonEmpty

import qualified Data.Map as Map

import qualified Data.Map.Strict as M

import qualified Data.Set as Set

import qualified Data.Text as T

import Data.Text.Encoding (encodeUtf8)

import Data.Yaml (ParseException)

import qualified Data.Yaml as Yaml

import Distribution.PackageDescription (GenericPackageDescription)

import qualified Distribution.PackageDescription as C

import Distribution.System (Platform)

import qualified Distribution.Text

import qualified Distribution.Types.UnqualComponentName as C

import Distribution.Version (anyVersion, mkVersion')

import Generics.Deriving.Monoid (memptydefault, mappenddefault)

import Lens.Micro (Lens', lens, _1, _2, to)

import Options.Applicative (ReadM)

import qualified Options.Applicative as OA

import qualified Options.Applicative.Types as OA

import Path

import qualified Paths_stack as Meta

import Stack.Constants

import Stack.PackageIndex (HasCabalLoader (..), CabalLoader (clStackRoot))

import Stack.Types.BuildPlan

import Stack.Types.Compiler

import Stack.Types.CompilerBuild

import Stack.Types.Docker

import Stack.Types.FlagName

import Stack.Types.Image

import Stack.Types.NamedComponent

import Stack.Types.Nix

import Stack.Types.PackageIdentifier

import Stack.Types.PackageIndex

import Stack.Types.PackageName

import Stack.Types.Resolver

import Stack.Types.Runner

import Stack.Types.TemplateName

import Stack.Types.Urls

import Stack.Types.Version

import qualified System.FilePath as FilePath

import System.PosixCompat.Types (UserID, GroupID, FileMode)

import RIO.Process (EnvOverride, HasEnvOverride (..), findExecutable)

-- Re-exports

import Stack.Types.Config.Build as X

-- | The top-level Stackage configuration.

data Config =

Config {configWorkDir :: !(Path Rel Dir)

-- ^ this allows to override .stack-work directory

,configUserConfigPath :: !(Path Abs File)

-- ^ Path to user configuration file (usually ~/.stack/config.yaml)

,configBuild :: !BuildOpts

-- ^ Build configuration

,configDocker :: !DockerOpts

-- ^ Docker configuration

,configNix :: !NixOpts

-- ^ Execution environment (e.g nix-shell) configuration

,configEnvOverrideSettings :: !(EnvSettings -> IO EnvOverride)

-- ^ Environment variables to be passed to external tools

,configLocalProgramsBase :: !(Path Abs Dir)

-- ^ Non-platform-specific path containing local installations

,configLocalPrograms :: !(Path Abs Dir)

-- ^ Path containing local installations (mainly GHC)

,configHideTHLoading :: !Bool

-- ^ Hide the Template Haskell "Loading package ..." messages from the

-- console

,configPlatform :: !Platform

-- ^ The platform we're building for, used in many directory names

,configPlatformVariant :: !PlatformVariant

-- ^ Variant of the platform, also used in directory names

,configGHCVariant0 :: !(Maybe GHCVariant)

-- ^ The variant of GHC requested by the user.

-- In most cases, use 'BuildConfig' or 'MiniConfig's version instead,

-- which will have an auto-detected default.

,configGHCBuild :: !(Maybe CompilerBuild)

-- ^ Override build of the compiler distribution (e.g. standard, gmp4, tinfo6)

,configUrls :: !Urls

-- ^ URLs for other files used by stack.

-- TODO: Better document

-- e.g. The latest snapshot file.

-- A build plan name (e.g. lts5.9.yaml) is appended when downloading

-- the build plan actually.

,configSystemGHC :: !Bool

-- ^ Should we use the system-installed GHC (on the PATH) if

-- available? Can be overridden by command line options.

,configInstallGHC :: !Bool

-- ^ Should we automatically install GHC if missing or the wrong

-- version is available? Can be overridden by command line options.

,configSkipGHCCheck :: !Bool

-- ^ Don't bother checking the GHC version or architecture.

,configSkipMsys :: !Bool

-- ^ On Windows: don't use a sandboxed MSYS

,configCompilerCheck :: !VersionCheck

-- ^ Specifies which versions of the compiler are acceptable.

,configLocalBin :: !(Path Abs Dir)

-- ^ Directory we should install executables into

,configRequireStackVersion :: !VersionRange

-- ^ Require a version of stack within this range.

,configJobs :: !Int

-- ^ How many concurrent jobs to run, defaults to number of capabilities

,configOverrideGccPath :: !(Maybe (Path Abs File))

-- ^ Optional gcc override path

,configOverrideHpack :: !HpackExecutable

-- ^ Use Hpack executable (overrides bundled Hpack)

,configExtraIncludeDirs :: !(Set FilePath)

-- ^ --extra-include-dirs arguments

,configExtraLibDirs :: !(Set FilePath)

-- ^ --extra-lib-dirs arguments

,configConcurrentTests :: !Bool

-- ^ Run test suites concurrently

,configImage :: !ImageOpts

,configTemplateParams :: !(Map Text Text)

-- ^ Parameters for templates.

,configScmInit :: !(Maybe SCM)

-- ^ Initialize SCM (e.g. git) when creating new projects.

,configGhcOptionsByName :: !(Map PackageName [Text])

-- ^ Additional GHC options to apply to specific packages.

,configGhcOptionsByCat :: !(Map ApplyGhcOptions [Text])

-- ^ Additional GHC options to apply to categories of packages

,configSetupInfoLocations :: ![SetupInfoLocation]

-- ^ Additional SetupInfo (inline or remote) to use to find tools.

,configPvpBounds :: !PvpBounds

-- ^ How PVP upper bounds should be added to packages

,configModifyCodePage :: !Bool

-- ^ Force the code page to UTF-8 on Windows

,configExplicitSetupDeps :: !(Map (Maybe PackageName) Bool)

-- ^ See 'explicitSetupDeps'. 'Nothing' provides the default value.

,configRebuildGhcOptions :: !Bool

-- ^ Rebuild on GHC options changes

,configApplyGhcOptions :: !ApplyGhcOptions

-- ^ Which packages to ghc-options on the command line apply to?

,configAllowNewer :: !Bool

-- ^ Ignore version ranges in .cabal files. Funny naming chosen to

-- match cabal.

,configDefaultTemplate :: !(Maybe TemplateName)

-- ^ The default template to use when none is specified.

-- (If Nothing, the default default is used.)

,configAllowDifferentUser :: !Bool

-- ^ Allow users other than the stack root owner to use the stack

-- installation.

,configDumpLogs :: !DumpLogs

-- ^ Dump logs of local non-dependencies when doing a build.

,configMaybeProject :: !(Maybe (Project, Path Abs File))

-- ^ 'Just' when a local project can be found, 'Nothing' when stack must

-- fall back on the implicit global project.

,configAllowLocals :: !Bool

-- ^ Are we allowed to build local packages? The script

-- command disallows this.

,configSaveHackageCreds :: !Bool

-- ^ Should we save Hackage credentials to a file?

,configRunner :: !Runner

,configCabalLoader :: !CabalLoader

}

data HpackExecutable

= HpackBundled

| HpackCommand String

deriving (Show, Read, Eq, Ord)

-- | Which packages do ghc-options on the command line apply to?

data ApplyGhcOptions = AGOTargets -- ^ all local targets

| AGOLocals -- ^ all local packages, even non-targets

| AGOEverything -- ^ every package

deriving (Show, Read, Eq, Ord, Enum, Bounded)

instance FromJSON ApplyGhcOptions where

parseJSON = withText "ApplyGhcOptions" $ \t ->

case t of

"targets" -> return AGOTargets

"locals" -> return AGOLocals

"everything" -> return AGOEverything

_ -> fail $ "Invalid ApplyGhcOptions: " ++ show t

-- | Which build log files to dump

data DumpLogs

= DumpNoLogs -- ^ don't dump any logfiles

| DumpWarningLogs -- ^ dump logfiles containing warnings

| DumpAllLogs -- ^ dump all logfiles

deriving (Show, Read, Eq, Ord, Enum, Bounded)

instance FromJSON DumpLogs where

parseJSON (Bool True) = return DumpAllLogs

parseJSON (Bool False) = return DumpNoLogs

parseJSON v =

withText

"DumpLogs"

(\t ->

if | t == "none" -> return DumpNoLogs

| t == "warning" -> return DumpWarningLogs

| t == "all" -> return DumpAllLogs

| otherwise -> fail ("Invalid DumpLogs: " ++ show t))

v

-- | Controls which version of the environment is used

data EnvSettings = EnvSettings

{ esIncludeLocals :: !Bool

-- ^ include local project bin directory, GHC_PACKAGE_PATH, etc

, esIncludeGhcPackagePath :: !Bool

-- ^ include the GHC_PACKAGE_PATH variable

, esStackExe :: !Bool

-- ^ set the STACK_EXE variable to the current executable name

, esLocaleUtf8 :: !Bool

-- ^ set the locale to C.UTF-8

, esKeepGhcRts :: !Bool

-- ^ if True, keep GHCRTS variable in environment

}

deriving (Show, Eq, Ord)

data ExecOpts = ExecOpts

{ eoCmd :: !SpecialExecCmd

, eoArgs :: ![String]

, eoExtra :: !ExecOptsExtra

} deriving (Show)

data SpecialExecCmd

= ExecCmd String

| ExecGhc

| ExecRunGhc

deriving (Show, Eq)

data ExecOptsExtra

= ExecOptsPlain

| ExecOptsEmbellished

{ eoEnvSettings :: !EnvSettings

, eoPackages :: ![String]

, eoRtsOptions :: ![String]

, eoCwd :: !(Maybe FilePath)

}

deriving (Show)

data EvalOpts = EvalOpts

{ evalArg :: !String

, evalExtra :: !ExecOptsExtra

} deriving (Show)

-- | Parsed global command-line options.

data GlobalOpts = GlobalOpts

{ globalReExecVersion :: !(Maybe String) -- ^ Expected re-exec in container version

, globalDockerEntrypoint :: !(Maybe DockerEntrypoint)

-- ^ Data used when stack is acting as a Docker entrypoint (internal use only)

, globalLogLevel :: !LogLevel -- ^ Log level

, globalTimeInLog :: !Bool -- ^ Whether to include timings in logs.

, globalConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig'

, globalResolver :: !(Maybe AbstractResolver) -- ^ Resolver override

, globalCompiler :: !(Maybe (CompilerVersion 'CVWanted)) -- ^ Compiler override

, globalTerminal :: !Bool -- ^ We're in a terminal?

, globalColorWhen :: !ColorWhen -- ^ When to use ansi terminal colors

, globalTermWidth :: !(Maybe Int) -- ^ Terminal width override

, globalStackYaml :: !(StackYamlLoc FilePath) -- ^ Override project stack.yaml

} deriving (Show)

data StackYamlLoc filepath

= SYLDefault

| SYLOverride !filepath

| SYLNoConfig !(Path Abs Dir)

-- ^ FilePath is the directory containing the script file, used

-- for resolving custom snapshot files.

deriving (Show,Functor,Foldable,Traversable)

-- | Parsed global command-line options monoid.

data GlobalOptsMonoid = GlobalOptsMonoid

{ globalMonoidReExecVersion :: !(First String) -- ^ Expected re-exec in container version

, globalMonoidDockerEntrypoint :: !(First DockerEntrypoint)

-- ^ Data used when stack is acting as a Docker entrypoint (internal use only)

, globalMonoidLogLevel :: !(First LogLevel) -- ^ Log level

, globalMonoidTimeInLog :: !(First Bool) -- ^ Whether to include timings in logs.

, globalMonoidConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig'

, globalMonoidResolver :: !(First AbstractResolver) -- ^ Resolver override

, globalMonoidCompiler :: !(First (CompilerVersion 'CVWanted)) -- ^ Compiler override

, globalMonoidTerminal :: !(First Bool) -- ^ We're in a terminal?

, globalMonoidColorWhen :: !(First ColorWhen) -- ^ When to use ansi colors

, globalMonoidTermWidth :: !(First Int) -- ^ Terminal width override

, globalMonoidStackYaml :: !(First FilePath) -- ^ Override project stack.yaml

} deriving (Show, Generic)

instance Monoid GlobalOptsMonoid where

mempty = memptydefault

mappend = mappenddefault

-- | Default logging level should be something useful but not crazy.

defaultLogLevel :: LogLevel

defaultLogLevel = LevelInfo

readColorWhen :: ReadM ColorWhen

readColorWhen = do

s <- OA.readerAsk

case s of

"never" -> return ColorNever

"always" -> return ColorAlways

"auto" -> return ColorAuto

_ -> OA.readerError "Expected values of color option are 'never', 'always', or 'auto'."

-- | A superset of 'Config' adding information on how to build code. The reason

-- for this breakdown is because we will need some of the information from

-- 'Config' in order to determine the values here.

--

-- These are the components which know nothing about local configuration.

data BuildConfig = BuildConfig

{ bcConfig :: !Config

, bcSnapshotDef :: !SnapshotDef

-- ^ Build plan wanted for this build

, bcGHCVariant :: !GHCVariant

-- ^ The variant of GHC used to select a GHC bindist.

, bcPackages :: ![PackageLocation Subdirs]

-- ^ Local packages

, bcDependencies :: ![PackageLocationIndex Subdirs]

-- ^ Extra dependencies specified in configuration.

--

-- These dependencies will not be installed to a shared location, and

-- will override packages provided by the resolver.

, bcExtraPackageDBs :: ![Path Abs Dir]

-- ^ Extra package databases

, bcStackYaml :: !(Path Abs File)

-- ^ Location of the stack.yaml file.

--

-- Note: if the STACK_YAML environment variable is used, this may be

-- different from projectRootL </> "stack.yaml"

--

-- FIXME MSS 2016-12-08: is the above comment still true? projectRootL

-- is defined in terms of bcStackYaml

, bcFlags :: !(Map PackageName (Map FlagName Bool))

-- ^ Per-package flag overrides

, bcImplicitGlobal :: !Bool

-- ^ Are we loading from the implicit global stack.yaml? This is useful

-- for providing better error messages.

}

stackYamlL :: HasBuildConfig env => Lens' env (Path Abs File)

stackYamlL = buildConfigL.lens bcStackYaml (\x y -> x { bcStackYaml = y })

-- | Directory containing the project's stack.yaml file

projectRootL :: HasBuildConfig env => Getting r env (Path Abs Dir)

projectRootL = stackYamlL.to parent

-- | Configuration after the environment has been setup.

data EnvConfig = EnvConfig

{envConfigBuildConfig :: !BuildConfig

,envConfigCabalVersion :: !Version

-- ^ This is the version of Cabal that stack will use to compile Setup.hs files

-- in the build process.

--

-- Note that this is not necessarily the same version as the one that stack

-- depends on as a library and which is displayed when running

-- @stack list-dependencies | grep Cabal@ in the stack project.

,envConfigCompilerVersion :: !(CompilerVersion 'CVActual)

-- ^ The actual version of the compiler to be used, as opposed to

-- 'wantedCompilerL', which provides the version specified by the

-- build plan.

,envConfigCompilerBuild :: !CompilerBuild

,envConfigPackagesRef :: !(IORef (Maybe LocalPackages))

-- ^ Cache for 'getLocalPackages'.

,envConfigLoadedSnapshot :: !LoadedSnapshot

-- ^ The fully resolved snapshot information.

}

data LocalPackages = LocalPackages

{ lpProject :: !(Map PackageName LocalPackageView)

, lpDependencies :: !(Map PackageName (GenericPackageDescription, PackageLocationIndex FilePath))

}

-- | A view of a local package needed for resolving components

data LocalPackageView = LocalPackageView

{ lpvCabalFP :: !(Path Abs File)

, lpvGPD :: !GenericPackageDescription

, lpvLoc :: !(PackageLocation FilePath)

}

-- | Root directory for the given 'LocalPackageView'

lpvRoot :: LocalPackageView -> Path Abs Dir

lpvRoot = parent . lpvCabalFP

-- | Package name for the given 'LocalPackageView

lpvName :: LocalPackageView -> PackageName

lpvName lpv =

let PackageIdentifier name _version =

fromCabalPackageIdentifier

$ C.package

$ C.packageDescription

$ lpvGPD lpv

in name

-- | All components available in the given 'LocalPackageView'

lpvComponents :: LocalPackageView -> Set NamedComponent

lpvComponents lpv = Set.fromList $ concat

[ maybe [] (const [CLib]) (C.condLibrary gpkg)

, go CExe (map fst . C.condExecutables)

, go CTest (map fst . C.condTestSuites)

, go CBench (map fst . C.condBenchmarks)

]

where

gpkg = lpvGPD lpv

go :: (T.Text -> NamedComponent)

-> (C.GenericPackageDescription -> [C.UnqualComponentName])

-> [NamedComponent]

go wrapper f = map (wrapper . T.pack . C.unUnqualComponentName) $ f gpkg

-- | Version for the given 'LocalPackageView

lpvVersion :: LocalPackageView -> Version

lpvVersion lpv =

let PackageIdentifier _name version =

fromCabalPackageIdentifier

$ C.package

$ C.packageDescription

$ lpvGPD lpv

in version

-- | Value returned by 'Stack.Config.loadConfig'.

data LoadConfig = LoadConfig

{ lcConfig :: !Config

-- ^ Top-level Stack configuration.

, lcLoadBuildConfig :: !(Maybe (CompilerVersion 'CVWanted) -> IO BuildConfig)

-- ^ Action to load the remaining 'BuildConfig'.

, lcProjectRoot :: !(Maybe (Path Abs Dir))

-- ^ The project root directory, if in a project.

}

data PackageEntry = PackageEntry

{ peExtraDepMaybe :: !(Maybe TreatLikeExtraDep)

, peLocation :: !(PackageLocation Subdirs)

, peSubdirs :: !Subdirs

}

deriving Show

-- | Should a package be treated just like an extra-dep?

--

-- 'True' means, it will only be built as a dependency

-- for others, and its test suite/benchmarks will not be run.

--

-- Useful modifying an upstream package, see:

-- https://github.com/commercialhaskell/stack/issues/219

-- https://github.com/commercialhaskell/stack/issues/386

type TreatLikeExtraDep = Bool

instance FromJSON (WithJSONWarnings PackageEntry) where

parseJSON (String t) = do

WithJSONWarnings loc _ <- parseJSON $ String t

return $ noJSONWarnings

PackageEntry

{ peExtraDepMaybe = Nothing

, peLocation = loc

, peSubdirs = DefaultSubdirs

}

parseJSON v = withObjectWarnings "PackageEntry" (\o -> PackageEntry

<$> o ..:? "extra-dep"

<*> jsonSubWarnings (o ..: "location")

<*> o ..:? "subdirs" ..!= DefaultSubdirs) v

-- | A project is a collection of packages. We can have multiple stack.yaml

-- files, but only one of them may contain project information.

data Project = Project

{ projectUserMsg :: !(Maybe String)

-- ^ A warning message to display to the user when the auto generated

-- config may have issues.

, projectPackages :: ![PackageLocation Subdirs]

-- ^ Packages which are actually part of the project (as opposed

-- to dependencies).

--

-- /NOTE/ Stack has always allowed these packages to be any kind

-- of package location, but in reality only @PLFilePath@ really

-- makes sense. We could consider replacing @[PackageLocation]@

-- with @[FilePath]@ to properly enforce this idea, though it will

-- slightly break backwards compatibility if someone really did

-- want to treat such things as non-deps.

, projectDependencies :: ![PackageLocationIndex Subdirs]

-- ^ Dependencies defined within the stack.yaml file, to be

-- applied on top of the snapshot.

, projectFlags :: !(Map PackageName (Map FlagName Bool))

-- ^ Flags to be applied on top of the snapshot flags.

, projectResolver :: !Resolver

-- ^ How we resolve which @SnapshotDef@ to use

, projectCompiler :: !(Maybe (CompilerVersion 'CVWanted))

-- ^ When specified, overrides which compiler to use

, projectExtraPackageDBs :: ![FilePath]

}

deriving Show

instance ToJSON Project where

-- Expanding the constructor fully to ensure we don't miss any fields.

toJSON (Project userMsg packages extraDeps flags resolver compiler extraPackageDBs) = object $ concat

[ maybe [] (\cv -> ["compiler" .= cv]) compiler

, maybe [] (\msg -> ["user-message" .= msg]) userMsg

, if null extraPackageDBs then [] else ["extra-package-dbs" .= extraPackageDBs]

, if null extraDeps then [] else ["extra-deps" .= extraDeps]

, if Map.null flags then [] else ["flags" .= flags]

, ["packages" .= packages]

, ["resolver" .= resolver]

]

-- An uninterpreted representation of configuration options.

-- Configurations may be "cascaded" using mappend (left-biased).

data ConfigMonoid =

ConfigMonoid

{ configMonoidStackRoot :: !(First (Path Abs Dir))

-- ^ See: 'clStackRoot'

, configMonoidWorkDir :: !(First (Path Rel Dir))

-- ^ See: 'configWorkDir'.

, configMonoidBuildOpts :: !BuildOptsMonoid

-- ^ build options.

, configMonoidDockerOpts :: !DockerOptsMonoid

-- ^ Docker options.

, configMonoidNixOpts :: !NixOptsMonoid

-- ^ Options for the execution environment (nix-shell or container)

, configMonoidConnectionCount :: !(First Int)

-- ^ See: 'configConnectionCount'

, configMonoidHideTHLoading :: !(First Bool)

-- ^ See: 'configHideTHLoading'

, configMonoidLatestSnapshotUrl :: !(First Text)

-- ^ Deprecated in favour of 'urlsMonoidLatestSnapshot'

, configMonoidUrls :: !UrlsMonoid

-- ^ See: 'configUrls

, configMonoidPackageIndices :: !(First [PackageIndex])

-- ^ See: @picIndices@

, configMonoidSystemGHC :: !(First Bool)

-- ^ See: 'configSystemGHC'

,configMonoidInstallGHC :: !(First Bool)

-- ^ See: 'configInstallGHC'

,configMonoidSkipGHCCheck :: !(First Bool)

-- ^ See: 'configSkipGHCCheck'

,configMonoidSkipMsys :: !(First Bool)

-- ^ See: 'configSkipMsys'

,configMonoidCompilerCheck :: !(First VersionCheck)

-- ^ See: 'configCompilerCheck'

,configMonoidRequireStackVersion :: !IntersectingVersionRange

-- ^ See: 'configRequireStackVersion'

,configMonoidArch :: !(First String)

-- ^ Used for overriding the platform

,configMonoidGHCVariant :: !(First GHCVariant)

-- ^ Used for overriding the platform

,configMonoidGHCBuild :: !(First CompilerBuild)

-- ^ Used for overriding the GHC build

,configMonoidJobs :: !(First Int)

-- ^ See: 'configJobs'

,configMonoidExtraIncludeDirs :: !(Set FilePath)

-- ^ See: 'configExtraIncludeDirs'

,configMonoidExtraLibDirs :: !(Set FilePath)

-- ^ See: 'configExtraLibDirs'

, configMonoidOverrideGccPath :: !(First (Path Abs File))

-- ^ Allow users to override the path to gcc

,configMonoidOverrideHpack :: !(First FilePath)

-- ^ Use Hpack executable (overrides bundled Hpack)

,configMonoidConcurrentTests :: !(First Bool)

-- ^ See: 'configConcurrentTests'

,configMonoidLocalBinPath :: !(First FilePath)

-- ^ Used to override the binary installation dir

,configMonoidImageOpts :: !ImageOptsMonoid

-- ^ Image creation options.

,configMonoidTemplateParameters :: !(Map Text Text)

-- ^ Template parameters.

,configMonoidScmInit :: !(First SCM)

-- ^ Initialize SCM (e.g. git init) when making new projects?

,configMonoidGhcOptionsByName :: !(Map PackageName [Text])

-- ^ See 'configGhcOptionsByName'

,configMonoidGhcOptionsByCat :: !(Map ApplyGhcOptions [Text])

-- ^ See 'configGhcOptionsAll'

,configMonoidExtraPath :: ![Path Abs Dir]

-- ^ Additional paths to search for executables in

,configMonoidSetupInfoLocations :: ![SetupInfoLocation]

-- ^ Additional setup info (inline or remote) to use for installing tools

,configMonoidLocalProgramsBase :: !(First (Path Abs Dir))

-- ^ Override the default local programs dir, where e.g. GHC is installed.

,configMonoidPvpBounds :: !(First PvpBounds)

-- ^ See 'configPvpBounds'

,configMonoidModifyCodePage :: !(First Bool)

-- ^ See 'configModifyCodePage'

,configMonoidExplicitSetupDeps :: !(Map (Maybe PackageName) Bool)

-- ^ See 'configExplicitSetupDeps'

,configMonoidRebuildGhcOptions :: !(First Bool)

-- ^ See 'configMonoidRebuildGhcOptions'

,configMonoidApplyGhcOptions :: !(First ApplyGhcOptions)

-- ^ See 'configApplyGhcOptions'

,configMonoidAllowNewer :: !(First Bool)

-- ^ See 'configMonoidAllowNewer'

,configMonoidDefaultTemplate :: !(First TemplateName)

-- ^ The default template to use when none is specified.

-- (If Nothing, the default default is used.)

, configMonoidAllowDifferentUser :: !(First Bool)

-- ^ Allow users other than the stack root owner to use the stack

-- installation.

, configMonoidDumpLogs :: !(First DumpLogs)

-- ^ See 'configDumpLogs'

, configMonoidSaveHackageCreds :: !(First Bool)

-- ^ See 'configSaveHackageCreds'

, configMonoidIgnoreRevisionMismatch :: !(First Bool)

-- ^ See 'configIgnoreRevisionMismatch'

}

deriving (Show, Generic)

instance Monoid ConfigMonoid where

mempty = memptydefault

mappend = mappenddefault

parseConfigMonoid :: Path Abs Dir -> Value -> Yaml.Parser (WithJSONWarnings ConfigMonoid)

parseConfigMonoid = withObjectWarnings "ConfigMonoid" . parseConfigMonoidObject

-- | Parse a partial configuration. Used both to parse both a standalone config

-- file and a project file, so that a sub-parser is not required, which would interfere with

-- warnings for missing fields.

parseConfigMonoidObject :: Path Abs Dir -> Object -> WarningParser ConfigMonoid

parseConfigMonoidObject rootDir obj = do

-- Parsing 'stackRoot' from 'stackRoot'/config.yaml would be nonsensical

let configMonoidStackRoot = First Nothing

configMonoidWorkDir <- First <$> obj ..:? configMonoidWorkDirName

configMonoidBuildOpts <- jsonSubWarnings (obj ..:? configMonoidBuildOptsName ..!= mempty)

configMonoidDockerOpts <- jsonSubWarnings (obj ..:? configMonoidDockerOptsName ..!= mempty)

configMonoidNixOpts <- jsonSubWarnings (obj ..:? configMonoidNixOptsName ..!= mempty)

configMonoidConnectionCount <- First <$> obj ..:? configMonoidConnectionCountName

configMonoidHideTHLoading <- First <$> obj ..:? configMonoidHideTHLoadingName

configMonoidLatestSnapshotUrl <- First <$> obj ..:? configMonoidLatestSnapshotUrlName

configMonoidUrls <- jsonSubWarnings (obj ..:? configMonoidUrlsName ..!= mempty)

configMonoidPackageIndices <- First <$> jsonSubWarningsTT (obj ..:? configMonoidPackageIndicesName)

configMonoidSystemGHC <- First <$> obj ..:? configMonoidSystemGHCName

configMonoidInstallGHC <- First <$> obj ..:? configMonoidInstallGHCName

configMonoidSkipGHCCheck <- First <$> obj ..:? configMonoidSkipGHCCheckName

configMonoidSkipMsys <- First <$> obj ..:? configMonoidSkipMsysName

configMonoidRequireStackVersion <- IntersectingVersionRange . unVersionRangeJSON <$> (

obj ..:? configMonoidRequireStackVersionName

..!= VersionRangeJSON anyVersion)

configMonoidArch <- First <$> obj ..:? configMonoidArchName

configMonoidGHCVariant <- First <$> obj ..:? configMonoidGHCVariantName

configMonoidGHCBuild <- First <$> obj ..:? configMonoidGHCBuildName

configMonoidJobs <- First <$> obj ..:? configMonoidJobsName

configMonoidExtraIncludeDirs <- fmap (Set.map (toFilePath rootDir FilePath.</>)) $

obj ..:? configMonoidExtraIncludeDirsName ..!= Set.empty

configMonoidExtraLibDirs <- fmap (Set.map (toFilePath rootDir FilePath.</>)) $

obj ..:? configMonoidExtraLibDirsName ..!= Set.empty

configMonoidOverrideGccPath <- First <$> obj ..:? configMonoidOverrideGccPathName

configMonoidOverrideHpack <- First <$> obj ..:? configMonoidOverrideHpackName

configMonoidConcurrentTests <- First <$> obj ..:? configMonoidConcurrentTestsName

configMonoidLocalBinPath <- First <$> obj ..:? configMonoidLocalBinPathName

configMonoidImageOpts <- jsonSubWarnings (obj ..:? configMonoidImageOptsName ..!= mempty)

templates <- obj ..:? "templates"

(configMonoidScmInit,configMonoidTemplateParameters) <-

case templates of

Nothing -> return (First Nothing,M.empty)

Just tobj -> do

scmInit <- tobj ..:? configMonoidScmInitName

params <- tobj ..:? configMonoidTemplateParametersName

return (First scmInit,fromMaybe M.empty params)

configMonoidCompilerCheck <- First <$> obj ..:? configMonoidCompilerCheckName

options <- Map.map unGhcOptions <$> obj ..:? configMonoidGhcOptionsName ..!= mempty

optionsEverything <-

case (Map.lookup GOKOldEverything options, Map.lookup GOKEverything options) of

(Just _, Just _) -> fail "Cannot specify both `*` and `$everything` GHC options"

(Nothing, Just x) -> return x

(Just x, Nothing) -> do

tell "The `*` ghc-options key is not recommended. Consider using $locals, or if really needed, $everything"

return x

(Nothing, Nothing) -> return []

let configMonoidGhcOptionsByCat = Map.fromList

[ (AGOEverything, optionsEverything)

, (AGOLocals, Map.findWithDefault [] GOKLocals options)

, (AGOTargets, Map.findWithDefault [] GOKTargets options)

]

configMonoidGhcOptionsByName = Map.fromList

[(name, opts) | (GOKPackage name, opts) <- Map.toList options]

configMonoidExtraPath <- obj ..:? configMonoidExtraPathName ..!= []

configMonoidSetupInfoLocations <-

maybeToList <$> jsonSubWarningsT (obj ..:? configMonoidSetupInfoLocationsName)

configMonoidLocalProgramsBase <- First <$> obj ..:? configMonoidLocalProgramsBaseName

configMonoidPvpBounds <- First <$> obj ..:? configMonoidPvpBoundsName

configMonoidModifyCodePage <- First <$> obj ..:? configMonoidModifyCodePageName

configMonoidExplicitSetupDeps <-

(obj ..:? configMonoidExplicitSetupDepsName ..!= mempty)

>>= fmap Map.fromList . mapM handleExplicitSetupDep . Map.toList

configMonoidRebuildGhcOptions <- First <$> obj ..:? configMonoidRebuildGhcOptionsName

configMonoidApplyGhcOptions <- First <$> obj ..:? configMonoidApplyGhcOptionsName

configMonoidAllowNewer <- First <$> obj ..:? configMonoidAllowNewerName

configMonoidDefaultTemplate <- First <$> obj ..:? configMonoidDefaultTemplateName

configMonoidAllowDifferentUser <- First <$> obj ..:? configMonoidAllowDifferentUserName

configMonoidDumpLogs <- First <$> obj ..:? configMonoidDumpLogsName

configMonoidSaveHackageCreds <- First <$> obj ..:? configMonoidSaveHackageCredsName

configMonoidIgnoreRevisionMismatch <- First <$> obj ..:? configMonoidIgnoreRevisionMismatchName

return ConfigMonoid {..}

where

handleExplicitSetupDep :: Monad m => (Text, Bool) -> m (Maybe PackageName, Bool)

handleExplicitSetupDep (name', b) = do

name <-

if name' == "*"

then return Nothing

else case parsePackageNameFromString $ T.unpack name' of

Left e -> fail $ show e

Right x -> return $ Just x

return (name, b)

configMonoidWorkDirName :: Text

configMonoidWorkDirName = "work-dir"

configMonoidBuildOptsName :: Text

configMonoidBuildOptsName = "build"

configMonoidDockerOptsName :: Text

configMonoidDockerOptsName = "docker"

configMonoidNixOptsName :: Text

configMonoidNixOptsName = "nix"

configMonoidConnectionCountName :: Text

configMonoidConnectionCountName = "connection-count"

configMonoidHideTHLoadingName :: Text

configMonoidHideTHLoadingName = "hide-th-loading"

configMonoidLatestSnapshotUrlName :: Text

configMonoidLatestSnapshotUrlName = "latest-snapshot-url"

configMonoidUrlsName :: Text

configMonoidUrlsName = "urls"

configMonoidPackageIndicesName :: Text

configMonoidPackageIndicesName = "package-indices"

configMonoidSystemGHCName :: Text

configMonoidSystemGHCName = "system-ghc"

configMonoidInstallGHCName :: Text

configMonoidInstallGHCName = "install-ghc"

configMonoidSkipGHCCheckName :: Text

configMonoidSkipGHCCheckName = "skip-ghc-check"

configMonoidSkipMsysName :: Text

configMonoidSkipMsysName = "skip-msys"

configMonoidRequireStackVersionName :: Text

configMonoidRequireStackVersionName = "require-stack-version"

configMonoidArchName :: Text

configMonoidArchName = "arch"

configMonoidGHCVariantName :: Text

configMonoidGHCVariantName = "ghc-variant"

configMonoidGHCBuildName :: Text

configMonoidGHCBuildName = "ghc-build"

configMonoidJobsName :: Text

configMonoidJobsName = "jobs"

configMonoidExtraIncludeDirsName :: Text

configMonoidExtraIncludeDirsName = "extra-include-dirs"

configMonoidExtraLibDirsName :: Text

configMonoidExtraLibDirsName = "extra-lib-dirs"

configMonoidOverrideGccPathName :: Text

configMonoidOverrideGccPathName = "with-gcc"

configMonoidOverrideHpackName :: Text

configMonoidOverrideHpackName = "with-hpack"

configMonoidConcurrentTestsName :: Text

configMonoidConcurrentTestsName = "concurrent-tests"

configMonoidLocalBinPathName :: Text

configMonoidLocalBinPathName = "local-bin-path"

configMonoidImageOptsName :: Text

configMonoidImageOptsName = "image"

configMonoidScmInitName :: Text

configMonoidScmInitName = "scm-init"

configMonoidTemplateParametersName :: Text

configMonoidTemplateParametersName = "params"

configMonoidCompilerCheckName :: Text

configMonoidCompilerCheckName = "compiler-check"

configMonoidGhcOptionsName :: Text

configMonoidGhcOptionsName = "ghc-options"

configMonoidExtraPathName :: Text

configMonoidExtraPathName = "extra-path"

configMonoidSetupInfoLocationsName :: Text

configMonoidSetupInfoLocationsName = "setup-info"

configMonoidLocalProgramsBaseName :: Text

configMonoidLocalProgramsBaseName = "local-programs-path"

configMonoidPvpBoundsName :: Text

configMonoidPvpBoundsName = "pvp-bounds"

configMonoidModifyCodePageName :: Text

configMonoidModifyCodePageName = "modify-code-page"

configMonoidExplicitSetupDepsName :: Text

configMonoidExplicitSetupDepsName = "explicit-setup-deps"

configMonoidRebuildGhcOptionsName :: Text

configMonoidRebuildGhcOptionsName = "rebuild-ghc-options"

configMonoidApplyGhcOptionsName :: Text

configMonoidApplyGhcOptionsName = "apply-ghc-options"

configMonoidAllowNewerName :: Text

configMonoidAllowNewerName = "allow-newer"

configMonoidDefaultTemplateName :: Text

configMonoidDefaultTemplateName = "default-template"

configMonoidAllowDifferentUserName :: Text

configMonoidAllowDifferentUserName = "allow-different-user"

configMonoidDumpLogsName :: Text

configMonoidDumpLogsName = "dump-logs"

configMonoidSaveHackageCredsName :: Text