{-# LANGUAGE ConstraintKinds #-}

{-# LANGUAGE DataKinds #-}

{-# LANGUAGE DefaultSignatures #-}

{-# LANGUAGE DeriveDataTypeable #-}

{-# LANGUAGE DeriveGeneric #-}

{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE FlexibleInstances #-}

{-# LANGUAGE GADTs #-}

{-# LANGUAGE MultiParamTypeClasses #-}

{-# LANGUAGE MultiWayIf #-}

{-# LANGUAGE NoImplicitPrelude #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE RecordWildCards #-}

{-# LANGUAGE ScopedTypeVariables #-}

{-# LANGUAGE TypeFamilies #-}

{-# LANGUAGE ViewPatterns #-}

-- | The Config type.

module Stack.Types.Config

(

-- * Main configuration types and classes

-- ** HasPlatform & HasStackRoot

HasPlatform(..)

,PlatformVariant(..)

-- ** Runner

,HasRunner(..)

,Runner(..)

,ColorWhen(..)

,terminalL

,reExecL

-- ** Config & HasConfig

,Config(..)

,HasConfig(..)

,askLatestSnapshotUrl

,configProjectRoot

-- ** BuildConfig & HasBuildConfig

,BuildConfig(..)

,ProjectPackage(..)

,DepPackage(..)

,ppRoot

,ppVersion

,ppComponents

,ppGPD

,stackYamlL

,projectRootL

,HasBuildConfig(..)

-- ** Storage databases

,UserStorage(..)

,ProjectStorage(..)

-- ** GHCVariant & HasGHCVariant

,GHCVariant(..)

,ghcVariantName

,ghcVariantSuffix

,parseGHCVariant

,HasGHCVariant(..)

,snapshotsDir

-- ** EnvConfig & HasEnvConfig

,EnvConfig(..)

,HasSourceMap(..)

,HasEnvConfig(..)

,getCompilerPath

-- * Details

-- ** ApplyGhcOptions

,ApplyGhcOptions(..)

-- ** CabalConfigKey

,CabalConfigKey(..)

-- ** ConfigException

,HpackExecutable(..)

,ConfigException(..)

-- ** ConfigMonoid

,ConfigMonoid(..)

,configMonoidInstallGHCName

,configMonoidSystemGHCName

,parseConfigMonoid

-- ** DumpLogs

,DumpLogs(..)

-- ** EnvSettings

,EnvSettings(..)

,minimalEnvSettings

,defaultEnvSettings

,plainEnvSettings

-- ** GlobalOpts & GlobalOptsMonoid

,GlobalOpts(..)

,GlobalOptsMonoid(..)

,StackYamlLoc(..)

,stackYamlLocL

,LockFileBehavior(..)

,readLockFileBehavior

,lockFileBehaviorL

,defaultLogLevel

-- ** Project & ProjectAndConfigMonoid

,Project(..)

,ProjectConfig(..)

,Curator(..)

,ProjectAndConfigMonoid(..)

,parseProjectAndConfigMonoid

-- ** PvpBounds

,PvpBounds(..)

,PvpBoundsType(..)

,parsePvpBounds

-- ** ColorWhen

,readColorWhen

-- ** Styles

,readStyles

-- ** SCM

,SCM(..)

-- * Paths

,bindirSuffix

,GlobalInfoSource(..)

,getProjectWorkDir

,docDirSuffix

,extraBinDirs

,hpcReportDir

,installationRootDeps

,installationRootLocal

,bindirCompilerTools

,hoogleRoot

,hoogleDatabasePath

,packageDatabaseDeps

,packageDatabaseExtra

,packageDatabaseLocal

,platformOnlyRelDir

,platformGhcRelDir

,platformGhcVerOnlyRelDir

,useShaPathOnWindows

,shaPath

,shaPathForBytes

,workDirL

-- * Command-specific types

-- ** Eval

,EvalOpts(..)

-- ** Exec

,ExecOpts(..)

,SpecialExecCmd(..)

,ExecOptsExtra(..)

-- ** Setup

,DownloadInfo(..)

,VersionedDownloadInfo(..)

,GHCDownloadInfo(..)

,SetupInfo(..)

-- ** Docker entrypoint

,DockerEntrypoint(..)

,DockerUser(..)

,module X

-- * Lens helpers

,wantedCompilerVersionL

,actualCompilerVersionL

,HasCompiler(..)

,DumpPackage(..)

,CompilerPaths(..)

,GhcPkgExe(..)

,getGhcPkgExe

,cpWhich

,ExtraDirs(..)

,buildOptsL

,globalOptsL

,buildOptsInstallExesL

,buildOptsMonoidHaddockL

,buildOptsMonoidTestsL

,buildOptsMonoidBenchmarksL

,buildOptsMonoidInstallExesL

,buildOptsHaddockL

,globalOptsBuildOptsMonoidL

,stackRootL

,cabalVersionL

,whichCompilerL

,envOverrideSettingsL

,shouldForceGhcColorFlag

,appropriateGhcColorFlag

-- * Helper logging functions

,prettyStackDevL

-- * Lens reexport

,view

,to

) where

import Control.Monad.Writer (tell)

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

import Stack.Prelude

import Pantry.Internal.AesonExtended

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

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

withObjectWarnings, WarningParser, Object, jsonSubWarnings,

jsonSubWarningsT, jsonSubWarningsTT, WithJSONWarnings(..),

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.Coerce (coerce)

import Data.List (stripPrefix)

import qualified Data.List.NonEmpty as NonEmpty

import qualified Data.Map as Map

import qualified Data.Map.Strict as M

import qualified Data.Monoid as Monoid

import Data.Monoid.Map (MonoidMap(..))

import qualified Data.Set as Set

import qualified Data.Text as T

import Data.Yaml (ParseException)

import qualified Data.Yaml as Yaml

import qualified Distribution.License as C

import Distribution.ModuleName (ModuleName)

import Distribution.PackageDescription (GenericPackageDescription)

import qualified Distribution.PackageDescription as C

import Distribution.System (Platform, Arch)

import qualified Distribution.Text

import qualified Distribution.Types.UnqualComponentName as C

import Distribution.Version (anyVersion, mkVersion', mkVersion)

import Generics.Deriving.Monoid (memptydefault, mappenddefault)

import Lens.Micro

import Options.Applicative (ReadM)

import qualified Options.Applicative as OA

import qualified Options.Applicative.Types as OA

import Pantry.Internal (Storage)

import Path

import qualified Paths_stack as Meta

import qualified RIO.List as List

import RIO.PrettyPrint (HasTerm (..), StyleDoc, prettyWarnL, prettyDebugL)

import RIO.PrettyPrint.StylesUpdate (StylesUpdate,

parseStylesUpdateFromString, HasStylesUpdate (..))

import Stack.Constants

import Stack.Types.Compiler

import Stack.Types.CompilerBuild

import Stack.Types.Docker

import Stack.Types.GhcPkgId

import Stack.Types.NamedComponent

import Stack.Types.Nix

import Stack.Types.Resolver

import Stack.Types.SourceMap

import Stack.Types.TemplateName

import Stack.Types.Version

import qualified System.FilePath as FilePath

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

import RIO.Process (ProcessContext, HasProcessContext (..))

import Casa.Client (CasaRepoPrefix)

-- Re-exports

import Stack.Types.Config.Build as X

-- | The base environment that almost everything in Stack runs in,

-- based off of parsing command line options in 'GlobalOpts'. Provides

-- logging and process execution.

data Runner = Runner

{ runnerGlobalOpts :: !GlobalOpts

, runnerUseColor :: !Bool

, runnerLogFunc :: !LogFunc

, runnerTermWidth :: !Int

, runnerProcessContext :: !ProcessContext

}

data ColorWhen = ColorNever | ColorAlways | ColorAuto

deriving (Eq, Show, Generic)

instance FromJSON ColorWhen where

parseJSON v = do

s <- parseJSON v

case s of

"never" -> return ColorNever

"always" -> return ColorAlways

"auto" -> return ColorAuto

_ -> fail ("Unknown color use: " <> s <> ". Expected values of " <>

"option are 'never', 'always', or 'auto'.")

-- | 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

,configProcessContextSettings :: !(EnvSettings -> IO ProcessContext)

-- ^ 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

,configPrefixTimestamps :: !Bool

-- ^ Prefix build output with timestamps for each line.

,configPlatform :: !Platform

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

,configPlatformVariant :: !PlatformVariant

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

,configGHCVariant :: !(Maybe GHCVariant)

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

,configGHCBuild :: !(Maybe CompilerBuild)

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

,configLatestSnapshot :: !Text

-- ^ URL of a JSON file providing the latest LTS and Nightly snapshots.

,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.

,configCompilerRepository :: !CompilerRepository

-- ^ Specifies the repository containing the compiler sources

,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

,configExtraIncludeDirs :: ![FilePath]

-- ^ --extra-include-dirs arguments

,configExtraLibDirs :: ![FilePath]

-- ^ --extra-lib-dirs arguments

,configConcurrentTests :: !Bool

-- ^ Run test suites concurrently

,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

,configCabalConfigOpts :: !(Map CabalConfigKey [Text])

-- ^ Additional options to be passed to ./Setup.hs configure

,configSetupInfoLocations :: ![String]

-- ^ URLs or paths to stack-setup.yaml files, for finding tools.

-- If none present, the default setup-info is used.

,configSetupInfoInline :: !SetupInfo

-- ^ Additional SetupInfo 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

,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.

,configProject :: !(ProjectConfig (Project, Path Abs File))

-- ^ Project information and stack.yaml file location

,configAllowLocals :: !Bool

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

-- command disallows this.

,configSaveHackageCreds :: !Bool

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

,configHackageBaseUrl :: !Text

-- ^ Hackage base URL used when uploading packages

,configRunner :: !Runner

,configPantryConfig :: !PantryConfig

,configStackRoot :: !(Path Abs Dir)

,configResolver :: !(Maybe AbstractResolver)

-- ^ Any resolver override from the command line

,configUserStorage :: !UserStorage

-- ^ Database connection pool for user Stack database

,configHideSourcePaths :: !Bool

-- ^ Enable GHC hiding source paths?

,configRecommendUpgrade :: !Bool

-- ^ Recommend a Stack upgrade?

,configStackDeveloperMode :: !Bool

-- ^ Turn on Stack developer mode for additional messages?

}

-- | A bit of type safety to ensure we're talking to the right database.

newtype UserStorage = UserStorage

{ unUserStorage :: Storage

}

-- | A bit of type safety to ensure we're talking to the right database.

newtype ProjectStorage = ProjectStorage

{ unProjectStorage :: Storage

}

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

configProjectRoot :: Config -> Maybe (Path Abs Dir)

configProjectRoot c =

case configProject c of

PCProject (_, fp) -> Just $ parent fp

PCGlobalProject -> Nothing

PCNoProject _deps -> Nothing

-- | Which packages do configure opts apply to?

data CabalConfigKey

= CCKTargets -- ^ See AGOTargets

| CCKLocals -- ^ See AGOLocals

| CCKEverything -- ^ See AGOEverything

| CCKPackage !PackageName -- ^ A specific package

deriving (Show, Read, Eq, Ord)

instance FromJSON CabalConfigKey where

parseJSON = withText "CabalConfigKey" parseCabalConfigKey

instance FromJSONKey CabalConfigKey where

fromJSONKey = FromJSONKeyTextParser parseCabalConfigKey

parseCabalConfigKey :: (Monad m, MonadFail m) => Text -> m CabalConfigKey

parseCabalConfigKey "$targets" = pure CCKTargets

parseCabalConfigKey "$locals" = pure CCKLocals

parseCabalConfigKey "$everything" = pure CCKEverything

parseCabalConfigKey name =

case parsePackageName $ T.unpack name of

Nothing -> fail $ "Invalid CabalConfigKey: " ++ show name

Just x -> pure $ CCKPackage x

-- | 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

| ExecRun

| ExecGhc

| ExecRunGhc

deriving (Show, Eq)

data ExecOptsExtra = ExecOptsExtra

{ 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 WantedCompiler) -- ^ Compiler override

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

, globalStylesUpdate :: !StylesUpdate -- ^ SGR (Ansi) codes for styles

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

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

, globalLockFileBehavior :: !LockFileBehavior

} deriving (Show)

-- | Location for the project's stack.yaml file.

data StackYamlLoc

= SYLDefault

-- ^ Use the standard parent-directory-checking logic

| SYLOverride !(Path Abs File)

-- ^ Use a specific stack.yaml file provided

| SYLNoProject ![PackageIdentifierRevision]

-- ^ Do not load up a project, just user configuration. Include

-- the given extra dependencies with the resolver.

| SYLGlobalProject

-- ^ Do not look for a project configuration, and use the implicit global.

deriving Show

stackYamlLocL :: HasRunner env => Lens' env StackYamlLoc

stackYamlLocL = globalOptsL.lens globalStackYaml (\x y -> x { globalStackYaml = y })

-- | How to interact with lock files

data LockFileBehavior

= LFBReadWrite

-- ^ Read and write lock files

| LFBReadOnly

-- ^ Read lock files, but do not write them

| LFBIgnore

-- ^ Entirely ignore lock files

| LFBErrorOnWrite

-- ^ Error out on trying to write a lock file. This can be used to

-- ensure that lock files in a repository already ensure

-- reproducible builds.

deriving (Show, Enum, Bounded)

lockFileBehaviorL :: HasRunner env => SimpleGetter env LockFileBehavior

lockFileBehaviorL = globalOptsL.to globalLockFileBehavior

-- | Parser for 'LockFileBehavior'

readLockFileBehavior :: ReadM LockFileBehavior

readLockFileBehavior = do

s <- OA.readerAsk

case Map.lookup s m of

Just x -> pure x

Nothing -> OA.readerError $ "Invalid lock file behavior, valid options: " ++

List.intercalate ", " (Map.keys m)

where

m = Map.fromList $ map (\x -> (render x, x)) [minBound..maxBound]

render LFBReadWrite = "read-write"

render LFBReadOnly = "read-only"

render LFBIgnore = "ignore"

render LFBErrorOnWrite = "error-on-write"

-- | Project configuration information. Not every run of Stack has a

-- true local project; see constructors below.

data ProjectConfig a

= PCProject a

-- ^ Normal run: we want a project, and have one. This comes from

-- either 'SYLDefault' or 'SYLOverride'.

| PCGlobalProject

-- ^ No project was found when using 'SYLDefault'. Instead, use

-- the implicit global.

| PCNoProject ![PackageIdentifierRevision]

-- ^ Use a no project run. This comes from 'SYLNoProject'.

-- | 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 :: !FirstTrue -- ^ Whether to include timings in logs.

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

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

, globalMonoidResolverRoot :: !(First FilePath) -- ^ root directory for resolver relative path

, globalMonoidCompiler :: !(First WantedCompiler) -- ^ Compiler override

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

, globalMonoidStyles :: !StylesUpdate -- ^ Stack's output styles

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

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

, globalMonoidLockFileBehavior :: !(First LockFileBehavior) -- ^ See 'globalLockFileBehavior'

} deriving Generic

instance Semigroup GlobalOptsMonoid where

(<>) = mappenddefault

instance Monoid GlobalOptsMonoid where

mempty = memptydefault

mappend = (<>)

-- | 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'."

readStyles :: ReadM StylesUpdate

readStyles = parseStylesUpdateFromString <$> OA.readerAsk

-- | 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

, bcSMWanted :: !SMWanted

, 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" if a different file

-- name is used.

, bcProjectStorage :: !ProjectStorage

-- ^ Database connection pool for project Stack database

, bcCurator :: !(Maybe Curator)

}

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

,envConfigBuildOptsCLI :: !BuildOptsCLI

,envConfigSourceMap :: !SourceMap

,envConfigSourceMapHash :: !SourceMapHash

,envConfigCompilerPaths :: !CompilerPaths

}

ppGPD :: MonadIO m => ProjectPackage -> m GenericPackageDescription

ppGPD = liftIO . cpGPD . ppCommon

-- | Root directory for the given 'ProjectPackage'

ppRoot :: ProjectPackage -> Path Abs Dir

ppRoot = parent . ppCabalFP

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

ppComponents :: MonadIO m => ProjectPackage -> m (Set NamedComponent)

ppComponents pp = do

gpd <- ppGPD pp

pure $ Set.fromList $ concat

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

, go CExe (fst <$> C.condExecutables gpd)

, go CTest (fst <$> C.condTestSuites gpd)

, go CBench (fst <$> C.condBenchmarks gpd)

]

where

go :: (T.Text -> NamedComponent)

-> [C.UnqualComponentName]

-> [NamedComponent]

go wrapper = map (wrapper . T.pack . C.unUnqualComponentName)

-- | Version for the given 'ProjectPackage

ppVersion :: MonadIO m => ProjectPackage -> m Version

ppVersion = fmap gpdVersion . ppGPD

-- | 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 :: ![RelFilePath]

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

-- to dependencies).

, projectDependencies :: ![RawPackageLocation]

-- ^ 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 :: !RawSnapshotLocation

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

, projectCompiler :: !(Maybe WantedCompiler)

-- ^ Override the compiler in 'projectResolver'

, projectExtraPackageDBs :: ![FilePath]

, projectCurator :: !(Maybe Curator)

-- ^ Extra configuration intended exclusively for usage by the

-- curator tool. In other words, this is /not/ part of the

-- documented and exposed Stack API. SUBJECT TO CHANGE.

, projectDropPackages :: !(Set PackageName)

-- ^ Packages to drop from the 'projectResolver'.

}

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 mcompiler extraPackageDBs mcurator drops) = object $ concat

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

, 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" .= fmap toCabalStringMap (toCabalStringMap flags)]

, ["packages" .= packages]

, ["resolver" .= resolver]

, maybe [] (\c -> ["curator" .= c]) mcurator

, if Set.null drops then [] else ["drop-packages" .= Set.map CabalString drops]

]

-- | Extra configuration intended exclusively for usage by the

-- curator tool. In other words, this is /not/ part of the

-- documented and exposed Stack API. SUBJECT TO CHANGE.

data Curator = Curator

{ curatorSkipTest :: !(Set PackageName)

, curatorExpectTestFailure :: !(Set PackageName)

, curatorSkipBenchmark :: !(Set PackageName)

, curatorExpectBenchmarkFailure :: !(Set PackageName)

, curatorSkipHaddock :: !(Set PackageName)

, curatorExpectHaddockFailure :: !(Set PackageName)

}

deriving Show

instance ToJSON Curator where

toJSON c = object

[ "skip-test" .= Set.map CabalString (curatorSkipTest c)

, "expect-test-failure" .= Set.map CabalString (curatorExpectTestFailure c)

, "skip-bench" .= Set.map CabalString (curatorSkipBenchmark c)

, "expect-benchmark-failure" .= Set.map CabalString (curatorExpectTestFailure c)

, "skip-haddock" .= Set.map CabalString (curatorSkipHaddock c)

, "expect-test-failure" .= Set.map CabalString (curatorExpectHaddockFailure c)

]

instance FromJSON (WithJSONWarnings Curator) where

parseJSON = withObjectWarnings "Curator" $ \o -> Curator

<$> fmap (Set.map unCabalString) (o ..:? "skip-test" ..!= mempty)

<*> fmap (Set.map unCabalString) (o ..:? "expect-test-failure" ..!= mempty)

<*> fmap (Set.map unCabalString) (o ..:? "skip-bench" ..!= mempty)

<*> fmap (Set.map unCabalString) (o ..:? "expect-benchmark-failure" ..!= mempty)

<*> fmap (Set.map unCabalString) (o ..:? "skip-haddock" ..!= mempty)

<*> fmap (Set.map unCabalString) (o ..:? "expect-haddock-failure" ..!= mempty)

-- 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 :: !FirstTrue

-- ^ See: 'configHideTHLoading'

, configMonoidPrefixTimestamps :: !(First Bool)

-- ^ See: 'configPrefixTimestamps'

, configMonoidLatestSnapshot :: !(First Text)

-- ^ See: 'configLatestSnapshot'

, configMonoidPackageIndices :: !(First [HackageSecurityConfig])

-- ^ See: @picIndices@

, configMonoidSystemGHC :: !(First Bool)

-- ^ See: 'configSystemGHC'

,configMonoidInstallGHC :: !FirstTrue

-- ^ See: 'configInstallGHC'

,configMonoidSkipGHCCheck :: !FirstFalse

-- ^ See: 'configSkipGHCCheck'

,configMonoidSkipMsys :: !FirstFalse

-- ^ See: 'configSkipMsys'

,configMonoidCompilerCheck :: !(First VersionCheck)

-- ^ See: 'configCompilerCheck'

,configMonoidCompilerRepository :: !(First CompilerRepository)

-- ^ See: 'configCompilerRepository'

,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 :: ![FilePath]

-- ^ See: 'configExtraIncludeDirs'

,configMonoidExtraLibDirs :: ![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

,configMonoidTemplateParameters :: !(Map Text Text)

-- ^ Template parameters.

,configMonoidScmInit :: !(First SCM)

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

,configMonoidGhcOptionsByName :: !(MonoidMap PackageName (Monoid.Dual [Text]))

-- ^ See 'configGhcOptionsByName'. Uses 'Monoid.Dual' so that

-- options from the configs on the right come first, so that they

-- can be overridden.

,configMonoidGhcOptionsByCat :: !(MonoidMap ApplyGhcOptions (Monoid.Dual [Text]))

-- ^ See 'configGhcOptionsAll'. Uses 'Monoid.Dual' so that options

-- from the configs on the right come first, so that they can be

-- overridden.

,configMonoidCabalConfigOpts :: !(MonoidMap CabalConfigKey (Monoid.Dual [Text]))

-- ^ See 'configCabalConfigOpts'.

,configMonoidExtraPath :: ![Path Abs Dir]

-- ^ Additional paths to search for executables in

,configMonoidSetupInfoLocations :: ![String]

-- ^ See 'configSetupInfoLocations'

,configMonoidSetupInfoInline :: !SetupInfo

-- ^ See 'configSetupInfoInline'

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

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

,configMonoidPvpBounds :: !(First PvpBounds)

-- ^ See 'configPvpBounds'

,configMonoidModifyCodePage :: !FirstTrue

-- ^ See 'configModifyCodePage'

,configMonoidRebuildGhcOptions :: !FirstFalse

-- ^ 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'

, configMonoidHackageBaseUrl :: !(First Text)

-- ^ See 'configHackageBaseUrl'

, configMonoidColorWhen :: !(First ColorWhen)

-- ^ When to use 'ANSI' colors

, configMonoidStyles :: !StylesUpdate

, configMonoidHideSourcePaths :: !FirstTrue

-- ^ See 'configHideSourcePaths'

, configMonoidRecommendUpgrade :: !FirstTrue

-- ^ See 'configRecommendUpgrade'

, configMonoidCasaRepoPrefix :: !(First CasaRepoPrefix)

, configMonoidSnapshotLocation :: !(First Text)

-- ^ Custom location of LTS/Nightly snapshots

, configMonoidStackDeveloperMode :: !(First Bool)

-- ^ See 'configStackDeveloperMode'

}

deriving (Show, Generic)

instance Semigroup ConfigMonoid where

(<>) = mappenddefault

instance Monoid ConfigMonoid where

mempty = memptydefault

mappend = (<>)

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 <- FirstTrue <$> obj ..:? configMonoidHideTHLoadingName

configMonoidPrefixTimestamps <- First <$> obj ..:? configMonoidPrefixTimestampsName

murls :: Maybe Value <- obj ..:? configMonoidUrlsName

configMonoidLatestSnapshot <-

case murls of

Nothing -> pure $ First Nothing

Just urls -> jsonSubWarnings $ lift $ withObjectWarnings

"urls"

(\o -> First <$> o ..:? "latest-snapshot" :: WarningParser (First Text))

urls

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

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

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

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

configMonoidSkipMsys <- FirstFalse <$> 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 <- map (toFilePath rootDir FilePath.</>) <$>

obj ..:? configMonoidExtraIncludeDirsName ..!= []

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

obj ..:? configMonoidExtraLibDirsName ..!= []

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

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

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

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

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

configMonoidCompilerRepository <- First <$> (obj ..:? configMonoidCompilerRepositoryName)

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 = coerce $ Map.fromList

[ (AGOEverything, optionsEverything)

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

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

]

configMonoidGhcOptionsByName = coerce $ Map.fromList

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

configMonoidCabalConfigOpts' <- obj ..:? "configure-options" ..!= mempty

let configMonoidCabalConfigOpts = coerce (configMonoidCabalConfigOpts' :: Map CabalConfigKey [Text])

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

configMonoidSetupInfoLocations <- obj ..:? configMonoidSetupInfoLocationsName ..!= []

configMonoidSetupInfoInline <- jsonSubWarningsT (obj ..:? configMonoidSetupInfoInlineName) ..!= mempty

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

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

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

configMonoidRebuildGhcOptions <- FirstFalse <$> 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

configMonoidHackageBaseUrl <- First <$> obj ..:? configMonoidHackageBaseUrlName

configMonoidColorWhenUS <- obj ..:? configMonoidColorWhenUSName

configMonoidColorWhenGB <- obj ..:? configMonoidColorWhenGBName

let configMonoidColorWhen = First $ configMonoidColorWhenUS

<|> configMonoidColorWhenGB

configMonoidStylesUS <- obj ..:? configMonoidStylesUSName

configMonoidStylesGB <- obj ..:? configMonoidStylesGBName

let configMonoidStyles = fromMaybe mempty $ configMonoidStylesUS

<|> configMonoidStylesGB

configMonoidHideSourcePaths <- FirstTrue <$> obj ..:? configMonoidHideSourcePathsName

configMonoidRecommendUpgrade <- FirstTrue <$> obj ..:? configMonoidRecommendUpgradeName

configMonoidCasaRepoPrefix <- First <$> obj ..:? configMonoidCasaRepoPrefixName

configMonoidSnapshotLocation <- First <$> obj ..:? configMonoidSnapshotLocationName

configMonoidStackDeveloperMode <- First <$> obj ..:? configMonoidStackDeveloperModeName

return ConfigMonoid {..}

configMonoidWorkDirName :: Text

configMonoidWorkDirName = "work-dir"

configMonoidBuildOptsName :: Text

configMonoidBuildOptsName = "build"

configMonoidDockerOptsName :: Text

configMonoidDockerOptsName = "docker"

configMonoidNixOptsName :: Text