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