1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DefaultSignatures #-}
4{-# LANGUAGE DeriveDataTypeable #-}
5{-# LANGUAGE DeriveGeneric #-}
6{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE GADTs #-}
9{-# LANGUAGE MultiParamTypeClasses #-}
10{-# LANGUAGE MultiWayIf #-}
11{-# LANGUAGE NoImplicitPrelude #-}
12{-# LANGUAGE OverloadedStrings #-}
13{-# LANGUAGE RecordWildCards #-}
14{-# LANGUAGE ScopedTypeVariables #-}
15{-# LANGUAGE TypeFamilies #-}
16{-# LANGUAGE ViewPatterns #-}
17
18-- | The Config type.
19
20module Stack.Types.Config
21  (
22  -- * Main configuration types and classes
23  -- ** HasPlatform & HasStackRoot
24   HasPlatform(..)
25  ,PlatformVariant(..)
26  -- ** Runner
27  ,HasRunner(..)
28  ,Runner(..)
29  ,ColorWhen(..)
30  ,terminalL
31  ,reExecL
32  -- ** Config & HasConfig
33  ,Config(..)
34  ,HasConfig(..)
35  ,askLatestSnapshotUrl
36  ,configProjectRoot
37  -- ** BuildConfig & HasBuildConfig
38  ,BuildConfig(..)
39  ,ProjectPackage(..)
40  ,DepPackage(..)
41  ,ppRoot
42  ,ppVersion
43  ,ppComponents
44  ,ppGPD
45  ,stackYamlL
46  ,projectRootL
47  ,HasBuildConfig(..)
48  -- ** Storage databases
49  ,UserStorage(..)
50  ,ProjectStorage(..)
51  -- ** GHCVariant & HasGHCVariant
52  ,GHCVariant(..)
53  ,ghcVariantName
54  ,ghcVariantSuffix
55  ,parseGHCVariant
56  ,HasGHCVariant(..)
57  ,snapshotsDir
58  -- ** EnvConfig & HasEnvConfig
59  ,EnvConfig(..)
60  ,HasSourceMap(..)
61  ,HasEnvConfig(..)
62  ,getCompilerPath
63  -- * Details
64  -- ** ApplyGhcOptions
65  ,ApplyGhcOptions(..)
66  -- ** CabalConfigKey
67  ,CabalConfigKey(..)
68  -- ** ConfigException
69  ,HpackExecutable(..)
70  ,ConfigException(..)
71  -- ** ConfigMonoid
72  ,ConfigMonoid(..)
73  ,configMonoidInstallGHCName
74  ,configMonoidSystemGHCName
75  ,parseConfigMonoid
76  -- ** DumpLogs
77  ,DumpLogs(..)
78  -- ** EnvSettings
79  ,EnvSettings(..)
80  ,minimalEnvSettings
81  ,defaultEnvSettings
82  ,plainEnvSettings
83  -- ** GlobalOpts & GlobalOptsMonoid
84  ,GlobalOpts(..)
85  ,GlobalOptsMonoid(..)
86  ,StackYamlLoc(..)
87  ,stackYamlLocL
88  ,LockFileBehavior(..)
89  ,readLockFileBehavior
90  ,lockFileBehaviorL
91  ,defaultLogLevel
92  -- ** Project & ProjectAndConfigMonoid
93  ,Project(..)
94  ,ProjectConfig(..)
95  ,Curator(..)
96  ,ProjectAndConfigMonoid(..)
97  ,parseProjectAndConfigMonoid
98  -- ** PvpBounds
99  ,PvpBounds(..)
100  ,PvpBoundsType(..)
101  ,parsePvpBounds
102  -- ** ColorWhen
103  ,readColorWhen
104  -- ** Styles
105  ,readStyles
106  -- ** SCM
107  ,SCM(..)
108  -- * Paths
109  ,bindirSuffix
110  ,GlobalInfoSource(..)
111  ,getProjectWorkDir
112  ,docDirSuffix
113  ,extraBinDirs
114  ,hpcReportDir
115  ,installationRootDeps
116  ,installationRootLocal
117  ,bindirCompilerTools
118  ,hoogleRoot
119  ,hoogleDatabasePath
120  ,packageDatabaseDeps
121  ,packageDatabaseExtra
122  ,packageDatabaseLocal
123  ,platformOnlyRelDir
124  ,platformGhcRelDir
125  ,platformGhcVerOnlyRelDir
126  ,useShaPathOnWindows
127  ,shaPath
128  ,shaPathForBytes
129  ,workDirL
130  -- * Command-specific types
131  -- ** Eval
132  ,EvalOpts(..)
133  -- ** Exec
134  ,ExecOpts(..)
135  ,SpecialExecCmd(..)
136  ,ExecOptsExtra(..)
137  -- ** Setup
138  ,DownloadInfo(..)
139  ,VersionedDownloadInfo(..)
140  ,GHCDownloadInfo(..)
141  ,SetupInfo(..)
142  -- ** Docker entrypoint
143  ,DockerEntrypoint(..)
144  ,DockerUser(..)
145  ,module X
146  -- * Lens helpers
147  ,wantedCompilerVersionL
148  ,actualCompilerVersionL
149  ,HasCompiler(..)
150  ,DumpPackage(..)
151  ,CompilerPaths(..)
152  ,GhcPkgExe(..)
153  ,getGhcPkgExe
154  ,cpWhich
155  ,ExtraDirs(..)
156  ,buildOptsL
157  ,globalOptsL
158  ,buildOptsInstallExesL
159  ,buildOptsMonoidHaddockL
160  ,buildOptsMonoidTestsL
161  ,buildOptsMonoidBenchmarksL
162  ,buildOptsMonoidInstallExesL
163  ,buildOptsHaddockL
164  ,globalOptsBuildOptsMonoidL
165  ,stackRootL
166  ,cabalVersionL
167  ,whichCompilerL
168  ,envOverrideSettingsL
169  ,shouldForceGhcColorFlag
170  ,appropriateGhcColorFlag
171  -- * Helper logging functions
172  ,prettyStackDevL
173  -- * Lens reexport
174  ,view
175  ,to
176  ) where
177
178import           Control.Monad.Writer (tell)
179import           Crypto.Hash (hashWith, SHA1(..))
180import           Stack.Prelude
181import           Pantry.Internal.AesonExtended
182                 (ToJSON, toJSON, FromJSON, FromJSONKey (..), parseJSON, withText, object,
183                  (.=), (..:), (...:), (..:?), (..!=), Value(Bool),
184                  withObjectWarnings, WarningParser, Object, jsonSubWarnings,
185                  jsonSubWarningsT, jsonSubWarningsTT, WithJSONWarnings(..),
186                  FromJSONKeyFunction (FromJSONKeyTextParser))
187import           Data.Attoparsec.Args (parseArgs, EscapingMode (Escaping))
188import qualified Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16))
189import qualified Data.ByteString.Char8 as S8
190import           Data.Coerce (coerce)
191import           Data.List (stripPrefix)
192import qualified Data.List.NonEmpty as NonEmpty
193import qualified Data.Map as Map
194import qualified Data.Map.Strict as M
195import qualified Data.Monoid as Monoid
196import           Data.Monoid.Map (MonoidMap(..))
197import qualified Data.Set as Set
198import qualified Data.Text as T
199import           Data.Yaml (ParseException)
200import qualified Data.Yaml as Yaml
201import qualified Distribution.License as C
202import           Distribution.ModuleName (ModuleName)
203import           Distribution.PackageDescription (GenericPackageDescription)
204import qualified Distribution.PackageDescription as C
205import           Distribution.System (Platform, Arch)
206import qualified Distribution.Text
207import qualified Distribution.Types.UnqualComponentName as C
208import           Distribution.Version (anyVersion, mkVersion', mkVersion)
209import           Generics.Deriving.Monoid (memptydefault, mappenddefault)
210import           Lens.Micro
211import           Options.Applicative (ReadM)
212import qualified Options.Applicative as OA
213import qualified Options.Applicative.Types as OA
214import           Pantry.Internal (Storage)
215import           Path
216import qualified Paths_stack as Meta
217import qualified RIO.List as List
218import           RIO.PrettyPrint (HasTerm (..), StyleDoc, prettyWarnL, prettyDebugL)
219import           RIO.PrettyPrint.StylesUpdate (StylesUpdate,
220                     parseStylesUpdateFromString, HasStylesUpdate (..))
221import           Stack.Constants
222import           Stack.Types.Compiler
223import           Stack.Types.CompilerBuild
224import           Stack.Types.Docker
225import           Stack.Types.GhcPkgId
226import           Stack.Types.NamedComponent
227import           Stack.Types.Nix
228import           Stack.Types.Resolver
229import           Stack.Types.SourceMap
230import           Stack.Types.TemplateName
231import           Stack.Types.Version
232import qualified System.FilePath as FilePath
233import           System.PosixCompat.Types (UserID, GroupID, FileMode)
234import           RIO.Process (ProcessContext, HasProcessContext (..))
235import           Casa.Client (CasaRepoPrefix)
236
237-- Re-exports
238import           Stack.Types.Config.Build as X
239
240-- | The base environment that almost everything in Stack runs in,
241-- based off of parsing command line options in 'GlobalOpts'. Provides
242-- logging and process execution.
243data Runner = Runner
244  { runnerGlobalOpts :: !GlobalOpts
245  , runnerUseColor   :: !Bool
246  , runnerLogFunc    :: !LogFunc
247  , runnerTermWidth  :: !Int
248  , runnerProcessContext :: !ProcessContext
249  }
250
251data ColorWhen = ColorNever | ColorAlways | ColorAuto
252    deriving (Eq, Show, Generic)
253
254instance FromJSON ColorWhen where
255    parseJSON v = do
256        s <- parseJSON v
257        case s of
258            "never"  -> return ColorNever
259            "always" -> return ColorAlways
260            "auto"   -> return ColorAuto
261            _ -> fail ("Unknown color use: " <> s <> ". Expected values of " <>
262                       "option are 'never', 'always', or 'auto'.")
263
264-- | The top-level Stackage configuration.
265data Config =
266  Config {configWorkDir             :: !(Path Rel Dir)
267         -- ^ this allows to override .stack-work directory
268         ,configUserConfigPath      :: !(Path Abs File)
269         -- ^ Path to user configuration file (usually ~/.stack/config.yaml)
270         ,configBuild               :: !BuildOpts
271         -- ^ Build configuration
272         ,configDocker              :: !DockerOpts
273         -- ^ Docker configuration
274         ,configNix                 :: !NixOpts
275         -- ^ Execution environment (e.g nix-shell) configuration
276         ,configProcessContextSettings :: !(EnvSettings -> IO ProcessContext)
277         -- ^ Environment variables to be passed to external tools
278         ,configLocalProgramsBase   :: !(Path Abs Dir)
279         -- ^ Non-platform-specific path containing local installations
280         ,configLocalPrograms       :: !(Path Abs Dir)
281         -- ^ Path containing local installations (mainly GHC)
282         ,configHideTHLoading       :: !Bool
283         -- ^ Hide the Template Haskell "Loading package ..." messages from the
284         -- console
285         ,configPrefixTimestamps    :: !Bool
286         -- ^ Prefix build output with timestamps for each line.
287         ,configPlatform            :: !Platform
288         -- ^ The platform we're building for, used in many directory names
289         ,configPlatformVariant     :: !PlatformVariant
290         -- ^ Variant of the platform, also used in directory names
291         ,configGHCVariant          :: !(Maybe GHCVariant)
292         -- ^ The variant of GHC requested by the user.
293         ,configGHCBuild            :: !(Maybe CompilerBuild)
294         -- ^ Override build of the compiler distribution (e.g. standard, gmp4, tinfo6)
295         ,configLatestSnapshot      :: !Text
296         -- ^ URL of a JSON file providing the latest LTS and Nightly snapshots.
297         ,configSystemGHC           :: !Bool
298         -- ^ Should we use the system-installed GHC (on the PATH) if
299         -- available? Can be overridden by command line options.
300         ,configInstallGHC          :: !Bool
301         -- ^ Should we automatically install GHC if missing or the wrong
302         -- version is available? Can be overridden by command line options.
303         ,configSkipGHCCheck        :: !Bool
304         -- ^ Don't bother checking the GHC version or architecture.
305         ,configSkipMsys            :: !Bool
306         -- ^ On Windows: don't use a sandboxed MSYS
307         ,configCompilerCheck       :: !VersionCheck
308         -- ^ Specifies which versions of the compiler are acceptable.
309         ,configCompilerRepository  :: !CompilerRepository
310         -- ^ Specifies the repository containing the compiler sources
311         ,configLocalBin            :: !(Path Abs Dir)
312         -- ^ Directory we should install executables into
313         ,configRequireStackVersion :: !VersionRange
314         -- ^ Require a version of stack within this range.
315         ,configJobs                :: !Int
316         -- ^ How many concurrent jobs to run, defaults to number of capabilities
317         ,configOverrideGccPath     :: !(Maybe (Path Abs File))
318         -- ^ Optional gcc override path
319         ,configExtraIncludeDirs    :: ![FilePath]
320         -- ^ --extra-include-dirs arguments
321         ,configExtraLibDirs        :: ![FilePath]
322         -- ^ --extra-lib-dirs arguments
323         ,configCustomPreprocessorExts :: ![Text]
324         -- ^ List of custom preprocessors to complete the hard coded ones
325         ,configConcurrentTests     :: !Bool
326         -- ^ Run test suites concurrently
327         ,configTemplateParams      :: !(Map Text Text)
328         -- ^ Parameters for templates.
329         ,configScmInit             :: !(Maybe SCM)
330         -- ^ Initialize SCM (e.g. git) when creating new projects.
331         ,configGhcOptionsByName    :: !(Map PackageName [Text])
332         -- ^ Additional GHC options to apply to specific packages.
333         ,configGhcOptionsByCat     :: !(Map ApplyGhcOptions [Text])
334         -- ^ Additional GHC options to apply to categories of packages
335         ,configCabalConfigOpts     :: !(Map CabalConfigKey [Text])
336         -- ^ Additional options to be passed to ./Setup.hs configure
337         ,configSetupInfoLocations  :: ![String]
338         -- ^ URLs or paths to stack-setup.yaml files, for finding tools.
339         -- If none present, the default setup-info is used.
340         ,configSetupInfoInline     :: !SetupInfo
341         -- ^ Additional SetupInfo to use to find tools.
342         ,configPvpBounds           :: !PvpBounds
343         -- ^ How PVP upper bounds should be added to packages
344         ,configModifyCodePage      :: !Bool
345         -- ^ Force the code page to UTF-8 on Windows
346         ,configRebuildGhcOptions   :: !Bool
347         -- ^ Rebuild on GHC options changes
348         ,configApplyGhcOptions     :: !ApplyGhcOptions
349         -- ^ Which packages to ghc-options on the command line apply to?
350         ,configAllowNewer          :: !Bool
351         -- ^ Ignore version ranges in .cabal files. Funny naming chosen to
352         -- match cabal.
353         ,configDefaultTemplate     :: !(Maybe TemplateName)
354         -- ^ The default template to use when none is specified.
355         -- (If Nothing, the default default is used.)
356         ,configAllowDifferentUser  :: !Bool
357         -- ^ Allow users other than the stack root owner to use the stack
358         -- installation.
359         ,configDumpLogs            :: !DumpLogs
360         -- ^ Dump logs of local non-dependencies when doing a build.
361         ,configProject             :: !(ProjectConfig (Project, Path Abs File))
362         -- ^ Project information and stack.yaml file location
363         ,configAllowLocals         :: !Bool
364         -- ^ Are we allowed to build local packages? The script
365         -- command disallows this.
366         ,configSaveHackageCreds    :: !Bool
367         -- ^ Should we save Hackage credentials to a file?
368         ,configHackageBaseUrl      :: !Text
369         -- ^ Hackage base URL used when uploading packages
370         ,configRunner              :: !Runner
371         ,configPantryConfig        :: !PantryConfig
372         ,configStackRoot           :: !(Path Abs Dir)
373         ,configResolver            :: !(Maybe AbstractResolver)
374         -- ^ Any resolver override from the command line
375         ,configUserStorage         :: !UserStorage
376         -- ^ Database connection pool for user Stack database
377         ,configHideSourcePaths     :: !Bool
378         -- ^ Enable GHC hiding source paths?
379         ,configRecommendUpgrade    :: !Bool
380         -- ^ Recommend a Stack upgrade?
381         ,configStackDeveloperMode  :: !Bool
382         -- ^ Turn on Stack developer mode for additional messages?
383         }
384
385-- | A bit of type safety to ensure we're talking to the right database.
386newtype UserStorage = UserStorage
387  { unUserStorage :: Storage
388  }
389
390-- | A bit of type safety to ensure we're talking to the right database.
391newtype ProjectStorage = ProjectStorage
392  { unProjectStorage :: Storage
393  }
394
395-- | The project root directory, if in a project.
396configProjectRoot :: Config -> Maybe (Path Abs Dir)
397configProjectRoot c =
398  case configProject c of
399    PCProject (_, fp) -> Just $ parent fp
400    PCGlobalProject -> Nothing
401    PCNoProject _deps -> Nothing
402
403-- | Which packages do configure opts apply to?
404data CabalConfigKey
405  = CCKTargets -- ^ See AGOTargets
406  | CCKLocals -- ^ See AGOLocals
407  | CCKEverything -- ^ See AGOEverything
408  | CCKPackage !PackageName -- ^ A specific package
409  deriving (Show, Read, Eq, Ord)
410instance FromJSON CabalConfigKey where
411  parseJSON = withText "CabalConfigKey" parseCabalConfigKey
412instance FromJSONKey CabalConfigKey where
413  fromJSONKey = FromJSONKeyTextParser parseCabalConfigKey
414
415parseCabalConfigKey :: (Monad m, MonadFail m) => Text -> m CabalConfigKey
416parseCabalConfigKey "$targets" = pure CCKTargets
417parseCabalConfigKey "$locals" = pure CCKLocals
418parseCabalConfigKey "$everything" = pure CCKEverything
419parseCabalConfigKey name =
420  case parsePackageName $ T.unpack name of
421    Nothing -> fail $ "Invalid CabalConfigKey: " ++ show name
422    Just x -> pure $ CCKPackage x
423
424-- | Which packages do ghc-options on the command line apply to?
425data ApplyGhcOptions = AGOTargets -- ^ all local targets
426                     | AGOLocals -- ^ all local packages, even non-targets
427                     | AGOEverything -- ^ every package
428  deriving (Show, Read, Eq, Ord, Enum, Bounded)
429
430instance FromJSON ApplyGhcOptions where
431    parseJSON = withText "ApplyGhcOptions" $ \t ->
432        case t of
433            "targets" -> return AGOTargets
434            "locals" -> return AGOLocals
435            "everything" -> return AGOEverything
436            _ -> fail $ "Invalid ApplyGhcOptions: " ++ show t
437
438-- | Which build log files to dump
439data DumpLogs
440  = DumpNoLogs -- ^ don't dump any logfiles
441  | DumpWarningLogs -- ^ dump logfiles containing warnings
442  | DumpAllLogs -- ^ dump all logfiles
443  deriving (Show, Read, Eq, Ord, Enum, Bounded)
444
445instance FromJSON DumpLogs where
446  parseJSON (Bool True) = return DumpAllLogs
447  parseJSON (Bool False) = return DumpNoLogs
448  parseJSON v =
449    withText
450      "DumpLogs"
451      (\t ->
452          if | t == "none" -> return DumpNoLogs
453             | t == "warning" -> return DumpWarningLogs
454             | t == "all" -> return DumpAllLogs
455             | otherwise -> fail ("Invalid DumpLogs: " ++ show t))
456      v
457
458-- | Controls which version of the environment is used
459data EnvSettings = EnvSettings
460    { esIncludeLocals :: !Bool
461    -- ^ include local project bin directory, GHC_PACKAGE_PATH, etc
462    , esIncludeGhcPackagePath :: !Bool
463    -- ^ include the GHC_PACKAGE_PATH variable
464    , esStackExe :: !Bool
465    -- ^ set the STACK_EXE variable to the current executable name
466    , esLocaleUtf8 :: !Bool
467    -- ^ set the locale to C.UTF-8
468    , esKeepGhcRts :: !Bool
469    -- ^ if True, keep GHCRTS variable in environment
470    }
471    deriving (Show, Eq, Ord)
472
473data ExecOpts = ExecOpts
474    { eoCmd :: !SpecialExecCmd
475    , eoArgs :: ![String]
476    , eoExtra :: !ExecOptsExtra
477    } deriving (Show)
478
479data SpecialExecCmd
480    = ExecCmd String
481    | ExecRun
482    | ExecGhc
483    | ExecRunGhc
484    deriving (Show, Eq)
485
486data ExecOptsExtra = ExecOptsExtra
487  { eoEnvSettings :: !EnvSettings
488  , eoPackages :: ![String]
489  , eoRtsOptions :: ![String]
490  , eoCwd :: !(Maybe FilePath)
491  }
492  deriving (Show)
493
494data EvalOpts = EvalOpts
495    { evalArg :: !String
496    , evalExtra :: !ExecOptsExtra
497    } deriving (Show)
498
499-- | Parsed global command-line options.
500data GlobalOpts = GlobalOpts
501    { globalReExecVersion :: !(Maybe String) -- ^ Expected re-exec in container version
502    , globalDockerEntrypoint :: !(Maybe DockerEntrypoint)
503      -- ^ Data used when stack is acting as a Docker entrypoint (internal use only)
504    , globalLogLevel     :: !LogLevel -- ^ Log level
505    , globalTimeInLog    :: !Bool -- ^ Whether to include timings in logs.
506    , globalConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig'
507    , globalResolver     :: !(Maybe AbstractResolver) -- ^ Resolver override
508    , globalCompiler     :: !(Maybe WantedCompiler) -- ^ Compiler override
509    , globalTerminal     :: !Bool -- ^ We're in a terminal?
510    , globalStylesUpdate :: !StylesUpdate -- ^ SGR (Ansi) codes for styles
511    , globalTermWidth    :: !(Maybe Int) -- ^ Terminal width override
512    , globalStackYaml    :: !StackYamlLoc -- ^ Override project stack.yaml
513    , globalLockFileBehavior :: !LockFileBehavior
514    } deriving (Show)
515
516-- | Location for the project's stack.yaml file.
517data StackYamlLoc
518    = SYLDefault
519    -- ^ Use the standard parent-directory-checking logic
520    | SYLOverride !(Path Abs File)
521    -- ^ Use a specific stack.yaml file provided
522    | SYLNoProject ![PackageIdentifierRevision]
523    -- ^ Do not load up a project, just user configuration. Include
524    -- the given extra dependencies with the resolver.
525    | SYLGlobalProject
526    -- ^ Do not look for a project configuration, and use the implicit global.
527    deriving Show
528
529stackYamlLocL :: HasRunner env => Lens' env StackYamlLoc
530stackYamlLocL = globalOptsL.lens globalStackYaml (\x y -> x { globalStackYaml = y })
531
532-- | How to interact with lock files
533data LockFileBehavior
534  = LFBReadWrite
535  -- ^ Read and write lock files
536  | LFBReadOnly
537  -- ^ Read lock files, but do not write them
538  | LFBIgnore
539  -- ^ Entirely ignore lock files
540  | LFBErrorOnWrite
541  -- ^ Error out on trying to write a lock file. This can be used to
542  -- ensure that lock files in a repository already ensure
543  -- reproducible builds.
544  deriving (Show, Enum, Bounded)
545
546lockFileBehaviorL :: HasRunner env => SimpleGetter env LockFileBehavior
547lockFileBehaviorL = globalOptsL.to globalLockFileBehavior
548
549-- | Parser for 'LockFileBehavior'
550readLockFileBehavior :: ReadM LockFileBehavior
551readLockFileBehavior = do
552  s <- OA.readerAsk
553  case Map.lookup s m of
554    Just x -> pure x
555    Nothing -> OA.readerError $ "Invalid lock file behavior, valid options: " ++
556                                List.intercalate ", " (Map.keys m)
557  where
558    m = Map.fromList $ map (\x -> (render x, x)) [minBound..maxBound]
559    render LFBReadWrite = "read-write"
560    render LFBReadOnly = "read-only"
561    render LFBIgnore = "ignore"
562    render LFBErrorOnWrite = "error-on-write"
563
564-- | Project configuration information. Not every run of Stack has a
565-- true local project; see constructors below.
566data ProjectConfig a
567    = PCProject a
568    -- ^ Normal run: we want a project, and have one. This comes from
569    -- either 'SYLDefault' or 'SYLOverride'.
570    | PCGlobalProject
571    -- ^ No project was found when using 'SYLDefault'. Instead, use
572    -- the implicit global.
573    | PCNoProject ![PackageIdentifierRevision]
574    -- ^ Use a no project run. This comes from 'SYLNoProject'.
575
576-- | Parsed global command-line options monoid.
577data GlobalOptsMonoid = GlobalOptsMonoid
578    { globalMonoidReExecVersion :: !(First String) -- ^ Expected re-exec in container version
579    , globalMonoidDockerEntrypoint :: !(First DockerEntrypoint)
580      -- ^ Data used when stack is acting as a Docker entrypoint (internal use only)
581    , globalMonoidLogLevel     :: !(First LogLevel) -- ^ Log level
582    , globalMonoidTimeInLog    :: !FirstTrue -- ^ Whether to include timings in logs.
583    , globalMonoidConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig'
584    , globalMonoidResolver     :: !(First (Unresolved AbstractResolver)) -- ^ Resolver override
585    , globalMonoidResolverRoot :: !(First FilePath) -- ^ root directory for resolver relative path
586    , globalMonoidCompiler     :: !(First WantedCompiler) -- ^ Compiler override
587    , globalMonoidTerminal     :: !(First Bool) -- ^ We're in a terminal?
588    , globalMonoidStyles       :: !StylesUpdate -- ^ Stack's output styles
589    , globalMonoidTermWidth    :: !(First Int) -- ^ Terminal width override
590    , globalMonoidStackYaml    :: !(First FilePath) -- ^ Override project stack.yaml
591    , globalMonoidLockFileBehavior :: !(First LockFileBehavior) -- ^ See 'globalLockFileBehavior'
592    } deriving Generic
593
594instance Semigroup GlobalOptsMonoid where
595    (<>) = mappenddefault
596
597instance Monoid GlobalOptsMonoid where
598    mempty = memptydefault
599    mappend = (<>)
600
601-- | Default logging level should be something useful but not crazy.
602defaultLogLevel :: LogLevel
603defaultLogLevel = LevelInfo
604
605readColorWhen :: ReadM ColorWhen
606readColorWhen = do
607    s <- OA.readerAsk
608    case s of
609        "never" -> return ColorNever
610        "always" -> return ColorAlways
611        "auto" -> return ColorAuto
612        _ -> OA.readerError "Expected values of color option are 'never', 'always', or 'auto'."
613
614readStyles :: ReadM StylesUpdate
615readStyles = parseStylesUpdateFromString <$> OA.readerAsk
616
617-- | A superset of 'Config' adding information on how to build code. The reason
618-- for this breakdown is because we will need some of the information from
619-- 'Config' in order to determine the values here.
620--
621-- These are the components which know nothing about local configuration.
622data BuildConfig = BuildConfig
623    { bcConfig     :: !Config
624    , bcSMWanted :: !SMWanted
625    , bcExtraPackageDBs :: ![Path Abs Dir]
626      -- ^ Extra package databases
627    , bcStackYaml  :: !(Path Abs File)
628      -- ^ Location of the stack.yaml file.
629      --
630      -- Note: if the STACK_YAML environment variable is used, this may be
631      -- different from projectRootL </> "stack.yaml" if a different file
632      -- name is used.
633    , bcProjectStorage :: !ProjectStorage
634    -- ^ Database connection pool for project Stack database
635    , bcCurator :: !(Maybe Curator)
636    }
637
638stackYamlL :: HasBuildConfig env => Lens' env (Path Abs File)
639stackYamlL = buildConfigL.lens bcStackYaml (\x y -> x { bcStackYaml = y })
640
641-- | Directory containing the project's stack.yaml file
642projectRootL :: HasBuildConfig env => Getting r env (Path Abs Dir)
643projectRootL = stackYamlL.to parent
644
645-- | Configuration after the environment has been setup.
646data EnvConfig = EnvConfig
647    {envConfigBuildConfig :: !BuildConfig
648    ,envConfigBuildOptsCLI :: !BuildOptsCLI
649    ,envConfigSourceMap :: !SourceMap
650    ,envConfigSourceMapHash :: !SourceMapHash
651    ,envConfigCompilerPaths :: !CompilerPaths
652    }
653
654ppGPD :: MonadIO m => ProjectPackage -> m GenericPackageDescription
655ppGPD = liftIO . cpGPD . ppCommon
656
657-- | Root directory for the given 'ProjectPackage'
658ppRoot :: ProjectPackage -> Path Abs Dir
659ppRoot = parent . ppCabalFP
660
661-- | All components available in the given 'ProjectPackage'
662ppComponents :: MonadIO m => ProjectPackage -> m (Set NamedComponent)
663ppComponents pp = do
664  gpd <- ppGPD pp
665  pure $ Set.fromList $ concat
666    [ maybe []  (const [CLib]) (C.condLibrary gpd)
667    , go CExe   (fst <$> C.condExecutables gpd)
668    , go CTest  (fst <$> C.condTestSuites gpd)
669    , go CBench (fst <$> C.condBenchmarks gpd)
670    ]
671  where
672    go :: (T.Text -> NamedComponent)
673       -> [C.UnqualComponentName]
674       -> [NamedComponent]
675    go wrapper = map (wrapper . T.pack . C.unUnqualComponentName)
676
677-- | Version for the given 'ProjectPackage
678ppVersion :: MonadIO m => ProjectPackage -> m Version
679ppVersion = fmap gpdVersion . ppGPD
680
681-- | A project is a collection of packages. We can have multiple stack.yaml
682-- files, but only one of them may contain project information.
683data Project = Project
684    { projectUserMsg :: !(Maybe String)
685    -- ^ A warning message to display to the user when the auto generated
686    -- config may have issues.
687    , projectPackages :: ![RelFilePath]
688    -- ^ Packages which are actually part of the project (as opposed
689    -- to dependencies).
690    , projectDependencies :: ![RawPackageLocation]
691    -- ^ Dependencies defined within the stack.yaml file, to be
692    -- applied on top of the snapshot.
693    , projectFlags :: !(Map PackageName (Map FlagName Bool))
694    -- ^ Flags to be applied on top of the snapshot flags.
695    , projectResolver :: !RawSnapshotLocation
696    -- ^ How we resolve which @Snapshot@ to use
697    , projectCompiler :: !(Maybe WantedCompiler)
698    -- ^ Override the compiler in 'projectResolver'
699    , projectExtraPackageDBs :: ![FilePath]
700    , projectCurator :: !(Maybe Curator)
701    -- ^ Extra configuration intended exclusively for usage by the
702    -- curator tool. In other words, this is /not/ part of the
703    -- documented and exposed Stack API. SUBJECT TO CHANGE.
704    , projectDropPackages :: !(Set PackageName)
705    -- ^ Packages to drop from the 'projectResolver'.
706    }
707  deriving Show
708
709instance ToJSON Project where
710    -- Expanding the constructor fully to ensure we don't miss any fields.
711    toJSON (Project userMsg packages extraDeps flags resolver mcompiler extraPackageDBs mcurator drops) = object $ concat
712      [ maybe [] (\cv -> ["compiler" .= cv]) mcompiler
713      , maybe [] (\msg -> ["user-message" .= msg]) userMsg
714      , if null extraPackageDBs then [] else ["extra-package-dbs" .= extraPackageDBs]
715      , if null extraDeps then [] else ["extra-deps" .= extraDeps]
716      , if Map.null flags then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap flags)]
717      , ["packages" .= packages]
718      , ["resolver" .= resolver]
719      , maybe [] (\c -> ["curator" .= c]) mcurator
720      , if Set.null drops then [] else ["drop-packages" .= Set.map CabalString drops]
721      ]
722
723-- | Extra configuration intended exclusively for usage by the
724-- curator tool. In other words, this is /not/ part of the
725-- documented and exposed Stack API. SUBJECT TO CHANGE.
726data Curator = Curator
727  { curatorSkipTest :: !(Set PackageName)
728  , curatorExpectTestFailure :: !(Set PackageName)
729  , curatorSkipBenchmark :: !(Set PackageName)
730  , curatorExpectBenchmarkFailure :: !(Set PackageName)
731  , curatorSkipHaddock :: !(Set PackageName)
732  , curatorExpectHaddockFailure :: !(Set PackageName)
733  }
734  deriving Show
735instance ToJSON Curator where
736  toJSON c = object
737    [ "skip-test" .= Set.map CabalString (curatorSkipTest c)
738    , "expect-test-failure" .= Set.map CabalString (curatorExpectTestFailure c)
739    , "skip-bench" .= Set.map CabalString (curatorSkipBenchmark c)
740    , "expect-benchmark-failure" .= Set.map CabalString (curatorExpectTestFailure c)
741    , "skip-haddock" .= Set.map CabalString (curatorSkipHaddock c)
742    , "expect-test-failure" .= Set.map CabalString (curatorExpectHaddockFailure c)
743    ]
744instance FromJSON (WithJSONWarnings Curator) where
745  parseJSON = withObjectWarnings "Curator" $ \o -> Curator
746    <$> fmap (Set.map unCabalString) (o ..:? "skip-test" ..!= mempty)
747    <*> fmap (Set.map unCabalString) (o ..:? "expect-test-failure" ..!= mempty)
748    <*> fmap (Set.map unCabalString) (o ..:? "skip-bench" ..!= mempty)
749    <*> fmap (Set.map unCabalString) (o ..:? "expect-benchmark-failure" ..!= mempty)
750    <*> fmap (Set.map unCabalString) (o ..:? "skip-haddock" ..!= mempty)
751    <*> fmap (Set.map unCabalString) (o ..:? "expect-haddock-failure" ..!= mempty)
752
753-- An uninterpreted representation of configuration options.
754-- Configurations may be "cascaded" using mappend (left-biased).
755data ConfigMonoid =
756  ConfigMonoid
757    { configMonoidStackRoot          :: !(First (Path Abs Dir))
758    -- ^ See: 'clStackRoot'
759    , configMonoidWorkDir            :: !(First (Path Rel Dir))
760    -- ^ See: 'configWorkDir'.
761    , configMonoidBuildOpts          :: !BuildOptsMonoid
762    -- ^ build options.
763    , configMonoidDockerOpts         :: !DockerOptsMonoid
764    -- ^ Docker options.
765    , configMonoidNixOpts            :: !NixOptsMonoid
766    -- ^ Options for the execution environment (nix-shell or container)
767    , configMonoidConnectionCount    :: !(First Int)
768    -- ^ See: 'configConnectionCount'
769    , configMonoidHideTHLoading      :: !FirstTrue
770    -- ^ See: 'configHideTHLoading'
771    , configMonoidPrefixTimestamps   :: !(First Bool)
772    -- ^ See: 'configPrefixTimestamps'
773    , configMonoidLatestSnapshot     :: !(First Text)
774    -- ^ See: 'configLatestSnapshot'
775    , configMonoidPackageIndices     :: !(First [HackageSecurityConfig])
776    -- ^ See: @picIndices@
777    , configMonoidSystemGHC          :: !(First Bool)
778    -- ^ See: 'configSystemGHC'
779    ,configMonoidInstallGHC          :: !FirstTrue
780    -- ^ See: 'configInstallGHC'
781    ,configMonoidSkipGHCCheck        :: !FirstFalse
782    -- ^ See: 'configSkipGHCCheck'
783    ,configMonoidSkipMsys            :: !FirstFalse
784    -- ^ See: 'configSkipMsys'
785    ,configMonoidCompilerCheck       :: !(First VersionCheck)
786    -- ^ See: 'configCompilerCheck'
787    ,configMonoidCompilerRepository  :: !(First CompilerRepository)
788    -- ^ See: 'configCompilerRepository'
789    ,configMonoidRequireStackVersion :: !IntersectingVersionRange
790    -- ^ See: 'configRequireStackVersion'
791    ,configMonoidArch                :: !(First String)
792    -- ^ Used for overriding the platform
793    ,configMonoidGHCVariant          :: !(First GHCVariant)
794    -- ^ Used for overriding the platform
795    ,configMonoidGHCBuild            :: !(First CompilerBuild)
796    -- ^ Used for overriding the GHC build
797    ,configMonoidJobs                :: !(First Int)
798    -- ^ See: 'configJobs'
799    ,configMonoidExtraIncludeDirs    :: ![FilePath]
800    -- ^ See: 'configExtraIncludeDirs'
801    ,configMonoidExtraLibDirs        :: ![FilePath]
802    -- ^ See: 'configExtraLibDirs'
803    ,configMonoidCustomPreprocessorExts :: ![Text]
804    -- ^ See: 'configCustomPreprocessorExts'
805    , configMonoidOverrideGccPath    :: !(First (Path Abs File))
806    -- ^ Allow users to override the path to gcc
807    ,configMonoidOverrideHpack       :: !(First FilePath)
808    -- ^ Use Hpack executable (overrides bundled Hpack)
809    ,configMonoidConcurrentTests     :: !(First Bool)
810    -- ^ See: 'configConcurrentTests'
811    ,configMonoidLocalBinPath        :: !(First FilePath)
812    -- ^ Used to override the binary installation dir
813    ,configMonoidTemplateParameters  :: !(Map Text Text)
814    -- ^ Template parameters.
815    ,configMonoidScmInit             :: !(First SCM)
816    -- ^ Initialize SCM (e.g. git init) when making new projects?
817    ,configMonoidGhcOptionsByName    :: !(MonoidMap PackageName (Monoid.Dual [Text]))
818    -- ^ See 'configGhcOptionsByName'. Uses 'Monoid.Dual' so that
819    -- options from the configs on the right come first, so that they
820    -- can be overridden.
821    ,configMonoidGhcOptionsByCat     :: !(MonoidMap ApplyGhcOptions (Monoid.Dual [Text]))
822    -- ^ See 'configGhcOptionsAll'. Uses 'Monoid.Dual' so that options
823    -- from the configs on the right come first, so that they can be
824    -- overridden.
825    ,configMonoidCabalConfigOpts     :: !(MonoidMap CabalConfigKey (Monoid.Dual [Text]))
826    -- ^ See 'configCabalConfigOpts'.
827    ,configMonoidExtraPath           :: ![Path Abs Dir]
828    -- ^ Additional paths to search for executables in
829    ,configMonoidSetupInfoLocations  :: ![String]
830    -- ^ See 'configSetupInfoLocations'
831    ,configMonoidSetupInfoInline     :: !SetupInfo
832    -- ^ See 'configSetupInfoInline'
833    ,configMonoidLocalProgramsBase   :: !(First (Path Abs Dir))
834    -- ^ Override the default local programs dir, where e.g. GHC is installed.
835    ,configMonoidPvpBounds           :: !(First PvpBounds)
836    -- ^ See 'configPvpBounds'
837    ,configMonoidModifyCodePage      :: !FirstTrue
838    -- ^ See 'configModifyCodePage'
839    ,configMonoidRebuildGhcOptions   :: !FirstFalse
840    -- ^ See 'configMonoidRebuildGhcOptions'
841    ,configMonoidApplyGhcOptions     :: !(First ApplyGhcOptions)
842    -- ^ See 'configApplyGhcOptions'
843    ,configMonoidAllowNewer          :: !(First Bool)
844    -- ^ See 'configMonoidAllowNewer'
845    ,configMonoidDefaultTemplate     :: !(First TemplateName)
846    -- ^ The default template to use when none is specified.
847    -- (If Nothing, the default default is used.)
848    , configMonoidAllowDifferentUser :: !(First Bool)
849    -- ^ Allow users other than the stack root owner to use the stack
850    -- installation.
851    , configMonoidDumpLogs           :: !(First DumpLogs)
852    -- ^ See 'configDumpLogs'
853    , configMonoidSaveHackageCreds   :: !(First Bool)
854    -- ^ See 'configSaveHackageCreds'
855    , configMonoidHackageBaseUrl     :: !(First Text)
856    -- ^ See 'configHackageBaseUrl'
857    , configMonoidColorWhen          :: !(First ColorWhen)
858    -- ^ When to use 'ANSI' colors
859    , configMonoidStyles             :: !StylesUpdate
860    , configMonoidHideSourcePaths    :: !FirstTrue
861    -- ^ See 'configHideSourcePaths'
862    , configMonoidRecommendUpgrade   :: !FirstTrue
863    -- ^ See 'configRecommendUpgrade'
864    , configMonoidCasaRepoPrefix     :: !(First CasaRepoPrefix)
865    , configMonoidSnapshotLocation :: !(First Text)
866    -- ^ Custom location of LTS/Nightly snapshots
867    , configMonoidStackDeveloperMode :: !(First Bool)
868    -- ^ See 'configStackDeveloperMode'
869    }
870  deriving (Show, Generic)
871
872instance Semigroup ConfigMonoid where
873    (<>) = mappenddefault
874
875instance Monoid ConfigMonoid where
876    mempty = memptydefault
877    mappend = (<>)
878
879parseConfigMonoid :: Path Abs Dir -> Value -> Yaml.Parser (WithJSONWarnings ConfigMonoid)
880parseConfigMonoid = withObjectWarnings "ConfigMonoid" . parseConfigMonoidObject
881
882-- | Parse a partial configuration.  Used both to parse both a standalone config
883-- file and a project file, so that a sub-parser is not required, which would interfere with
884-- warnings for missing fields.
885parseConfigMonoidObject :: Path Abs Dir -> Object -> WarningParser ConfigMonoid
886parseConfigMonoidObject rootDir obj = do
887    -- Parsing 'stackRoot' from 'stackRoot'/config.yaml would be nonsensical
888    let configMonoidStackRoot = First Nothing
889    configMonoidWorkDir <- First <$> obj ..:? configMonoidWorkDirName
890    configMonoidBuildOpts <- jsonSubWarnings (obj ..:? configMonoidBuildOptsName ..!= mempty)
891    configMonoidDockerOpts <- jsonSubWarnings (obj ..:? configMonoidDockerOptsName ..!= mempty)
892    configMonoidNixOpts <- jsonSubWarnings (obj ..:? configMonoidNixOptsName ..!= mempty)
893    configMonoidConnectionCount <- First <$> obj ..:? configMonoidConnectionCountName
894    configMonoidHideTHLoading <- FirstTrue <$> obj ..:? configMonoidHideTHLoadingName
895    configMonoidPrefixTimestamps <- First <$> obj ..:? configMonoidPrefixTimestampsName
896
897    murls :: Maybe Value <- obj ..:? configMonoidUrlsName
898    configMonoidLatestSnapshot <-
899      case murls of
900        Nothing -> pure $ First Nothing
901        Just urls -> jsonSubWarnings $ lift $ withObjectWarnings
902          "urls"
903          (\o -> First <$> o ..:? "latest-snapshot" :: WarningParser (First Text))
904          urls
905
906    configMonoidPackageIndices <- First <$> jsonSubWarningsTT (obj ..:?  configMonoidPackageIndicesName)
907    configMonoidSystemGHC <- First <$> obj ..:? configMonoidSystemGHCName
908    configMonoidInstallGHC <- FirstTrue <$> obj ..:? configMonoidInstallGHCName
909    configMonoidSkipGHCCheck <- FirstFalse <$> obj ..:? configMonoidSkipGHCCheckName
910    configMonoidSkipMsys <- FirstFalse <$> obj ..:? configMonoidSkipMsysName
911    configMonoidRequireStackVersion <- IntersectingVersionRange . unVersionRangeJSON <$> (
912                                       obj ..:? configMonoidRequireStackVersionName
913                                           ..!= VersionRangeJSON anyVersion)
914    configMonoidArch <- First <$> obj ..:? configMonoidArchName
915    configMonoidGHCVariant <- First <$> obj ..:? configMonoidGHCVariantName
916    configMonoidGHCBuild <- First <$> obj ..:? configMonoidGHCBuildName
917    configMonoidJobs <- First <$> obj ..:? configMonoidJobsName
918    configMonoidExtraIncludeDirs <- map (toFilePath rootDir FilePath.</>) <$>
919        obj ..:?  configMonoidExtraIncludeDirsName ..!= []
920    configMonoidExtraLibDirs <- map (toFilePath rootDir FilePath.</>) <$>
921        obj ..:?  configMonoidExtraLibDirsName ..!= []
922    configMonoidCustomPreprocessorExts <- obj ..:?  configMonoidCustomPreprocessorExtsName ..!= []
923    configMonoidOverrideGccPath <- First <$> obj ..:? configMonoidOverrideGccPathName
924    configMonoidOverrideHpack <- First <$> obj ..:? configMonoidOverrideHpackName
925    configMonoidConcurrentTests <- First <$> obj ..:? configMonoidConcurrentTestsName
926    configMonoidLocalBinPath <- First <$> obj ..:? configMonoidLocalBinPathName
927    templates <- obj ..:? "templates"
928    (configMonoidScmInit,configMonoidTemplateParameters) <-
929      case templates of
930        Nothing -> return (First Nothing,M.empty)
931        Just tobj -> do
932          scmInit <- tobj ..:? configMonoidScmInitName
933          params <- tobj ..:? configMonoidTemplateParametersName
934          return (First scmInit,fromMaybe M.empty params)
935    configMonoidCompilerCheck <- First <$> obj ..:? configMonoidCompilerCheckName
936    configMonoidCompilerRepository <- First <$> (obj ..:? configMonoidCompilerRepositoryName)
937
938    options <- Map.map unGhcOptions <$> obj ..:? configMonoidGhcOptionsName ..!= mempty
939
940    optionsEverything <-
941      case (Map.lookup GOKOldEverything options, Map.lookup GOKEverything options) of
942        (Just _, Just _) -> fail "Cannot specify both `*` and `$everything` GHC options"
943        (Nothing, Just x) -> return x
944        (Just x, Nothing) -> do
945          tell "The `*` ghc-options key is not recommended. Consider using $locals, or if really needed, $everything"
946          return x
947        (Nothing, Nothing) -> return []
948
949    let configMonoidGhcOptionsByCat = coerce $ Map.fromList
950          [ (AGOEverything, optionsEverything)
951          , (AGOLocals, Map.findWithDefault [] GOKLocals options)
952          , (AGOTargets, Map.findWithDefault [] GOKTargets options)
953          ]
954
955        configMonoidGhcOptionsByName = coerce $ Map.fromList
956            [(name, opts) | (GOKPackage name, opts) <- Map.toList options]
957
958    configMonoidCabalConfigOpts' <- obj ..:? "configure-options" ..!= mempty
959    let configMonoidCabalConfigOpts = coerce (configMonoidCabalConfigOpts' :: Map CabalConfigKey [Text])
960
961    configMonoidExtraPath <- obj ..:? configMonoidExtraPathName ..!= []
962    configMonoidSetupInfoLocations <- obj ..:? configMonoidSetupInfoLocationsName ..!= []
963    configMonoidSetupInfoInline <- jsonSubWarningsT (obj ..:? configMonoidSetupInfoInlineName) ..!= mempty
964    configMonoidLocalProgramsBase <- First <$> obj ..:? configMonoidLocalProgramsBaseName
965    configMonoidPvpBounds <- First <$> obj ..:? configMonoidPvpBoundsName
966    configMonoidModifyCodePage <- FirstTrue <$> obj ..:? configMonoidModifyCodePageName
967    configMonoidRebuildGhcOptions <- FirstFalse <$> obj ..:? configMonoidRebuildGhcOptionsName
968    configMonoidApplyGhcOptions <- First <$> obj ..:? configMonoidApplyGhcOptionsName
969    configMonoidAllowNewer <- First <$> obj ..:? configMonoidAllowNewerName
970    configMonoidDefaultTemplate <- First <$> obj ..:? configMonoidDefaultTemplateName
971    configMonoidAllowDifferentUser <- First <$> obj ..:? configMonoidAllowDifferentUserName
972    configMonoidDumpLogs <- First <$> obj ..:? configMonoidDumpLogsName
973    configMonoidSaveHackageCreds <- First <$> obj ..:? configMonoidSaveHackageCredsName
974    configMonoidHackageBaseUrl <- First <$> obj ..:? configMonoidHackageBaseUrlName
975
976    configMonoidColorWhenUS <- obj ..:? configMonoidColorWhenUSName
977    configMonoidColorWhenGB <- obj ..:? configMonoidColorWhenGBName
978    let configMonoidColorWhen =  First $   configMonoidColorWhenUS
979                                       <|> configMonoidColorWhenGB
980
981    configMonoidStylesUS <- obj ..:? configMonoidStylesUSName
982    configMonoidStylesGB <- obj ..:? configMonoidStylesGBName
983    let configMonoidStyles = fromMaybe mempty $   configMonoidStylesUS
984                                              <|> configMonoidStylesGB
985
986    configMonoidHideSourcePaths <- FirstTrue <$> obj ..:? configMonoidHideSourcePathsName
987    configMonoidRecommendUpgrade <- FirstTrue <$> obj ..:? configMonoidRecommendUpgradeName
988
989    configMonoidCasaRepoPrefix <- First <$> obj ..:? configMonoidCasaRepoPrefixName
990    configMonoidSnapshotLocation <- First <$> obj ..:? configMonoidSnapshotLocationName
991
992    configMonoidStackDeveloperMode <- First <$> obj ..:? configMonoidStackDeveloperModeName
993
994    return ConfigMonoid {..}
995
996configMonoidWorkDirName :: Text
997configMonoidWorkDirName = "work-dir"
998
999configMonoidBuildOptsName :: Text
1000configMonoidBuildOptsName = "build"
1001
1002configMonoidDockerOptsName :: Text
1003configMonoidDockerOptsName = "docker"
1004
1005configMonoidNixOptsName :: Text
1006configMonoidNixOptsName = "nix"
1007
1008configMonoidConnectionCountName :: Text
1009configMonoidConnectionCountName = "connection-count"
1010
1011configMonoidHideTHLoadingName :: Text
1012configMonoidHideTHLoadingName = "hide-th-loading"
1013
1014configMonoidPrefixTimestampsName :: Text
1015configMonoidPrefixTimestampsName = "build-output-timestamps"
1016
1017configMonoidUrlsName :: Text
1018configMonoidUrlsName = "urls"
1019
1020configMonoidPackageIndicesName :: Text
1021configMonoidPackageIndicesName = "package-indices"
1022
1023configMonoidSystemGHCName :: Text
1024configMonoidSystemGHCName = "system-ghc"
1025
1026configMonoidInstallGHCName :: Text
1027configMonoidInstallGHCName = "install-ghc"
1028
1029configMonoidSkipGHCCheckName :: Text
1030configMonoidSkipGHCCheckName = "skip-ghc-check"
1031
1032configMonoidSkipMsysName :: Text
1033configMonoidSkipMsysName = "skip-msys"
1034
1035configMonoidRequireStackVersionName :: Text
1036configMonoidRequireStackVersionName = "require-stack-version"
1037
1038configMonoidArchName :: Text
1039configMonoidArchName = "arch"
1040
1041configMonoidGHCVariantName :: Text
1042configMonoidGHCVariantName = "ghc-variant"
1043
1044configMonoidGHCBuildName :: Text
1045configMonoidGHCBuildName = "ghc-build"
1046
1047configMonoidJobsName :: Text
1048configMonoidJobsName = "jobs"
1049
1050configMonoidExtraIncludeDirsName :: Text
1051configMonoidExtraIncludeDirsName = "extra-include-dirs"
1052
1053configMonoidExtraLibDirsName :: Text
1054configMonoidExtraLibDirsName = "extra-lib-dirs"
1055
1056configMonoidCustomPreprocessorExtsName  :: Text
1057configMonoidCustomPreprocessorExtsName  = "custom-preprocessor-extensions"
1058
1059configMonoidOverrideGccPathName :: Text
1060configMonoidOverrideGccPathName = "with-gcc"
1061
1062configMonoidOverrideHpackName :: Text
1063configMonoidOverrideHpackName = "with-hpack"
1064
1065configMonoidConcurrentTestsName :: Text
1066configMonoidConcurrentTestsName = "concurrent-tests"
1067
1068configMonoidLocalBinPathName :: Text
1069configMonoidLocalBinPathName = "local-bin-path"
1070
1071configMonoidScmInitName :: Text
1072configMonoidScmInitName = "scm-init"
1073
1074configMonoidTemplateParametersName :: Text
1075configMonoidTemplateParametersName = "params"
1076
1077configMonoidCompilerCheckName :: Text
1078configMonoidCompilerCheckName = "compiler-check"
1079
1080configMonoidCompilerRepositoryName :: Text
1081configMonoidCompilerRepositoryName = "compiler-repository"
1082
1083configMonoidGhcOptionsName :: Text
1084configMonoidGhcOptionsName = "ghc-options"
1085
1086configMonoidExtraPathName :: Text
1087configMonoidExtraPathName = "extra-path"
1088
1089configMonoidSetupInfoLocationsName :: Text
1090configMonoidSetupInfoLocationsName = "setup-info-locations"
1091
1092configMonoidSetupInfoInlineName :: Text
1093configMonoidSetupInfoInlineName = "setup-info"
1094
1095configMonoidLocalProgramsBaseName :: Text
1096configMonoidLocalProgramsBaseName = "local-programs-path"
1097
1098configMonoidPvpBoundsName :: Text
1099configMonoidPvpBoundsName = "pvp-bounds"
1100
1101configMonoidModifyCodePageName :: Text
1102configMonoidModifyCodePageName = "modify-code-page"
1103
1104configMonoidRebuildGhcOptionsName :: Text
1105configMonoidRebuildGhcOptionsName = "rebuild-ghc-options"
1106
1107configMonoidApplyGhcOptionsName :: Text
1108configMonoidApplyGhcOptionsName = "apply-ghc-options"
1109
1110configMonoidAllowNewerName :: Text
1111configMonoidAllowNewerName = "allow-newer"
1112
1113configMonoidDefaultTemplateName :: Text
1114configMonoidDefaultTemplateName = "default-template"
1115
1116configMonoidAllowDifferentUserName :: Text
1117configMonoidAllowDifferentUserName = "allow-different-user"
1118
1119configMonoidDumpLogsName :: Text
1120configMonoidDumpLogsName = "dump-logs"
1121
1122configMonoidSaveHackageCredsName :: Text
1123configMonoidSaveHackageCredsName = "save-hackage-creds"
1124
1125configMonoidHackageBaseUrlName :: Text
1126configMonoidHackageBaseUrlName = "hackage-base-url"
1127
1128configMonoidColorWhenUSName :: Text
1129configMonoidColorWhenUSName = "color"
1130
1131configMonoidColorWhenGBName :: Text
1132configMonoidColorWhenGBName = "colour"
1133
1134configMonoidStylesUSName :: Text
1135configMonoidStylesUSName = "stack-colors"
1136
1137configMonoidStylesGBName :: Text
1138configMonoidStylesGBName = "stack-colours"
1139
1140configMonoidHideSourcePathsName :: Text
1141configMonoidHideSourcePathsName = "hide-source-paths"
1142
1143configMonoidRecommendUpgradeName :: Text
1144configMonoidRecommendUpgradeName = "recommend-stack-upgrade"
1145
1146configMonoidCasaRepoPrefixName :: Text
1147configMonoidCasaRepoPrefixName = "casa-repo-prefix"
1148
1149configMonoidSnapshotLocationName :: Text
1150configMonoidSnapshotLocationName = "snapshot-location-base"
1151
1152configMonoidStackDeveloperModeName :: Text
1153configMonoidStackDeveloperModeName = "stack-developer-mode"
1154
1155data ConfigException
1156  = ParseConfigFileException (Path Abs File) ParseException
1157  | ParseCustomSnapshotException Text ParseException
1158  | NoProjectConfigFound (Path Abs Dir) (Maybe Text)
1159  | UnexpectedArchiveContents [Path Abs Dir] [Path Abs File]
1160  | UnableToExtractArchive Text (Path Abs File)
1161  | BadStackVersionException VersionRange
1162  | NoMatchingSnapshot (NonEmpty SnapName)
1163  | ResolverMismatch !RawSnapshotLocation String
1164  | ResolverPartial !RawSnapshotLocation String
1165  | NoSuchDirectory FilePath
1166  | ParseGHCVariantException String
1167  | BadStackRoot (Path Abs Dir)
1168  | Won'tCreateStackRootInDirectoryOwnedByDifferentUser (Path Abs Dir) (Path Abs Dir) -- ^ @$STACK_ROOT@, parent dir
1169  | UserDoesn'tOwnDirectory (Path Abs Dir)
1170  | ManualGHCVariantSettingsAreIncompatibleWithSystemGHC
1171  | NixRequiresSystemGhc
1172  | NoResolverWhenUsingNoProject
1173  | DuplicateLocalPackageNames ![(PackageName, [PackageLocation])]
1174  deriving Typeable
1175instance Show ConfigException where
1176    show (ParseConfigFileException configFile exception) = concat
1177        [ "Could not parse '"
1178        , toFilePath configFile
1179        , "':\n"
1180        , Yaml.prettyPrintParseException exception
1181        , "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration/"
1182        ]
1183    show (ParseCustomSnapshotException url exception) = concat
1184        [ "Could not parse '"
1185        , T.unpack url
1186        , "':\n"
1187        , Yaml.prettyPrintParseException exception
1188        , "\nSee https://docs.haskellstack.org/en/stable/custom_snapshot/"
1189        ]
1190    show (NoProjectConfigFound dir mcmd) = concat
1191        [ "Unable to find a stack.yaml file in the current directory ("
1192        , toFilePath dir
1193        , ") or its ancestors"
1194        , case mcmd of
1195            Nothing -> ""
1196            Just cmd -> "\nRecommended action: stack " ++ T.unpack cmd
1197        ]
1198    show (UnexpectedArchiveContents dirs files) = concat
1199        [ "When unpacking an archive specified in your stack.yaml file, "
1200        , "did not find expected contents. Expected: a single directory. Found: "
1201        , show ( map (toFilePath . dirname) dirs
1202               , map (toFilePath . filename) files
1203               )
1204        ]
1205    show (UnableToExtractArchive url file) = concat
1206        [ "Archive extraction failed. Tarballs and zip archives are supported, couldn't handle the following URL, "
1207        , T.unpack url, " downloaded to the file ", toFilePath $ filename file
1208        ]
1209    show (BadStackVersionException requiredRange) = concat
1210        [ "The version of stack you are using ("
1211        , show (mkVersion' Meta.version)
1212        , ") is outside the required\n"
1213        ,"version range specified in stack.yaml ("
1214        , T.unpack (versionRangeText requiredRange)
1215        , ").\n"
1216        , "You can upgrade stack by running:\n\n"
1217        , "stack upgrade"
1218        ]
1219    show (NoMatchingSnapshot names) = concat
1220        [ "None of the following snapshots provides a compiler matching "
1221        , "your package(s):\n"
1222        , unlines $ map (\name -> "    - " <> show name)
1223                        (NonEmpty.toList names)
1224        , resolveOptions
1225        ]
1226    show (ResolverMismatch resolver errDesc) = concat
1227        [ "Resolver '"
1228        , T.unpack $ utf8BuilderToText $ display resolver
1229        , "' does not have a matching compiler to build some or all of your "
1230        , "package(s).\n"
1231        , errDesc
1232        , resolveOptions
1233        ]
1234    show (ResolverPartial resolver errDesc) = concat
1235        [ "Resolver '"
1236        , T.unpack $ utf8BuilderToText $ display resolver
1237        , "' does not have all the packages to match your requirements.\n"
1238        , unlines $ fmap ("    " <>) (lines errDesc)
1239        , resolveOptions
1240        ]
1241    show (NoSuchDirectory dir) =
1242        "No directory could be located matching the supplied path: " ++ dir
1243    show (ParseGHCVariantException v) =
1244        "Invalid ghc-variant value: " ++ v
1245    show (BadStackRoot stackRoot) = concat
1246        [ "Invalid stack root: '"
1247        , toFilePath stackRoot
1248        , "'. Please provide a valid absolute path."
1249        ]
1250    show (Won'tCreateStackRootInDirectoryOwnedByDifferentUser envStackRoot parentDir) = concat
1251        [ "Preventing creation of stack root '"
1252        , toFilePath envStackRoot
1253        , "'. Parent directory '"
1254        , toFilePath parentDir
1255        , "' is owned by someone else."
1256        ]
1257    show (UserDoesn'tOwnDirectory dir) = concat
1258        [ "You are not the owner of '"
1259        , toFilePath dir
1260        , "'. Aborting to protect file permissions."
1261        , "\nRetry with '--"
1262        , T.unpack configMonoidAllowDifferentUserName
1263        , "' to disable this precaution."
1264        ]
1265    show ManualGHCVariantSettingsAreIncompatibleWithSystemGHC = T.unpack $ T.concat
1266        [ "stack can only control the "
1267        , configMonoidGHCVariantName
1268        , " of its own GHC installations. Please use '--no-"
1269        , configMonoidSystemGHCName
1270        , "'."
1271        ]
1272    show NixRequiresSystemGhc = T.unpack $ T.concat
1273        [ "stack's Nix integration is incompatible with '--no-system-ghc'. "
1274        , "Please use '--"
1275        , configMonoidSystemGHCName
1276        , "' or disable the Nix integration."
1277        ]
1278    show NoResolverWhenUsingNoProject = "When using the script command, you must provide a resolver argument"
1279    show (DuplicateLocalPackageNames pairs) = concat
1280        $ "The same package name is used in multiple local packages\n"
1281        : map go pairs
1282      where
1283        go (name, dirs) = unlines
1284            $ ""
1285            : (packageNameString name ++ " used in:")
1286            : map goLoc dirs
1287        goLoc loc = "- " ++ show loc
1288instance Exception ConfigException
1289
1290resolveOptions :: String
1291resolveOptions =
1292  unlines [ "\nThis may be resolved by:"
1293          , "    - Using '--omit-packages' to exclude mismatching package(s)."
1294          , "    - Using '--resolver' to specify a matching snapshot/resolver"
1295          ]
1296
1297-- | Get the URL to request the information on the latest snapshots
1298askLatestSnapshotUrl :: (MonadReader env m, HasConfig env) => m Text
1299askLatestSnapshotUrl = view $ configL.to configLatestSnapshot
1300
1301-- | @".stack-work"@
1302workDirL :: HasConfig env => Lens' env (Path Rel Dir)
1303workDirL = configL.lens configWorkDir (\x y -> x { configWorkDir = y })
1304
1305-- | Per-project work dir
1306getProjectWorkDir :: (HasBuildConfig env, MonadReader env m) => m (Path Abs Dir)
1307getProjectWorkDir = do
1308    root    <- view projectRootL
1309    workDir <- view workDirL
1310    return (root </> workDir)
1311
1312-- | Relative directory for the platform identifier
1313platformOnlyRelDir
1314    :: (MonadReader env m, HasPlatform env, MonadThrow m)
1315    => m (Path Rel Dir)
1316platformOnlyRelDir = do
1317    platform <- view platformL
1318    platformVariant <- view platformVariantL
1319    parseRelDir (Distribution.Text.display platform ++ platformVariantSuffix platformVariant)
1320
1321-- | Directory containing snapshots
1322snapshotsDir :: (MonadReader env m, HasEnvConfig env, MonadThrow m) => m (Path Abs Dir)
1323snapshotsDir = do
1324    root <- view stackRootL
1325    platform <- platformGhcRelDir
1326    return $ root </> relDirSnapshots </> platform
1327
1328-- | Installation root for dependencies
1329installationRootDeps :: (HasEnvConfig env) => RIO env (Path Abs Dir)
1330installationRootDeps = do
1331    root <- view stackRootL
1332    -- TODO: also useShaPathOnWindows here, once #1173 is resolved.
1333    psc <- platformSnapAndCompilerRel
1334    return $ root </> relDirSnapshots </> psc
1335
1336-- | Installation root for locals
1337installationRootLocal :: (HasEnvConfig env) => RIO env (Path Abs Dir)
1338installationRootLocal = do
1339    workDir <- getProjectWorkDir
1340    psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel
1341    return $ workDir </> relDirInstall </> psc
1342
1343-- | Installation root for compiler tools
1344bindirCompilerTools :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
1345bindirCompilerTools = do
1346    config <- view configL
1347    platform <- platformGhcRelDir
1348    compilerVersion <- view actualCompilerVersionL
1349    compiler <- parseRelDir $ compilerVersionString compilerVersion
1350    return $
1351        view stackRootL config </>
1352        relDirCompilerTools </>
1353        platform </>
1354        compiler </>
1355        bindirSuffix
1356
1357-- | Hoogle directory.
1358hoogleRoot :: (HasEnvConfig env) => RIO env (Path Abs Dir)
1359hoogleRoot = do
1360    workDir <- getProjectWorkDir
1361    psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel
1362    return $ workDir </> relDirHoogle </> psc
1363
1364-- | Get the hoogle database path.
1365hoogleDatabasePath :: (HasEnvConfig env) => RIO env (Path Abs File)
1366hoogleDatabasePath = do
1367    dir <- hoogleRoot
1368    return (dir </> relFileDatabaseHoo)
1369
1370-- | Path for platform followed by snapshot name followed by compiler
1371-- name.
1372platformSnapAndCompilerRel
1373    :: (HasEnvConfig env)
1374    => RIO env (Path Rel Dir)
1375platformSnapAndCompilerRel = do
1376    platform <- platformGhcRelDir
1377    smh <- view $ envConfigL.to envConfigSourceMapHash
1378    name <- smRelDir smh
1379    ghc <- compilerVersionDir
1380    useShaPathOnWindows (platform </> name </> ghc)
1381
1382-- | Relative directory for the platform and GHC identifier
1383platformGhcRelDir
1384    :: (MonadReader env m, HasEnvConfig env, MonadThrow m)
1385    => m (Path Rel Dir)
1386platformGhcRelDir = do
1387    cp <- view compilerPathsL
1388    let cbSuffix = compilerBuildSuffix $ cpBuild cp
1389    verOnly <- platformGhcVerOnlyRelDirStr
1390    parseRelDir (mconcat [ verOnly, cbSuffix ])
1391
1392-- | Relative directory for the platform and GHC identifier without GHC bindist build
1393platformGhcVerOnlyRelDir
1394    :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m)
1395    => m (Path Rel Dir)
1396platformGhcVerOnlyRelDir =
1397    parseRelDir =<< platformGhcVerOnlyRelDirStr
1398
1399-- | Relative directory for the platform and GHC identifier without GHC bindist build
1400-- (before parsing into a Path)
1401platformGhcVerOnlyRelDirStr
1402    :: (MonadReader env m, HasPlatform env, HasGHCVariant env)
1403    => m FilePath
1404platformGhcVerOnlyRelDirStr = do
1405    platform <- view platformL
1406    platformVariant <- view platformVariantL
1407    ghcVariant <- view ghcVariantL
1408    return $ mconcat [ Distribution.Text.display platform
1409                     , platformVariantSuffix platformVariant
1410                     , ghcVariantSuffix ghcVariant ]
1411
1412-- | This is an attempt to shorten stack paths on Windows to decrease our
1413-- chances of hitting 260 symbol path limit. The idea is to calculate
1414-- SHA1 hash of the path used on other architectures, encode with base
1415-- 16 and take first 8 symbols of it.
1416useShaPathOnWindows :: MonadThrow m => Path Rel Dir -> m (Path Rel Dir)
1417useShaPathOnWindows
1418  | osIsWindows = shaPath
1419  | otherwise = pure
1420
1421shaPath :: (IsPath Rel t, MonadThrow m) => Path Rel t -> m (Path Rel t)
1422shaPath = shaPathForBytes . encodeUtf8 . T.pack . toFilePath
1423
1424shaPathForBytes :: (IsPath Rel t, MonadThrow m) => ByteString -> m (Path Rel t)
1425shaPathForBytes
1426    = parsePath . S8.unpack . S8.take 8
1427    . Mem.convertToBase Mem.Base16 . hashWith SHA1
1428
1429-- TODO: Move something like this into the path package. Consider
1430-- subsuming path-io's 'AnyPath'?
1431class IsPath b t where
1432  parsePath :: MonadThrow m => FilePath -> m (Path b t)
1433
1434instance IsPath Abs Dir where parsePath = parseAbsDir
1435instance IsPath Rel Dir where parsePath = parseRelDir
1436instance IsPath Abs File where parsePath = parseAbsFile
1437instance IsPath Rel File where parsePath = parseRelFile
1438
1439compilerVersionDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Rel Dir)
1440compilerVersionDir = do
1441    compilerVersion <- view actualCompilerVersionL
1442    parseRelDir $ case compilerVersion of
1443        ACGhc version -> versionString version
1444        ACGhcGit {} -> compilerVersionString compilerVersion
1445
1446-- | Package database for installing dependencies into
1447packageDatabaseDeps :: (HasEnvConfig env) => RIO env (Path Abs Dir)
1448packageDatabaseDeps = do
1449    root <- installationRootDeps
1450    return $ root </> relDirPkgdb
1451
1452-- | Package database for installing local packages into
1453packageDatabaseLocal :: (HasEnvConfig env) => RIO env (Path Abs Dir)
1454packageDatabaseLocal = do
1455    root <- installationRootLocal
1456    return $ root </> relDirPkgdb
1457
1458-- | Extra package databases
1459packageDatabaseExtra :: (MonadReader env m, HasEnvConfig env) => m [Path Abs Dir]
1460packageDatabaseExtra = view $ buildConfigL.to bcExtraPackageDBs
1461
1462-- | Where do we get information on global packages for loading up a
1463-- 'LoadedSnapshot'?
1464data GlobalInfoSource
1465  = GISSnapshotHints
1466  -- ^ Accept the hints in the snapshot definition
1467  | GISCompiler ActualCompiler
1468  -- ^ Look up the actual information in the installed compiler
1469
1470-- | Where HPC reports and tix files get stored.
1471hpcReportDir :: (HasEnvConfig env)
1472             => RIO env (Path Abs Dir)
1473hpcReportDir = do
1474   root <- installationRootLocal
1475   return $ root </> relDirHpc
1476
1477-- | Get the extra bin directories (for the PATH). Puts more local first
1478--
1479-- Bool indicates whether or not to include the locals
1480extraBinDirs :: (HasEnvConfig env)
1481             => RIO env (Bool -> [Path Abs Dir])
1482extraBinDirs = do
1483    deps <- installationRootDeps
1484    local' <- installationRootLocal
1485    tools <- bindirCompilerTools
1486    return $ \locals -> if locals
1487        then [local' </> bindirSuffix, deps </> bindirSuffix, tools]
1488        else [deps </> bindirSuffix, tools]
1489
1490minimalEnvSettings :: EnvSettings
1491minimalEnvSettings =
1492    EnvSettings
1493    { esIncludeLocals = False
1494    , esIncludeGhcPackagePath = False
1495    , esStackExe = False
1496    , esLocaleUtf8 = False
1497    , esKeepGhcRts = False
1498    }
1499
1500-- | Default @EnvSettings@ which includes locals and GHC_PACKAGE_PATH.
1501--
1502-- Note that this also passes through the GHCRTS environment variable.
1503-- See https://github.com/commercialhaskell/stack/issues/3444
1504defaultEnvSettings :: EnvSettings
1505defaultEnvSettings = EnvSettings
1506    { esIncludeLocals = True
1507    , esIncludeGhcPackagePath = True
1508    , esStackExe = True
1509    , esLocaleUtf8 = False
1510    , esKeepGhcRts = True
1511    }
1512
1513-- | Environment settings which do not embellish the environment
1514--
1515-- Note that this also passes through the GHCRTS environment variable.
1516-- See https://github.com/commercialhaskell/stack/issues/3444
1517plainEnvSettings :: EnvSettings
1518plainEnvSettings = EnvSettings
1519    { esIncludeLocals = False
1520    , esIncludeGhcPackagePath = False
1521    , esStackExe = False
1522    , esLocaleUtf8 = False
1523    , esKeepGhcRts = True
1524    }
1525
1526-- | Get the path for the given compiler ignoring any local binaries.
1527--
1528-- https://github.com/commercialhaskell/stack/issues/1052
1529getCompilerPath :: HasCompiler env => RIO env (Path Abs File)
1530getCompilerPath = view $ compilerPathsL.to cpCompiler
1531
1532data ProjectAndConfigMonoid
1533  = ProjectAndConfigMonoid !Project !ConfigMonoid
1534
1535parseProjectAndConfigMonoid :: Path Abs Dir -> Value -> Yaml.Parser (WithJSONWarnings (IO ProjectAndConfigMonoid))
1536parseProjectAndConfigMonoid rootDir =
1537    withObjectWarnings "ProjectAndConfigMonoid" $ \o -> do
1538        packages <- o ..:? "packages" ..!= [RelFilePath "."]
1539        deps <- jsonSubWarningsTT (o ..:? "extra-deps") ..!= []
1540        flags' <- o ..:? "flags" ..!= mempty
1541        let flags = unCabalStringMap <$> unCabalStringMap
1542                    (flags' :: Map (CabalString PackageName) (Map (CabalString FlagName) Bool))
1543
1544        resolver <- jsonSubWarnings $ o ...: ["snapshot", "resolver"]
1545        mcompiler <- o ..:? "compiler"
1546        msg <- o ..:? "user-message"
1547        config <- parseConfigMonoidObject rootDir o
1548        extraPackageDBs <- o ..:? "extra-package-dbs" ..!= []
1549        mcurator <- jsonSubWarningsT (o ..:? "curator")
1550        drops <- o ..:? "drop-packages" ..!= mempty
1551        return $ do
1552          deps' <- mapM (resolvePaths (Just rootDir)) deps
1553          resolver' <- resolvePaths (Just rootDir) resolver
1554          let project = Project
1555                  { projectUserMsg = msg
1556                  , projectResolver = resolver'
1557                  , projectCompiler = mcompiler -- FIXME make sure resolver' isn't SLCompiler
1558                  , projectExtraPackageDBs = extraPackageDBs
1559                  , projectPackages = packages
1560                  , projectDependencies = concatMap toList (deps' :: [NonEmpty RawPackageLocation])
1561                  , projectFlags = flags
1562                  , projectCurator = mcurator
1563                  , projectDropPackages = Set.map unCabalString drops
1564                  }
1565          pure $ ProjectAndConfigMonoid project config
1566
1567-- | A software control system.
1568data SCM = Git
1569  deriving (Show)
1570
1571instance FromJSON SCM where
1572    parseJSON v = do
1573        s <- parseJSON v
1574        case s of
1575            "git" -> return Git
1576            _ -> fail ("Unknown or unsupported SCM: " <> s)
1577
1578instance ToJSON SCM where
1579    toJSON Git = toJSON ("git" :: Text)
1580
1581-- | A variant of the platform, used to differentiate Docker builds from host
1582data PlatformVariant = PlatformVariantNone
1583                     | PlatformVariant String
1584
1585-- | Render a platform variant to a String suffix.
1586platformVariantSuffix :: PlatformVariant -> String
1587platformVariantSuffix PlatformVariantNone = ""
1588platformVariantSuffix (PlatformVariant v) = "-" ++ v
1589
1590-- | Specialized bariant of GHC (e.g. libgmp4 or integer-simple)
1591data GHCVariant
1592    = GHCStandard -- ^ Standard bindist
1593    | GHCIntegerSimple -- ^ Bindist that uses integer-simple
1594    | GHCCustom String -- ^ Other bindists
1595    deriving (Show)
1596
1597instance FromJSON GHCVariant where
1598    -- Strange structuring is to give consistent error messages
1599    parseJSON =
1600        withText
1601            "GHCVariant"
1602            (either (fail . show) return . parseGHCVariant . T.unpack)
1603
1604-- | Render a GHC variant to a String.
1605ghcVariantName :: GHCVariant -> String
1606ghcVariantName GHCStandard = "standard"
1607ghcVariantName GHCIntegerSimple = "integersimple"
1608ghcVariantName (GHCCustom name) = "custom-" ++ name
1609
1610-- | Render a GHC variant to a String suffix.
1611ghcVariantSuffix :: GHCVariant -> String
1612ghcVariantSuffix GHCStandard = ""
1613ghcVariantSuffix v = "-" ++ ghcVariantName v
1614
1615-- | Parse GHC variant from a String.
1616parseGHCVariant :: (MonadThrow m) => String -> m GHCVariant
1617parseGHCVariant s =
1618    case stripPrefix "custom-" s of
1619        Just name -> return (GHCCustom name)
1620        Nothing
1621          | s == "" -> return GHCStandard
1622          | s == "standard" -> return GHCStandard
1623          | s == "integersimple" -> return GHCIntegerSimple
1624          | otherwise -> return (GHCCustom s)
1625
1626-- | Build of the compiler distribution (e.g. standard, gmp4, tinfo6)
1627-- | Information for a file to download.
1628data DownloadInfo = DownloadInfo
1629    { downloadInfoUrl :: Text
1630      -- ^ URL or absolute file path
1631    , downloadInfoContentLength :: Maybe Int
1632    , downloadInfoSha1 :: Maybe ByteString
1633    , downloadInfoSha256 :: Maybe ByteString
1634    } deriving (Show)
1635
1636instance FromJSON (WithJSONWarnings DownloadInfo) where
1637    parseJSON = withObjectWarnings "DownloadInfo" parseDownloadInfoFromObject
1638
1639-- | Parse JSON in existing object for 'DownloadInfo'
1640parseDownloadInfoFromObject :: Object -> WarningParser DownloadInfo
1641parseDownloadInfoFromObject o = do
1642    url <- o ..: "url"
1643    contentLength <- o ..:? "content-length"
1644    sha1TextMay <- o ..:? "sha1"
1645    sha256TextMay <- o ..:? "sha256"
1646    return
1647        DownloadInfo
1648        { downloadInfoUrl = url
1649        , downloadInfoContentLength = contentLength
1650        , downloadInfoSha1 = fmap encodeUtf8 sha1TextMay
1651        , downloadInfoSha256 = fmap encodeUtf8 sha256TextMay
1652        }
1653
1654data VersionedDownloadInfo = VersionedDownloadInfo
1655    { vdiVersion :: Version
1656    , vdiDownloadInfo :: DownloadInfo
1657    }
1658    deriving Show
1659
1660instance FromJSON (WithJSONWarnings VersionedDownloadInfo) where
1661    parseJSON = withObjectWarnings "VersionedDownloadInfo" $ \o -> do
1662        CabalString version <- o ..: "version"
1663        downloadInfo <- parseDownloadInfoFromObject o
1664        return VersionedDownloadInfo
1665            { vdiVersion = version
1666            , vdiDownloadInfo = downloadInfo
1667            }
1668
1669data GHCDownloadInfo = GHCDownloadInfo
1670    { gdiConfigureOpts :: [Text]
1671    , gdiConfigureEnv :: Map Text Text
1672    , gdiDownloadInfo :: DownloadInfo
1673    }
1674    deriving Show
1675
1676instance FromJSON (WithJSONWarnings GHCDownloadInfo) where
1677    parseJSON = withObjectWarnings "GHCDownloadInfo" $ \o -> do
1678        configureOpts <- o ..:? "configure-opts" ..!= mempty
1679        configureEnv <- o ..:? "configure-env" ..!= mempty
1680        downloadInfo <- parseDownloadInfoFromObject o
1681        return GHCDownloadInfo
1682            { gdiConfigureOpts = configureOpts
1683            , gdiConfigureEnv = configureEnv
1684            , gdiDownloadInfo = downloadInfo
1685            }
1686
1687data SetupInfo = SetupInfo
1688    { siSevenzExe :: Maybe DownloadInfo
1689    , siSevenzDll :: Maybe DownloadInfo
1690    , siMsys2 :: Map Text VersionedDownloadInfo
1691    , siGHCs :: Map Text (Map Version GHCDownloadInfo)
1692    , siStack :: Map Text (Map Version DownloadInfo)
1693    }
1694    deriving Show
1695
1696instance FromJSON (WithJSONWarnings SetupInfo) where
1697    parseJSON = withObjectWarnings "SetupInfo" $ \o -> do
1698        siSevenzExe <- jsonSubWarningsT (o ..:? "sevenzexe-info")
1699        siSevenzDll <- jsonSubWarningsT (o ..:? "sevenzdll-info")
1700        siMsys2 <- jsonSubWarningsT (o ..:? "msys2" ..!= mempty)
1701        (fmap unCabalStringMap -> siGHCs) <- jsonSubWarningsTT (o ..:? "ghc" ..!= mempty)
1702        (fmap unCabalStringMap -> siStack) <- jsonSubWarningsTT (o ..:? "stack" ..!= mempty)
1703        return SetupInfo {..}
1704
1705-- | For the @siGHCs@ field maps are deeply merged.
1706-- For all fields the values from the first @SetupInfo@ win.
1707instance Semigroup SetupInfo where
1708    l <> r =
1709        SetupInfo
1710        { siSevenzExe = siSevenzExe l <|> siSevenzExe r
1711        , siSevenzDll = siSevenzDll l <|> siSevenzDll r
1712        , siMsys2 = siMsys2 l <> siMsys2 r
1713        , siGHCs = Map.unionWith (<>) (siGHCs l) (siGHCs r)
1714        , siStack = Map.unionWith (<>) (siStack l) (siStack r) }
1715
1716instance Monoid SetupInfo where
1717    mempty =
1718        SetupInfo
1719        { siSevenzExe = Nothing
1720        , siSevenzDll = Nothing
1721        , siMsys2 = Map.empty
1722        , siGHCs = Map.empty
1723        , siStack = Map.empty
1724        }
1725    mappend = (<>)
1726
1727-- | How PVP bounds should be added to .cabal files
1728data PvpBoundsType
1729  = PvpBoundsNone
1730  | PvpBoundsUpper
1731  | PvpBoundsLower
1732  | PvpBoundsBoth
1733  deriving (Show, Read, Eq, Typeable, Ord, Enum, Bounded)
1734
1735data PvpBounds = PvpBounds
1736  { pbType :: !PvpBoundsType
1737  , pbAsRevision :: !Bool
1738  }
1739  deriving (Show, Read, Eq, Typeable, Ord)
1740
1741pvpBoundsText :: PvpBoundsType -> Text
1742pvpBoundsText PvpBoundsNone = "none"
1743pvpBoundsText PvpBoundsUpper = "upper"
1744pvpBoundsText PvpBoundsLower = "lower"
1745pvpBoundsText PvpBoundsBoth = "both"
1746
1747parsePvpBounds :: Text -> Either String PvpBounds
1748parsePvpBounds t = maybe err Right $ do
1749    (t', asRevision) <-
1750      case T.break (== '-') t of
1751        (x, "") -> Just (x, False)
1752        (x, "-revision") -> Just (x, True)
1753        _ -> Nothing
1754    x <- Map.lookup t' m
1755    Just PvpBounds
1756      { pbType = x
1757      , pbAsRevision = asRevision
1758      }
1759  where
1760    m = Map.fromList $ map (pvpBoundsText &&& id) [minBound..maxBound]
1761    err = Left $ "Invalid PVP bounds: " ++ T.unpack t
1762
1763instance ToJSON PvpBounds where
1764  toJSON (PvpBounds typ asRevision) =
1765    toJSON (pvpBoundsText typ <> (if asRevision then "-revision" else ""))
1766instance FromJSON PvpBounds where
1767  parseJSON = withText "PvpBounds" (either fail return . parsePvpBounds)
1768
1769-- | Data passed into Docker container for the Docker entrypoint's use
1770newtype DockerEntrypoint = DockerEntrypoint
1771    { deUser :: Maybe DockerUser
1772      -- ^ UID/GID/etc of host user, if we wish to perform UID/GID switch in container
1773    } deriving (Read,Show)
1774
1775-- | Docker host user info
1776data DockerUser = DockerUser
1777    { duUid :: UserID -- ^ uid
1778    , duGid :: GroupID -- ^ gid
1779    , duGroups :: [GroupID] -- ^ Supplemantal groups
1780    , duUmask :: FileMode -- ^ File creation mask }
1781    } deriving (Read,Show)
1782
1783data GhcOptionKey
1784  = GOKOldEverything
1785  | GOKEverything
1786  | GOKLocals
1787  | GOKTargets
1788  | GOKPackage !PackageName
1789  deriving (Eq, Ord)
1790
1791instance FromJSONKey GhcOptionKey where
1792  fromJSONKey = FromJSONKeyTextParser $ \t ->
1793    case t of
1794      "*" -> return GOKOldEverything
1795      "$everything" -> return GOKEverything
1796      "$locals" -> return GOKLocals
1797      "$targets" -> return GOKTargets
1798      _ ->
1799        case parsePackageName $ T.unpack t of
1800          Nothing -> fail $ "Invalid package name: " ++ show t
1801          Just x -> return $ GOKPackage x
1802  fromJSONKeyList = FromJSONKeyTextParser $ \_ -> fail "GhcOptionKey.fromJSONKeyList"
1803
1804newtype GhcOptions = GhcOptions { unGhcOptions :: [Text] }
1805
1806instance FromJSON GhcOptions where
1807  parseJSON = withText "GhcOptions" $ \t ->
1808    case parseArgs Escaping t of
1809      Left e -> fail e
1810      Right opts -> return $ GhcOptions $ map T.pack opts
1811
1812-----------------------------------
1813-- Lens classes
1814-----------------------------------
1815
1816-- | Class for environment values which have a Platform
1817class HasPlatform env where
1818    platformL :: Lens' env Platform
1819    default platformL :: HasConfig env => Lens' env Platform
1820    platformL = configL.platformL
1821    {-# INLINE platformL #-}
1822    platformVariantL :: Lens' env PlatformVariant
1823    default platformVariantL :: HasConfig env => Lens' env PlatformVariant
1824    platformVariantL = configL.platformVariantL
1825    {-# INLINE platformVariantL #-}
1826
1827-- | Class for environment values which have a GHCVariant
1828class HasGHCVariant env where
1829    ghcVariantL :: SimpleGetter env GHCVariant
1830    default ghcVariantL :: HasConfig env => SimpleGetter env GHCVariant
1831    ghcVariantL = configL.ghcVariantL
1832    {-# INLINE ghcVariantL #-}
1833
1834-- | Class for environment values which have a 'Runner'.
1835class (HasProcessContext env, HasLogFunc env) => HasRunner env where
1836  runnerL :: Lens' env Runner
1837instance HasLogFunc Runner where
1838  logFuncL = lens runnerLogFunc (\x y -> x { runnerLogFunc = y })
1839instance HasProcessContext Runner where
1840  processContextL = lens runnerProcessContext (\x y -> x { runnerProcessContext = y })
1841instance HasRunner Runner where
1842  runnerL = id
1843instance HasStylesUpdate Runner where
1844  stylesUpdateL = globalOptsL.
1845                  lens globalStylesUpdate (\x y -> x { globalStylesUpdate = y })
1846instance HasTerm Runner where
1847  useColorL = lens runnerUseColor (\x y -> x { runnerUseColor = y })
1848  termWidthL = lens runnerTermWidth (\x y -> x { runnerTermWidth = y })
1849
1850globalOptsL :: HasRunner env => Lens' env GlobalOpts
1851globalOptsL = runnerL.lens runnerGlobalOpts (\x y -> x { runnerGlobalOpts = y })
1852
1853-- | Class for environment values that can provide a 'Config'.
1854class (HasPlatform env, HasGHCVariant env, HasProcessContext env, HasPantryConfig env, HasTerm env, HasRunner env) => HasConfig env where
1855    configL :: Lens' env Config
1856    default configL :: HasBuildConfig env => Lens' env Config
1857    configL = buildConfigL.lens bcConfig (\x y -> x { bcConfig = y })
1858    {-# INLINE configL #-}
1859
1860class HasConfig env => HasBuildConfig env where
1861    buildConfigL :: Lens' env BuildConfig
1862    default buildConfigL :: HasEnvConfig env => Lens' env BuildConfig
1863    buildConfigL = envConfigL.lens
1864        envConfigBuildConfig
1865        (\x y -> x { envConfigBuildConfig = y })
1866
1867class (HasBuildConfig env, HasSourceMap env, HasCompiler env) => HasEnvConfig env where
1868    envConfigL :: Lens' env EnvConfig
1869
1870-----------------------------------
1871-- Lens instances
1872-----------------------------------
1873
1874instance HasPlatform (Platform,PlatformVariant) where
1875    platformL = _1
1876    platformVariantL = _2
1877instance HasPlatform Config where
1878    platformL = lens configPlatform (\x y -> x { configPlatform = y })
1879    platformVariantL = lens configPlatformVariant (\x y -> x { configPlatformVariant = y })
1880instance HasPlatform BuildConfig
1881instance HasPlatform EnvConfig
1882
1883instance HasGHCVariant GHCVariant where
1884    ghcVariantL = id
1885    {-# INLINE ghcVariantL #-}
1886instance HasGHCVariant Config where
1887    ghcVariantL = to $ fromMaybe GHCStandard . configGHCVariant
1888instance HasGHCVariant BuildConfig
1889instance HasGHCVariant EnvConfig
1890
1891instance HasProcessContext Config where
1892    processContextL = runnerL.processContextL
1893instance HasProcessContext BuildConfig where
1894    processContextL = configL.processContextL
1895instance HasProcessContext EnvConfig where
1896    processContextL = configL.processContextL
1897
1898instance HasPantryConfig Config where
1899    pantryConfigL = lens configPantryConfig (\x y -> x { configPantryConfig = y })
1900instance HasPantryConfig BuildConfig where
1901    pantryConfigL = configL.pantryConfigL
1902instance HasPantryConfig EnvConfig where
1903    pantryConfigL = configL.pantryConfigL
1904
1905instance HasConfig Config where
1906    configL = id
1907    {-# INLINE configL #-}
1908instance HasConfig BuildConfig where
1909    configL = lens bcConfig (\x y -> x { bcConfig = y })
1910instance HasConfig EnvConfig
1911
1912instance HasBuildConfig BuildConfig where
1913    buildConfigL = id
1914    {-# INLINE buildConfigL #-}
1915instance HasBuildConfig EnvConfig
1916
1917instance HasCompiler EnvConfig where
1918    compilerPathsL = to envConfigCompilerPaths
1919instance HasEnvConfig EnvConfig where
1920    envConfigL = id
1921    {-# INLINE envConfigL #-}
1922
1923instance HasRunner Config where
1924  runnerL = lens configRunner (\x y -> x { configRunner = y })
1925instance HasRunner BuildConfig where
1926  runnerL = configL.runnerL
1927instance HasRunner EnvConfig where
1928  runnerL = configL.runnerL
1929
1930instance HasLogFunc Config where
1931  logFuncL = runnerL.logFuncL
1932instance HasLogFunc BuildConfig where
1933  logFuncL = runnerL.logFuncL
1934instance HasLogFunc EnvConfig where
1935  logFuncL = runnerL.logFuncL
1936
1937instance HasStylesUpdate Config where
1938  stylesUpdateL = runnerL.stylesUpdateL
1939instance HasStylesUpdate BuildConfig where
1940  stylesUpdateL = runnerL.stylesUpdateL
1941instance HasStylesUpdate EnvConfig where
1942  stylesUpdateL = runnerL.stylesUpdateL
1943
1944instance HasTerm Config where
1945  useColorL = runnerL.useColorL
1946  termWidthL = runnerL.termWidthL
1947instance HasTerm BuildConfig where
1948  useColorL = runnerL.useColorL
1949  termWidthL = runnerL.termWidthL
1950instance HasTerm EnvConfig where
1951  useColorL = runnerL.useColorL
1952  termWidthL = runnerL.termWidthL
1953
1954-----------------------------------
1955-- Helper lenses
1956-----------------------------------
1957
1958stackRootL :: HasConfig s => Lens' s (Path Abs Dir)
1959stackRootL = configL.lens configStackRoot (\x y -> x { configStackRoot = y })
1960
1961-- | The compiler specified by the @SnapshotDef@. This may be
1962-- different from the actual compiler used!
1963wantedCompilerVersionL :: HasBuildConfig s => Getting r s WantedCompiler
1964wantedCompilerVersionL = buildConfigL.to (smwCompiler . bcSMWanted)
1965
1966-- | Location of the ghc-pkg executable
1967newtype GhcPkgExe = GhcPkgExe (Path Abs File)
1968  deriving Show
1969
1970-- | Get the 'GhcPkgExe' from a 'HasCompiler' environment
1971getGhcPkgExe :: HasCompiler env => RIO env GhcPkgExe
1972getGhcPkgExe = view $ compilerPathsL.to cpPkg
1973
1974-- | Dump information for a single package
1975data DumpPackage = DumpPackage
1976    { dpGhcPkgId :: !GhcPkgId
1977    , dpPackageIdent :: !PackageIdentifier
1978    , dpParentLibIdent :: !(Maybe PackageIdentifier)
1979    , dpLicense :: !(Maybe C.License)
1980    , dpLibDirs :: ![FilePath]
1981    , dpLibraries :: ![Text]
1982    , dpHasExposedModules :: !Bool
1983    , dpExposedModules :: !(Set ModuleName)
1984    , dpDepends :: ![GhcPkgId]
1985    , dpHaddockInterfaces :: ![FilePath]
1986    , dpHaddockHtml :: !(Maybe FilePath)
1987    , dpIsExposed :: !Bool
1988    }
1989    deriving (Show, Read, Eq)
1990
1991-- | Paths on the filesystem for the compiler we're using
1992data CompilerPaths = CompilerPaths
1993  { cpCompilerVersion :: !ActualCompiler
1994  , cpArch :: !Arch
1995  , cpBuild :: !CompilerBuild
1996  , cpCompiler :: !(Path Abs File)
1997  -- | ghc-pkg or equivalent
1998  , cpPkg :: !GhcPkgExe
1999  -- | runghc
2000  , cpInterpreter :: !(Path Abs File)
2001  -- | haddock, in 'IO' to allow deferring the lookup
2002  , cpHaddock :: !(Path Abs File)
2003  -- | Is this a Stack-sandboxed installation?
2004  , cpSandboxed :: !Bool
2005  , cpCabalVersion :: !Version
2006  -- ^ This is the version of Cabal that stack will use to compile Setup.hs files
2007  -- in the build process.
2008  --
2009  -- Note that this is not necessarily the same version as the one that stack
2010  -- depends on as a library and which is displayed when running
2011  -- @stack ls dependencies | grep Cabal@ in the stack project.
2012  , cpGlobalDB :: !(Path Abs Dir)
2013  -- ^ Global package database
2014  , cpGhcInfo :: !ByteString
2015  -- ^ Output of @ghc --info@
2016  , cpGlobalDump :: !(Map PackageName DumpPackage)
2017  }
2018  deriving Show
2019
2020cpWhich :: (MonadReader env m, HasCompiler env) => m WhichCompiler
2021cpWhich = view $ compilerPathsL.to (whichCompiler.cpCompilerVersion)
2022
2023data ExtraDirs = ExtraDirs
2024    { edBins :: ![Path Abs Dir]
2025    , edInclude :: ![Path Abs Dir]
2026    , edLib :: ![Path Abs Dir]
2027    } deriving (Show, Generic)
2028instance Semigroup ExtraDirs where
2029    (<>) = mappenddefault
2030instance Monoid ExtraDirs where
2031    mempty = memptydefault
2032    mappend = (<>)
2033
2034-- | An environment which ensures that the given compiler is available
2035-- on the PATH
2036class HasCompiler env where
2037  compilerPathsL :: SimpleGetter env CompilerPaths
2038instance HasCompiler CompilerPaths where
2039  compilerPathsL = id
2040
2041class HasSourceMap env where
2042  sourceMapL :: Lens' env SourceMap
2043instance HasSourceMap EnvConfig where
2044  sourceMapL = lens envConfigSourceMap (\x y -> x { envConfigSourceMap = y })
2045
2046-- | The version of the compiler which will actually be used. May be
2047-- different than that specified in the 'SnapshotDef' and returned
2048-- by 'wantedCompilerVersionL'.
2049actualCompilerVersionL :: HasSourceMap env => SimpleGetter env ActualCompiler
2050actualCompilerVersionL = sourceMapL.to smCompiler
2051
2052buildOptsL :: HasConfig s => Lens' s BuildOpts
2053buildOptsL = configL.lens
2054    configBuild
2055    (\x y -> x { configBuild = y })
2056
2057buildOptsMonoidHaddockL :: Lens' BuildOptsMonoid (Maybe Bool)
2058buildOptsMonoidHaddockL = lens (getFirstFalse . buildMonoidHaddock)
2059                            (\buildMonoid t -> buildMonoid {buildMonoidHaddock = FirstFalse t})
2060
2061buildOptsMonoidTestsL :: Lens' BuildOptsMonoid (Maybe Bool)
2062buildOptsMonoidTestsL = lens (getFirstFalse . buildMonoidTests)
2063                            (\buildMonoid t -> buildMonoid {buildMonoidTests = FirstFalse t})
2064
2065buildOptsMonoidBenchmarksL :: Lens' BuildOptsMonoid (Maybe Bool)
2066buildOptsMonoidBenchmarksL = lens (getFirstFalse . buildMonoidBenchmarks)
2067                            (\buildMonoid t -> buildMonoid {buildMonoidBenchmarks = FirstFalse t})
2068
2069buildOptsMonoidInstallExesL :: Lens' BuildOptsMonoid (Maybe Bool)
2070buildOptsMonoidInstallExesL =
2071  lens (getFirstFalse . buildMonoidInstallExes)
2072       (\buildMonoid t -> buildMonoid {buildMonoidInstallExes = FirstFalse t})
2073
2074buildOptsInstallExesL :: Lens' BuildOpts Bool
2075buildOptsInstallExesL =
2076  lens boptsInstallExes
2077       (\bopts t -> bopts {boptsInstallExes = t})
2078
2079buildOptsHaddockL :: Lens' BuildOpts Bool
2080buildOptsHaddockL =
2081  lens boptsHaddock
2082       (\bopts t -> bopts {boptsHaddock = t})
2083
2084globalOptsBuildOptsMonoidL :: Lens' GlobalOpts BuildOptsMonoid
2085globalOptsBuildOptsMonoidL =
2086  lens
2087    globalConfigMonoid
2088    (\x y -> x { globalConfigMonoid = y })
2089  .
2090  lens
2091    configMonoidBuildOpts
2092    (\x y -> x { configMonoidBuildOpts = y })
2093
2094cabalVersionL :: HasCompiler env => SimpleGetter env Version
2095cabalVersionL = compilerPathsL.to cpCabalVersion
2096
2097whichCompilerL :: Getting r ActualCompiler WhichCompiler
2098whichCompilerL = to whichCompiler
2099
2100envOverrideSettingsL :: HasConfig env => Lens' env (EnvSettings -> IO ProcessContext)
2101envOverrideSettingsL = configL.lens
2102    configProcessContextSettings
2103    (\x y -> x { configProcessContextSettings = y })
2104
2105shouldForceGhcColorFlag :: (HasRunner env, HasEnvConfig env)
2106                        => RIO env Bool
2107shouldForceGhcColorFlag = do
2108    canDoColor <- (>= mkVersion [8, 2, 1]) . getGhcVersion
2109              <$> view actualCompilerVersionL
2110    shouldDoColor <- view useColorL
2111    return $ canDoColor && shouldDoColor
2112
2113appropriateGhcColorFlag :: (HasRunner env, HasEnvConfig env)
2114                        => RIO env (Maybe String)
2115appropriateGhcColorFlag = f <$> shouldForceGhcColorFlag
2116  where f True = Just ghcColorForceFlag
2117        f False = Nothing
2118
2119-- | See 'globalTerminal'
2120terminalL :: HasRunner env => Lens' env Bool
2121terminalL = globalOptsL.lens globalTerminal (\x y -> x { globalTerminal = y })
2122
2123-- | See 'globalReExecVersion'
2124reExecL :: HasRunner env => SimpleGetter env Bool
2125reExecL = globalOptsL.to (isJust . globalReExecVersion)
2126
2127-- | In dev mode, print as a warning, otherwise as debug
2128prettyStackDevL :: HasConfig env => [StyleDoc] -> RIO env ()
2129prettyStackDevL docs = do
2130  config <- view configL
2131  if configStackDeveloperMode config
2132    then prettyWarnL docs
2133    else prettyDebugL docs
2134