{-# LANGUAGE CPP #-}

{-# LANGUAGE DefaultSignatures #-}

{-# LANGUAGE DeriveDataTypeable #-}

{-# LANGUAGE DeriveGeneric #-}

{-# LANGUAGE FlexibleInstances #-}

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

{-# LANGUAGE MultiWayIf #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE TemplateHaskell #-}

{-# LANGUAGE TupleSections #-}

{-# LANGUAGE TypeFamilies #-}

{-# LANGUAGE RecordWildCards #-}

{-# LANGUAGE ScopedTypeVariables #-}

{-# LANGUAGE DataKinds #-}

{-# LANGUAGE GADTs #-}

{-# LANGUAGE StandaloneDeriving #-}

-- | The Config type.

module Stack.Types.Config

(

-- * Main configuration types and classes

-- ** HasPlatform & HasStackRoot

HasPlatform(..)

,HasStackRoot(..)

,PlatformVariant(..)

-- ** Config & HasConfig

,Config(..)

,HasConfig(..)

,askConfig

,askLatestSnapshotUrl

,explicitSetupDeps

,getMinimalEnvOverride

-- ** BuildConfig & HasBuildConfig

,BuildConfig(..)

,bcRoot

,bcWorkDir

,bcWantedCompiler

,HasBuildConfig(..)

-- ** GHCVariant & HasGHCVariant

,GHCVariant(..)

,ghcVariantName

,ghcVariantSuffix

,parseGHCVariant

,HasGHCVariant(..)

,snapshotsDir

-- ** CompilerBuild

,CompilerBuild(..)

,compilerBuildName

,compilerBuildSuffix

,parseCompilerBuild

-- ** EnvConfig & HasEnvConfig

,EnvConfig(..)

,HasEnvConfig(..)

,getWhichCompiler

,getCompilerPath

-- * Details

-- ** ApplyGhcOptions

,ApplyGhcOptions(..)

-- ** ConfigException

,ConfigException(..)

-- ** WhichSolverCmd

,WhichSolverCmd(..)

-- ** ConfigMonoid

,ConfigMonoid(..)

,configMonoidInstallGHCName

,configMonoidSystemGHCName

-- ** DumpLogs

,DumpLogs(..)

-- ** EnvSettings

,EnvSettings(..)

,minimalEnvSettings

-- ** GlobalOpts & GlobalOptsMonoid

,GlobalOpts(..)

,GlobalOptsMonoid(..)

,defaultLogLevel

-- ** LoadConfig

,LoadConfig(..)

-- ** PackageEntry & PackageLocation

,PackageEntry(..)

,TreatLikeExtraDep

,PackageLocation(..)

,RemotePackageType(..)

-- ** PackageIndex, IndexName & IndexLocation

-- Re-exports

,PackageIndex(..)

,IndexName(..)

,indexNameText

,IndexLocation(..)

-- Config fields

,configPackageIndex

,configPackageIndexCache

,configPackageIndexGz

,configPackageIndexRoot

,configPackageIndexRepo

,configPackageTarball

-- ** Project & ProjectAndConfigMonoid

,Project(..)

,ProjectAndConfigMonoid(..)

-- ** PvpBounds

,PvpBounds(..)

,parsePvpBounds

-- ** Resolver & AbstractResolver

,Resolver

,LoadedResolver

,ResolverThat's(..)

,parseResolverText

,resolverDirName

,resolverName

,customResolverHash

,toResolverNotLoaded

,AbstractResolver(..)

,readAbstractResolver

-- ** SCM

,SCM(..)

-- ** CustomSnapshot

,CustomSnapshot(..)

-- ** GhcOptions

,GhcOptions(..)

,ghcOptionsFor

-- ** PackageFlags

,PackageFlags(..)

-- * Paths

,bindirSuffix

,configInstalledCache

,configMiniBuildPlanCache

,getProjectWorkDir

,docDirSuffix

,flagCacheLocal

,extraBinDirs

,hpcReportDir

,installationRootDeps

,installationRootLocal

,hoogleRoot

,hoogleDatabasePath

,packageDatabaseDeps

,packageDatabaseExtra

,packageDatabaseLocal

,platformOnlyRelDir

,platformGhcRelDir

,useShaPathOnWindows

,getWorkDir

-- * Command-specific types

-- ** Eval

,EvalOpts(..)

-- ** Exec

,ExecOpts(..)

,SpecialExecCmd(..)

,ExecOptsExtra(..)

-- ** Setup

,DownloadInfo(..)

,VersionedDownloadInfo(..)

,GHCDownloadInfo(..)

,SetupInfo(..)

,SetupInfoLocation(..)

-- ** Docker entrypoint

,DockerEntrypoint(..)

,DockerUser(..)

,module X

) where

import Control.Applicative

import Control.Arrow ((&&&))

import Control.Exception

import Control.Monad (liftM, mzero, join)

import Control.Monad.Catch (MonadThrow, throwM)

import Control.Monad.Logger (LogLevel(..))

import Control.Monad.Reader (MonadReader, ask, asks, MonadIO, liftIO)

import Data.Aeson.Extended

(ToJSON, toJSON, FromJSON, parseJSON, withText, object,

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

withObjectWarnings, WarningParser, Object, jsonSubWarnings,

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

import Data.Attoparsec.Args

import Data.ByteString (ByteString)

import qualified Data.ByteString.Char8 as S8

import Data.Either (partitionEithers)

import Data.IORef (IORef)

import Data.List (stripPrefix)

import Data.List.NonEmpty (NonEmpty)

import qualified Data.List.NonEmpty as NonEmpty

import Data.Map (Map)

import qualified Data.Map as Map

import qualified Data.Map.Strict as M

import Data.Maybe

import Data.Monoid.Extra

import Data.Set (Set)

import qualified Data.Set as Set

import Data.Text (Text)

import qualified Data.Text as T

import Data.Text.Encoding (encodeUtf8, decodeUtf8)

import Data.Text.Read (decimal)

import Data.Typeable

import Data.Yaml (ParseException)

import qualified Data.Yaml as Yaml

import Distribution.System (Platform)

import qualified Distribution.Text

import Distribution.Version (anyVersion)

import GHC.Generics (Generic)

import Generics.Deriving.Monoid (memptydefault, mappenddefault)

import Network.HTTP.Client (parseRequest)

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.Types.BuildPlan (MiniBuildPlan(..), SnapName, renderSnapName, parseSnapName, SnapshotHash (..), trimmedSnapshotHash)

import Stack.Types.Urls

import Stack.Types.Compiler

import Stack.Types.Docker

import Stack.Types.Nix

import Stack.Types.FlagName

import Stack.Types.Image

import Stack.Types.PackageIdentifier

import Stack.Types.PackageIndex

import Stack.Types.PackageName

import Stack.Types.TemplateName

import Stack.Types.Version

import System.FilePath (takeBaseName)

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

import System.Process.Read (EnvOverride, findExecutable)

-- Re-exports

import Stack.Types.Config.Build as X

#ifdef mingw32_HOST_OS

import qualified Crypto.Hash.SHA1 as SHA1

import qualified Data.ByteString.Base16 as B16

#endif

-- | The top-level Stackage configuration.

data Config =

Config {configStackRoot :: !(Path Abs Dir)

-- ^ ~/.stack more often than not

,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

,configEnvOverride :: !(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)

,configConnectionCount :: !Int

-- ^ How many concurrent connections are allowed when downloading

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

,configPackageIndices :: ![PackageIndex]

-- ^ Information on package indices. This is left biased, meaning that

-- packages in an earlier index will shadow those in a later index.

--

-- Warning: if you override packages in an index vs what's available

-- upstream, you may correct your compiled snapshots, as different

-- projects may have different definitions of what pkg-ver means! This

-- feature is primarily intended for adding local packages, not

-- overriding. Overriding is better accomplished by adding to your

-- list of packages.

--

-- Note that indices specified in a later config file will override

-- previous indices, /not/ extend them.

--

-- Using an assoc list instead of a Map to keep track of priority

,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

,configExtraIncludeDirs :: !(Set (Path Abs Dir))

-- ^ --extra-include-dirs arguments

,configExtraLibDirs :: !(Set (Path Abs Dir))

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

,configGhcOptions :: !GhcOptions

-- ^ Additional GHC options to apply to either all packages (Nothing)

-- or a specific package (Just).

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

,configPackageCaches :: !(IORef (Maybe (Map PackageIdentifier (PackageIndex, PackageCache))))

-- ^ In memory cache of hackage index.

,configDumpLogs :: !DumpLogs

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

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

}

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

}

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]

}

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

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

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

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

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

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

} deriving (Show)

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

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

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

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

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

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

} deriving (Show, Generic)

instance Monoid GlobalOptsMonoid where

mempty = memptydefault

mappend = mappenddefault

-- | Either an actual resolver value, or an abstract description of one (e.g.,

-- latest nightly).

data AbstractResolver

= ARLatestNightly

| ARLatestLTS

| ARLatestLTSMajor !Int

| ARResolver !Resolver

| ARGlobal

deriving Show

readAbstractResolver :: ReadM AbstractResolver

readAbstractResolver = do

s <- OA.readerAsk

case s of

"global" -> return ARGlobal

"nightly" -> return ARLatestNightly

"lts" -> return ARLatestLTS

'l':'t':'s':'-':x | Right (x', "") <- decimal $ T.pack x ->

return $ ARLatestLTSMajor x'

_ ->

case parseResolverText $ T.pack s of

Left e -> OA.readerError $ show e

Right x -> return $ ARResolver x

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

defaultLogLevel :: LogLevel

defaultLogLevel = LevelInfo

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

data BuildConfig = BuildConfig

{ bcConfig :: !Config

, bcResolver :: !LoadedResolver

-- ^ How we resolve which dependencies to install given a set of

-- packages.

, bcWantedMiniBuildPlan :: !MiniBuildPlan

-- ^ Compiler version wanted for this build

, bcPackageEntries :: ![PackageEntry]

-- ^ Local packages

, bcExtraDeps :: !(Map PackageName Version)

-- ^ 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 bcRoot </> "stack.yaml"

, bcFlags :: !PackageFlags

-- ^ Per-package flag overrides

, bcImplicitGlobal :: !Bool

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

-- for providing better error messages.

, bcGHCVariant :: !GHCVariant

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

}

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

bcRoot :: BuildConfig -> Path Abs Dir

bcRoot = parent . bcStackYaml

-- | @"'bcRoot'/.stack-work"@

bcWorkDir :: (MonadReader env m, HasConfig env) => BuildConfig -> m (Path Abs Dir)

bcWorkDir bconfig = do

workDir <- getWorkDir

return (bcRoot bconfig </> workDir)

bcWantedCompiler :: BuildConfig -> CompilerVersion

bcWantedCompiler = mbpCompilerVersion . bcWantedMiniBuildPlan

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

,envConfigCompilerBuild :: !CompilerBuild

,envConfigPackages :: !(Map (Path Abs Dir) TreatLikeExtraDep)}

instance HasBuildConfig EnvConfig where

getBuildConfig = envConfigBuildConfig

instance HasConfig EnvConfig

instance HasPlatform EnvConfig

instance HasGHCVariant EnvConfig

instance HasStackRoot EnvConfig

class (HasBuildConfig r, HasGHCVariant r) => HasEnvConfig r where

getEnvConfig :: r -> EnvConfig

instance HasEnvConfig EnvConfig where

getEnvConfig = id

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

data LoadConfig m = LoadConfig

{ lcConfig :: !Config

-- ^ Top-level Stack configuration.

, lcLoadBuildConfig :: !(Maybe CompilerVersion -> m 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

, peSubdirs :: ![FilePath]

}

deriving Show

-- | Perform defaulting of peExtraDepMaybe

peExtraDepDef :: PackageEntry -> TreatLikeExtraDep

peExtraDepDef = fromMaybe False . peExtraDepMaybe

-- | 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 ToJSON PackageEntry where

toJSON pe | not (peExtraDepDef pe) && null (peSubdirs pe) =

toJSON $ peLocation pe

toJSON pe = object $

maybe id (\e -> (("extra-dep" .= e):)) (peExtraDepMaybe pe)

[ "location" .= peLocation pe

, "subdirs" .= peSubdirs pe

]

instance FromJSON (WithJSONWarnings PackageEntry) where

parseJSON (String t) = do

WithJSONWarnings loc _ <- parseJSON $ String t

return $ noJSONWarnings

PackageEntry

{ peExtraDepMaybe = Nothing

, peLocation = loc

, peSubdirs = []

}

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

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

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

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

data PackageLocation

= PLFilePath FilePath

-- ^ Note that we use @FilePath@ and not @Path@s. The goal is: first parse

-- the value raw, and then use @canonicalizePath@ and @parseAbsDir@.

| PLRemote Text RemotePackageType

-- ^ URL and further details

deriving Show

data RemotePackageType

= RPTHttp

| RPTGit Text -- ^ Commit

| RPTHg Text -- ^ Commit

deriving Show

instance ToJSON PackageLocation where

toJSON (PLFilePath fp) = toJSON fp

toJSON (PLRemote t RPTHttp) = toJSON t

toJSON (PLRemote x (RPTGit y)) = object [("git", toJSON x), ("commit", toJSON y)]

toJSON (PLRemote x (RPTHg y)) = object [( "hg", toJSON x), ("commit", toJSON y)]

instance FromJSON (WithJSONWarnings PackageLocation) where

parseJSON v

= (noJSONWarnings <$> withText "PackageLocation" (\t -> http t <|> file t) v)

<|> git v

<|> hg v

where

file t = pure $ PLFilePath $ T.unpack t

http t =

case parseRequest $ T.unpack t of

Left _ -> mzero

Right _ -> return $ PLRemote t RPTHttp

git = withObjectWarnings "PackageGitLocation" $ \o -> PLRemote

<$> o ..: "git"

<*> (RPTGit <$> o ..: "commit")

hg = withObjectWarnings "PackageHgLocation" $ \o -> PLRemote

<$> o ..: "hg"

<*> (RPTHg <$> o ..: "commit")

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

-- ^ Components of the package list

, projectExtraDeps :: !(Map PackageName Version)

-- ^ Components of the package list referring to package/version combos,

-- see: https://github.com/fpco/stack/issues/41

, projectFlags :: !PackageFlags

-- ^ Per-package flag overrides

, projectResolver :: !Resolver

-- ^ How we resolve which dependencies to use

, projectCompiler :: !(Maybe CompilerVersion)

-- ^ When specified, overrides which compiler to use

, projectExtraPackageDBs :: ![FilePath]

}

deriving Show

instance ToJSON Project where

toJSON p = object $

maybe id (\cv -> (("compiler" .= cv) :)) (projectCompiler p) $

maybe id (\msg -> (("user-message" .= msg) :)) (projectUserMsg p)

[ "packages" .= projectPackages p

, "extra-deps" .= map fromTuple (Map.toList $ projectExtraDeps p)

, "flags" .= projectFlags p

, "resolver" .= projectResolver p

, "extra-package-dbs" .= projectExtraPackageDBs p

]

data IsLoaded = Loaded | NotLoaded

type LoadedResolver = ResolverThat's 'Loaded

type Resolver = ResolverThat's 'NotLoaded

-- TODO: once GHC 8.0 is the lowest version we support, make these into

-- actual haddock comments...

-- | How we resolve which dependencies to install given a set of packages.

data ResolverThat's (l :: IsLoaded) where

-- Use an official snapshot from the Stackage project, either an LTS

-- Haskell or Stackage Nightly.

ResolverSnapshot :: !SnapName -> ResolverThat's l

-- Require a specific compiler version, but otherwise provide no

-- build plan. Intended for use cases where end user wishes to

-- specify all upstream dependencies manually, such as using a

-- dependency solver.

ResolverCompiler :: !CompilerVersion -> ResolverThat's l

-- A custom resolver based on the given name and URL. When a URL is

-- provided, it file is to be completely immutable. Filepaths are

-- always loaded. This constructor is used before the build-plan has

-- been loaded, as we do not yet know the custom snapshot's hash.

ResolverCustom :: !Text -> !Text -> ResolverThat's 'NotLoaded

-- Like 'ResolverCustom', but after loading the build-plan, so we

-- have a hash. This is necessary in order to identify the location

-- files are stored for the resolver.

ResolverCustomLoaded :: !Text -> !Text -> !SnapshotHash -> ResolverThat's 'Loaded

deriving instance Eq (ResolverThat's k)

deriving instance Show (ResolverThat's k)

instance ToJSON (ResolverThat's k) where

toJSON x = case x of

ResolverSnapshot{} -> toJSON $ resolverName x

ResolverCompiler{} -> toJSON $ resolverName x

ResolverCustom n l -> handleCustom n l

ResolverCustomLoaded n l _ -> handleCustom n l

where

handleCustom n l = object

[ "name" .= n

, "location" .= l

]

instance FromJSON (WithJSONWarnings (ResolverThat's 'NotLoaded)) where

-- Strange structuring is to give consistent error messages

parseJSON v@(Object _) = withObjectWarnings "Resolver" (\o -> ResolverCustom

<$> o ..: "name"

<*> o ..: "location") v

parseJSON (String t) = either (fail . show) return (noJSONWarnings <$> parseResolverText t)

parseJSON _ = fail "Invalid Resolver, must be Object or String"

-- | Convert a Resolver into its @Text@ representation, as will be used by

-- directory names

resolverDirName :: LoadedResolver -> Text

resolverDirName (ResolverSnapshot name) = renderSnapName name

resolverDirName (ResolverCompiler v) = compilerVersionText v

resolverDirName (ResolverCustomLoaded name _ hash) = "custom-" <> name <> "-" <> decodeUtf8 (trimmedSnapshotHash hash)

-- | Convert a Resolver into its @Text@ representation for human

-- presentation.

resolverName :: ResolverThat's l -> Text

resolverName (ResolverSnapshot name) = renderSnapName name

resolverName (ResolverCompiler v) = compilerVersionText v

resolverName (ResolverCustom name _) = "custom-" <> name

resolverName (ResolverCustomLoaded name _ _) = "custom-" <> name

customResolverHash :: LoadedResolver-> Maybe SnapshotHash

customResolverHash (ResolverCustomLoaded _ _ hash) = Just hash

customResolverHash _ = Nothing

-- | Try to parse a @Resolver@ from a @Text@. Won't work for complex resolvers (like custom).

parseResolverText :: MonadThrow m => Text -> m Resolver

parseResolverText t

| Right x <- parseSnapName t = return $ ResolverSnapshot x

| Just v <- parseCompilerVersion t = return $ ResolverCompiler v

| otherwise = throwM $ ParseResolverException t

toResolverNotLoaded :: LoadedResolver -> Resolver

toResolverNotLoaded r = case r of

ResolverSnapshot s -> ResolverSnapshot s

ResolverCompiler v -> ResolverCompiler v

ResolverCustomLoaded n l _ -> ResolverCustom n l

-- | Class for environment values which have access to the stack root

class HasStackRoot env where

getStackRoot :: env -> Path Abs Dir

default getStackRoot :: HasConfig env => env -> Path Abs Dir

getStackRoot = configStackRoot . getConfig

{-# INLINE getStackRoot #-}

-- | Class for environment values which have a Platform

class HasPlatform env where

getPlatform :: env -> Platform

default getPlatform :: HasConfig env => env -> Platform

getPlatform = configPlatform . getConfig

{-# INLINE getPlatform #-}

getPlatformVariant :: env -> PlatformVariant

default getPlatformVariant :: HasConfig env => env -> PlatformVariant

getPlatformVariant = configPlatformVariant . getConfig

{-# INLINE getPlatformVariant #-}

instance HasPlatform (Platform,PlatformVariant) where

getPlatform (p,_) = p

getPlatformVariant (_,v) = v

-- | Class for environment values which have a GHCVariant

class HasGHCVariant env where

getGHCVariant :: env -> GHCVariant

default getGHCVariant :: HasBuildConfig env => env -> GHCVariant

getGHCVariant = bcGHCVariant . getBuildConfig

{-# INLINE getGHCVariant #-}

instance HasGHCVariant GHCVariant where

getGHCVariant = id

-- | Class for environment values that can provide a 'Config'.

class (HasStackRoot env, HasPlatform env) => HasConfig env where

getConfig :: env -> Config

default getConfig :: HasBuildConfig env => env -> Config

getConfig = bcConfig . getBuildConfig

{-# INLINE getConfig #-}

instance HasStackRoot Config

instance HasPlatform Config

instance HasConfig Config where

getConfig = id

{-# INLINE getConfig #-}

-- | Class for environment values that can provide a 'BuildConfig'.

class HasConfig env => HasBuildConfig env where

getBuildConfig :: env -> BuildConfig

instance HasStackRoot BuildConfig

instance HasPlatform BuildConfig

instance HasGHCVariant BuildConfig

instance HasConfig BuildConfig

instance HasBuildConfig BuildConfig where

getBuildConfig = id

{-# INLINE getBuildConfig #-}

-- An uninterpreted representation of configuration options.

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

data ConfigMonoid =

ConfigMonoid

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

-- ^ See: 'configStackRoot'

, 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: 'configPackageIndices'

, 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 (Path Abs Dir))

-- ^ See: 'configExtraIncludeDirs'

,configMonoidExtraLibDirs :: !(Set (Path Abs Dir))

-- ^ See: 'configExtraLibDirs'

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

-- ^ Allow users to override the path to gcc

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

,configMonoidGhcOptions :: !GhcOptions

-- ^ See 'configGhcOptions'

,configMonoidExtraPath :: ![Path Abs Dir]

-- ^ Additional paths to search for executables in

,configMonoidSetupInfoLocations :: ![SetupInfoLocation]

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

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

}

deriving (Show, Generic)

instance Monoid ConfigMonoid where

mempty = memptydefault

mappend = mappenddefault

instance FromJSON (WithJSONWarnings ConfigMonoid) where

parseJSON = withObjectWarnings "ConfigMonoid" parseConfigMonoidJSON

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

parseConfigMonoidJSON :: Object -> WarningParser ConfigMonoid

parseConfigMonoidJSON 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 <- obj ..:? configMonoidExtraIncludeDirsName ..!= Set.empty

configMonoidExtraLibDirs <- obj ..:? configMonoidExtraLibDirsName ..!= Set.empty

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

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

configMonoidGhcOptions <- obj ..:? configMonoidGhcOptionsName ..!= mempty

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

configMonoidSetupInfoLocations <-

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

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

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"