cabal-install/src/Distribution/Client/Config.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE DeriveGeneric #-}
   3
   4 -----------------------------------------------------------------------------
   5
   6 -----------------------------------------------------------------------------
   7
   8 -- |
   9 -- Module      :  Distribution.Client.Config
  10 -- Copyright   :  (c) David Himmelstrup 2005
  11 -- License     :  BSD-like
  12 --
  13 -- Maintainer  :  lemmih@gmail.com
  14 -- Stability   :  provisional
  15 -- Portability :  portable
  16 --
  17 -- Utilities for handling saved state such as known packages, known servers and
  18 -- downloaded packages.
  19 module Distribution.Client.Config
  20   ( SavedConfig (..)
  21   , loadConfig
  22   , getConfigFilePath
  23   , showConfig
  24   , showConfigWithComments
  25   , parseConfig
  26   , defaultConfigFile
  27   , defaultCacheDir
  28   , defaultCacheHome
  29   , defaultScriptBuildsDir
  30   , defaultStoreDir
  31   , defaultCompiler
  32   , defaultInstallPath
  33   , defaultLogsDir
  34   , defaultReportsDir
  35   , defaultUserInstall
  36   , baseSavedConfig
  37   , commentSavedConfig
  38   , initialSavedConfig
  39   , configFieldDescriptions
  40   , haddockFlagsFields
  41   , installDirsFields
  42   , withProgramsFields
  43   , withProgramOptionsFields
  44   , userConfigDiff
  45   , userConfigUpdate
  46   , createDefaultConfigFile
  47   , remoteRepoFields
  48   , postProcessRepo
  49   ) where
  50
  51 import Distribution.Client.Compat.Prelude
  52 import Distribution.Compat.Environment (lookupEnv)
  53 import Prelude ()
  54
  55 import Language.Haskell.Extension (Language (Haskell2010))
  56
  57 import Distribution.Deprecated.ViewAsFieldDescr
  58   ( viewAsFieldDescr
  59   )
  60
  61 import Distribution.Client.BuildReports.Types
  62   ( ReportLevel (..)
  63   )
  64 import Distribution.Client.CmdInstall.ClientInstallFlags
  65   ( ClientInstallFlags (..)
  66   , clientInstallOptions
  67   , defaultClientInstallFlags
  68   )
  69 import qualified Distribution.Client.Init.Defaults as IT
  70 import qualified Distribution.Client.Init.Types as IT
  71   ( InitFlags (..)
  72   )
  73 import Distribution.Client.Setup
  74   ( ConfigExFlags (..)
  75   , GlobalFlags (..)
  76   , InstallFlags (..)
  77   , ReportFlags (..)
  78   , UploadFlags (..)
  79   , configureExOptions
  80   , defaultConfigExFlags
  81   , defaultGlobalFlags
  82   , defaultInstallFlags
  83   , globalCommand
  84   , initOptions
  85   , installOptions
  86   , reportCommand
  87   , uploadCommand
  88   )
  89 import Distribution.Client.Types
  90   ( AllowNewer (..)
  91   , AllowOlder (..)
  92   , LocalRepo (..)
  93   , RelaxDeps (..)
  94   , RemoteRepo (..)
  95   , RepoName (..)
  96   , emptyRemoteRepo
  97   , isRelaxDeps
  98   , unRepoName
  99   )
 100 import Distribution.Client.Types.Credentials
 101   ( Password (..)
 102   , Token (..)
 103   , Username (..)
 104   )
 105 import Distribution.Utils.NubList
 106   ( NubList
 107   , fromNubList
 108   , overNubList
 109   , toNubList
 110   )
 111
 112 import qualified Data.ByteString as BS
 113 import qualified Data.Map as M
 114 import Distribution.Client.Errors
 115 import Distribution.Client.HttpUtils
 116   ( isOldHackageURI
 117   )
 118 import Distribution.Client.ParseUtils
 119   ( parseFields
 120   , ppFields
 121   , ppSection
 122   )
 123 import Distribution.Client.ProjectFlags (ProjectFlags (..))
 124 import Distribution.Client.ReplFlags
 125 import Distribution.Client.Version
 126   ( cabalInstallVersion
 127   )
 128 import qualified Distribution.Compat.CharParsing as P
 129 import Distribution.Compat.Environment
 130   ( getEnvironment
 131   )
 132 import Distribution.Compiler
 133   ( CompilerFlavor (..)
 134   , defaultCompilerFlavor
 135   )
 136 import Distribution.Deprecated.ParseUtils
 137   ( FieldDescr (..)
 138   , PError (..)
 139   , PWarning (..)
 140   , ParseResult (..)
 141   , liftField
 142   , lineNo
 143   , listField
 144   , listFieldParsec
 145   , locatedErrorMsg
 146   , parseOptCommaList
 147   , parseTokenQ
 148   , readFields
 149   , runP
 150   , showPWarning
 151   , simpleField
 152   , simpleFieldParsec
 153   , spaceListField
 154   , syntaxError
 155   , warning
 156   )
 157 import qualified Distribution.Deprecated.ParseUtils as ParseUtils
 158   ( Field (..)
 159   )
 160 import Distribution.Parsec (ParsecParser, parsecFilePath, parsecOptCommaList, parsecToken)
 161 import Distribution.Simple.Command
 162   ( CommandUI (commandOptions)
 163   , ShowOrParseArgs (..)
 164   , commandDefaultFlags
 165   )
 166 import Distribution.Simple.Compiler
 167   ( DebugInfoLevel (..)
 168   , OptimisationLevel (..)
 169   )
 170 import Distribution.Simple.InstallDirs
 171   ( InstallDirs (..)
 172   , PathTemplate
 173   , defaultInstallDirs
 174   , toPathTemplate
 175   )
 176 import Distribution.Simple.Program
 177   ( defaultProgramDb
 178   )
 179 import Distribution.Simple.Setup
 180   ( BenchmarkFlags (..)
 181   , CommonSetupFlags (..)
 182   , ConfigFlags (..)
 183   , Flag (..)
 184   , HaddockFlags (..)
 185   , TestFlags (..)
 186   , configureOptions
 187   , defaultBenchmarkFlags
 188   , defaultConfigFlags
 189   , defaultHaddockFlags
 190   , defaultTestFlags
 191   , flagToMaybe
 192   , fromFlagOrDefault
 193   , haddockOptions
 194   , installDirsOptions
 195   , optionDistPref
 196   , programDbOptions
 197   , programDbPaths'
 198   , toFlag
 199   )
 200 import Distribution.Simple.Utils
 201   ( cabalVersion
 202   , dieWithException
 203   , lowercase
 204   , notice
 205   , toUTF8BS
 206   , warn
 207   )
 208 import Distribution.Solver.Types.ConstraintSource
 209 import Distribution.Utils.Path (getSymbolicPath, unsafeMakeSymbolicPath)
 210 import Distribution.Verbosity
 211   ( normal
 212   )
 213 import Network.URI
 214   ( URI (..)
 215   , URIAuth (..)
 216   , parseURI
 217   )
 218 import System.Directory
 219   ( XdgDirectory (XdgCache, XdgConfig, XdgState)
 220   , createDirectoryIfMissing
 221   , doesDirectoryExist
 222   , doesFileExist
 223   , getAppUserDataDirectory
 224   , getHomeDirectory
 225   , getXdgDirectory
 226   , renameFile
 227   )
 228 import System.FilePath
 229   ( takeDirectory
 230   , (<.>)
 231   , (</>)
 232   )
 233 import System.IO.Error
 234   ( isDoesNotExistError
 235   )
 236 import Text.PrettyPrint
 237   ( ($+$)
 238   )
 239 import qualified Text.PrettyPrint as Disp
 240   ( empty
 241   , render
 242   , text
 243   )
 244 import Text.PrettyPrint.HughesPJ
 245   ( Doc
 246   , text
 247   )
 248
 249 --
 250
 251 -- * Configuration saved in the config file
 252
 253 --
 254
 255 data SavedConfig = SavedConfig
 256   { savedGlobalFlags :: GlobalFlags
 257   , savedInitFlags :: IT.InitFlags
 258   , savedInstallFlags :: InstallFlags
 259   , savedClientInstallFlags :: ClientInstallFlags
 260   , savedConfigureFlags :: ConfigFlags
 261   , savedConfigureExFlags :: ConfigExFlags
 262   , savedUserInstallDirs :: InstallDirs (Flag PathTemplate)
 263   , savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate)
 264   , savedUploadFlags :: UploadFlags
 265   , savedReportFlags :: ReportFlags
 266   , savedHaddockFlags :: HaddockFlags
 267   , savedTestFlags :: TestFlags
 268   , savedBenchmarkFlags :: BenchmarkFlags
 269   , savedProjectFlags :: ProjectFlags
 270   , savedReplMulti :: Flag Bool
 271   }
 272   deriving (Generic)
 273
 274 instance Monoid SavedConfig where
 275   mempty = gmempty
 276   mappend = (<>)
 277
 278 instance Semigroup SavedConfig where
 279   a <> b =
 280     SavedConfig
 281       { savedGlobalFlags = combinedSavedGlobalFlags
 282       , savedInitFlags = combinedSavedInitFlags
 283       , savedInstallFlags = combinedSavedInstallFlags
 284       , savedClientInstallFlags = combinedSavedClientInstallFlags
 285       , savedConfigureFlags = combinedSavedConfigureFlags
 286       , savedConfigureExFlags = combinedSavedConfigureExFlags
 287       , savedUserInstallDirs = combinedSavedUserInstallDirs
 288       , savedGlobalInstallDirs = combinedSavedGlobalInstallDirs
 289       , savedUploadFlags = combinedSavedUploadFlags
 290       , savedReportFlags = combinedSavedReportFlags
 291       , savedHaddockFlags = combinedSavedHaddockFlags
 292       , savedTestFlags = combinedSavedTestFlags
 293       , savedBenchmarkFlags = combinedSavedBenchmarkFlags
 294       , savedProjectFlags = combinedSavedProjectFlags
 295       , savedReplMulti = combinedSavedReplMulti
 296       }
 297     where
 298       -- This is ugly, but necessary. If we're mappending two config files, we
 299       -- want the values of the *non-empty* list fields from the second one to
 300       -- \*override* the corresponding values from the first one. Default
 301       -- behaviour (concatenation) is confusing and makes some use cases (see
 302       -- #1884) impossible.
 303       --
 304       -- However, we also want to allow specifying multiple values for a list
 305       -- field in a *single* config file. For example, we want the following to
 306       -- continue to work:
 307       --
 308       -- remote-repo: hackage.haskell.org:http://hackage.haskell.org/
 309       -- remote-repo: private-collection:http://hackage.local/
 310       --
 311       -- So we can't just wrap the list fields inside Flags; we have to do some
 312       -- special-casing just for SavedConfig.
 313
 314       -- NB: the signature prevents us from using 'combine' on lists.
 315       combine' :: (SavedConfig -> flags) -> (flags -> Flag a) -> Flag a
 316       combine' field subfield =
 317         (subfield . field $ a) `mappend` (subfield . field $ b)
 318
 319       combineMonoid
 320         :: Monoid mon
 321         => (SavedConfig -> flags)
 322         -> (flags -> mon)
 323         -> mon
 324       combineMonoid field subfield =
 325         (subfield . field $ a) `mappend` (subfield . field $ b)
 326
 327       lastNonEmpty' :: (SavedConfig -> flags) -> (flags -> [a]) -> [a]
 328       lastNonEmpty' field subfield =
 329         let a' = subfield . field $ a
 330             b' = subfield . field $ b
 331          in case b' of
 332               [] -> a'
 333               _ -> b'
 334
 335       lastNonMempty'
 336         :: (Eq a, Monoid a) => (SavedConfig -> flags) -> (flags -> a) -> a
 337       lastNonMempty' field subfield =
 338         let a' = subfield . field $ a
 339             b' = subfield . field $ b
 340          in if b' == mempty then a' else b'
 341
 342       lastNonEmptyNL'
 343         :: (SavedConfig -> flags)
 344         -> (flags -> NubList a)
 345         -> NubList a
 346       lastNonEmptyNL' field subfield =
 347         let a' = subfield . field $ a
 348             b' = subfield . field $ b
 349          in case fromNubList b' of
 350               [] -> a'
 351               _ -> b'
 352
 353       combinedSavedGlobalFlags =
 354         GlobalFlags
 355           { globalVersion = combine globalVersion
 356           , globalNumericVersion = combine globalNumericVersion
 357           , globalConfigFile = combine globalConfigFile
 358           , globalConstraintsFile = combine globalConstraintsFile
 359           , globalRemoteRepos = lastNonEmptyNL globalRemoteRepos
 360           , globalCacheDir = combine globalCacheDir
 361           , globalLocalNoIndexRepos = lastNonEmptyNL globalLocalNoIndexRepos
 362           , globalActiveRepos = combine globalActiveRepos
 363           , globalLogsDir = combine globalLogsDir
 364           , globalIgnoreExpiry = combine globalIgnoreExpiry
 365           , globalHttpTransport = combine globalHttpTransport
 366           , globalNix = combine globalNix
 367           , globalStoreDir = combine globalStoreDir
 368           , globalProgPathExtra = lastNonEmptyNL globalProgPathExtra
 369           }
 370         where
 371           combine = combine' savedGlobalFlags
 372           lastNonEmptyNL = lastNonEmptyNL' savedGlobalFlags
 373
 374       combinedSavedInitFlags =
 375         IT.InitFlags
 376           { IT.applicationDirs = combineMonoid savedInitFlags IT.applicationDirs
 377           , IT.author = combine IT.author
 378           , IT.buildTools = combineMonoid savedInitFlags IT.buildTools
 379           , IT.cabalVersion = combine IT.cabalVersion
 380           , IT.category = combine IT.category
 381           , IT.dependencies = combineMonoid savedInitFlags IT.dependencies
 382           , IT.email = combine IT.email
 383           , IT.exposedModules = combineMonoid savedInitFlags IT.exposedModules
 384           , IT.extraSrc = combineMonoid savedInitFlags IT.extraSrc
 385           , IT.extraDoc = combineMonoid savedInitFlags IT.extraDoc
 386           , IT.homepage = combine IT.homepage
 387           , IT.initHcPath = combine IT.initHcPath
 388           , IT.initVerbosity = combine IT.initVerbosity
 389           , IT.initializeTestSuite = combine IT.initializeTestSuite
 390           , IT.interactive = combine IT.interactive
 391           , IT.language = combine IT.language
 392           , IT.license = combine IT.license
 393           , IT.mainIs = combine IT.mainIs
 394           , IT.minimal = combine IT.minimal
 395           , IT.noComments = combine IT.noComments
 396           , IT.otherExts = combineMonoid savedInitFlags IT.otherExts
 397           , IT.otherModules = combineMonoid savedInitFlags IT.otherModules
 398           , IT.overwrite = combine IT.overwrite
 399           , IT.packageDir = combine IT.packageDir
 400           , IT.packageName = combine IT.packageName
 401           , IT.packageType = combine IT.packageType
 402           , IT.quiet = combine IT.quiet
 403           , IT.simpleProject = combine IT.simpleProject
 404           , IT.sourceDirs = combineMonoid savedInitFlags IT.sourceDirs
 405           , IT.synopsis = combine IT.synopsis
 406           , IT.testDirs = combineMonoid savedInitFlags IT.testDirs
 407           , IT.version = combine IT.version
 408           }
 409         where
 410           combine = combine' savedInitFlags
 411
 412       combinedSavedInstallFlags =
 413         InstallFlags
 414           { installDocumentation = combine installDocumentation
 415           , installHaddockIndex = combine installHaddockIndex
 416           , installDryRun = combine installDryRun
 417           , installOnlyDownload = combine installOnlyDownload
 418           , installDest = combine installDest
 419           , installMaxBackjumps = combine installMaxBackjumps
 420           , installReorderGoals = combine installReorderGoals
 421           , installCountConflicts = combine installCountConflicts
 422           , installFineGrainedConflicts = combine installFineGrainedConflicts
 423           , installMinimizeConflictSet = combine installMinimizeConflictSet
 424           , installIndependentGoals = combine installIndependentGoals
 425           , installPreferOldest = combine installPreferOldest
 426           , installShadowPkgs = combine installShadowPkgs
 427           , installStrongFlags = combine installStrongFlags
 428           , installAllowBootLibInstalls = combine installAllowBootLibInstalls
 429           , installOnlyConstrained = combine installOnlyConstrained
 430           , installReinstall = combine installReinstall
 431           , installAvoidReinstalls = combine installAvoidReinstalls
 432           , installOverrideReinstall = combine installOverrideReinstall
 433           , installUpgradeDeps = combine installUpgradeDeps
 434           , installOnly = combine installOnly
 435           , installOnlyDeps = combine installOnlyDeps
 436           , installIndexState = combine installIndexState
 437           , installRootCmd = combine installRootCmd
 438           , installSummaryFile = lastNonEmptyNL installSummaryFile
 439           , installLogFile = combine installLogFile
 440           , installBuildReports = combine installBuildReports
 441           , installReportPlanningFailure = combine installReportPlanningFailure
 442           , installSymlinkBinDir = combine installSymlinkBinDir
 443           , installPerComponent = combine installPerComponent
 444           , installNumJobs = combine installNumJobs
 445           , installUseSemaphore = combine installUseSemaphore
 446           , installKeepGoing = combine installKeepGoing
 447           , installRunTests = combine installRunTests
 448           , installOfflineMode = combine installOfflineMode
 449           }
 450         where
 451           combine = combine' savedInstallFlags
 452           lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags
 453
 454       combinedSavedClientInstallFlags =
 455         ClientInstallFlags
 456           { cinstInstallLibs = combine cinstInstallLibs
 457           , cinstEnvironmentPath = combine cinstEnvironmentPath
 458           , cinstOverwritePolicy = combine cinstOverwritePolicy
 459           , cinstInstallMethod = combine cinstInstallMethod
 460           , cinstInstalldir = combine cinstInstalldir
 461           }
 462         where
 463           combine = combine' savedClientInstallFlags
 464
 465       combinedSavedCommonFlags which =
 466         CommonSetupFlags
 467           { setupDistPref = combine setupDistPref
 468           , setupWorkingDir = combine setupWorkingDir
 469           , setupCabalFilePath = combine setupCabalFilePath
 470           , setupVerbosity = combine setupVerbosity
 471           , setupTargets = lastNonEmpty setupTargets
 472           }
 473         where
 474           lastNonEmpty = lastNonEmpty' which
 475           combine = combine' which
 476
 477       combinedSavedConfigureFlags =
 478         ConfigFlags
 479           { configCommonFlags = combinedSavedCommonFlags (configCommonFlags . savedConfigureFlags)
 480           , configPrograms_ = configPrograms_ . savedConfigureFlags $ b
 481           , -- TODO: NubListify
 482             configProgramPaths = lastNonEmpty configProgramPaths
 483           , -- TODO: NubListify
 484             configProgramArgs = lastNonEmpty configProgramArgs
 485           , configProgramPathExtra = lastNonEmptyNL configProgramPathExtra
 486           , configInstantiateWith = lastNonEmpty configInstantiateWith
 487           , configHcFlavor = combine configHcFlavor
 488           , configHcPath = combine configHcPath
 489           , configHcPkg = combine configHcPkg
 490           , configVanillaLib = combine configVanillaLib
 491           , configProfLib = combine configProfLib
 492           , configProf = combine configProf
 493           , configSharedLib = combine configSharedLib
 494           , configStaticLib = combine configStaticLib
 495           , configDynExe = combine configDynExe
 496           , configFullyStaticExe = combine configFullyStaticExe
 497           , configProfExe = combine configProfExe
 498           , configProfDetail = combine configProfDetail
 499           , configProfLibDetail = combine configProfLibDetail
 500           , -- TODO: NubListify
 501             configConfigureArgs = lastNonEmpty configConfigureArgs
 502           , configOptimization = combine configOptimization
 503           , configDebugInfo = combine configDebugInfo
 504           , configProgPrefix = combine configProgPrefix
 505           , configProgSuffix = combine configProgSuffix
 506           , -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.
 507             configInstallDirs =
 508               (configInstallDirs . savedConfigureFlags $ a)
 509                 `mappend` (configInstallDirs . savedConfigureFlags $ b)
 510           , configScratchDir = combine configScratchDir
 511           , -- TODO: NubListify
 512             configExtraLibDirs = lastNonEmpty configExtraLibDirs
 513           , configExtraLibDirsStatic = lastNonEmpty configExtraLibDirsStatic
 514           , -- TODO: NubListify
 515             configExtraFrameworkDirs = lastNonEmpty configExtraFrameworkDirs
 516           , -- TODO: NubListify
 517             configExtraIncludeDirs = lastNonEmpty configExtraIncludeDirs
 518           , configDeterministic = combine configDeterministic
 519           , configIPID = combine configIPID
 520           , configCID = combine configCID
 521           , configUserInstall = combine configUserInstall
 522           , -- TODO: NubListify
 523             configPackageDBs = lastNonEmpty configPackageDBs
 524           , configGHCiLib = combine configGHCiLib
 525           , configSplitSections = combine configSplitSections
 526           , configSplitObjs = combine configSplitObjs
 527           , configStripExes = combine configStripExes
 528           , configStripLibs = combine configStripLibs
 529           , -- TODO: NubListify
 530             configConstraints = lastNonEmpty configConstraints
 531           , -- TODO: NubListify
 532             configDependencies = lastNonEmpty configDependencies
 533           , configPromisedDependencies = lastNonEmpty configPromisedDependencies
 534           , -- TODO: NubListify
 535             configConfigurationsFlags = lastNonMempty configConfigurationsFlags
 536           , configTests = combine configTests
 537           , configBenchmarks = combine configBenchmarks
 538           , configCoverage = combine configCoverage
 539           , configLibCoverage = combine configLibCoverage
 540           , configExactConfiguration = combine configExactConfiguration
 541           , configFlagError = combine configFlagError
 542           , configRelocatable = combine configRelocatable
 543           , configUseResponseFiles = combine configUseResponseFiles
 544           , configDumpBuildInfo = combine configDumpBuildInfo
 545           , configAllowDependingOnPrivateLibs =
 546               combine configAllowDependingOnPrivateLibs
 547           , configCoverageFor = combine configCoverageFor
 548           }
 549         where
 550           combine = combine' savedConfigureFlags
 551           lastNonEmpty = lastNonEmpty' savedConfigureFlags
 552           lastNonEmptyNL = lastNonEmptyNL' savedConfigureFlags
 553           lastNonMempty = lastNonMempty' savedConfigureFlags
 554
 555       combinedSavedConfigureExFlags =
 556         ConfigExFlags
 557           { configCabalVersion = combine configCabalVersion
 558           , configAppend = combine configAppend
 559           , configBackup = combine configBackup
 560           , -- TODO: NubListify
 561             configExConstraints = lastNonEmpty configExConstraints
 562           , -- TODO: NubListify
 563             configPreferences = lastNonEmpty configPreferences
 564           , configSolver = combine configSolver
 565           , configAllowNewer =
 566               combineMonoid savedConfigureExFlags configAllowNewer
 567           , configAllowOlder =
 568               combineMonoid savedConfigureExFlags configAllowOlder
 569           , configWriteGhcEnvironmentFilesPolicy =
 570               combine configWriteGhcEnvironmentFilesPolicy
 571           }
 572         where
 573           combine = combine' savedConfigureExFlags
 574           lastNonEmpty = lastNonEmpty' savedConfigureExFlags
 575
 576       -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.
 577       combinedSavedUserInstallDirs =
 578         savedUserInstallDirs a
 579           `mappend` savedUserInstallDirs b
 580
 581       -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.
 582       combinedSavedGlobalInstallDirs =
 583         savedGlobalInstallDirs a
 584           `mappend` savedGlobalInstallDirs b
 585
 586       combinedSavedUploadFlags =
 587         UploadFlags
 588           { uploadCandidate = combine uploadCandidate
 589           , uploadDoc = combine uploadDoc
 590           , uploadToken = combine uploadToken
 591           , uploadUsername = combine uploadUsername
 592           , uploadPassword = combine uploadPassword
 593           , uploadPasswordCmd = combine uploadPasswordCmd
 594           , uploadVerbosity = combine uploadVerbosity
 595           }
 596         where
 597           combine = combine' savedUploadFlags
 598
 599       combinedSavedReportFlags =
 600         ReportFlags
 601           { reportToken = combine reportToken
 602           , reportUsername = combine reportUsername
 603           , reportPassword = combine reportPassword
 604           , reportVerbosity = combine reportVerbosity
 605           }
 606         where
 607           combine = combine' savedReportFlags
 608
 609       combinedSavedHaddockFlags =
 610         HaddockFlags
 611           { haddockCommonFlags = combinedSavedCommonFlags (haddockCommonFlags . savedHaddockFlags)
 612           , -- TODO: NubListify
 613             haddockProgramPaths = lastNonEmpty haddockProgramPaths
 614           , -- TODO: NubListify
 615             haddockProgramArgs = lastNonEmpty haddockProgramArgs
 616           , haddockHoogle = combine haddockHoogle
 617           , haddockHtml = combine haddockHtml
 618           , haddockHtmlLocation = combine haddockHtmlLocation
 619           , haddockForHackage = combine haddockForHackage
 620           , haddockExecutables = combine haddockExecutables
 621           , haddockTestSuites = combine haddockTestSuites
 622           , haddockBenchmarks = combine haddockBenchmarks
 623           , haddockForeignLibs = combine haddockForeignLibs
 624           , haddockInternal = combine haddockInternal
 625           , haddockCss = combine haddockCss
 626           , haddockLinkedSource = combine haddockLinkedSource
 627           , haddockQuickJump = combine haddockQuickJump
 628           , haddockHscolourCss = combine haddockHscolourCss
 629           , haddockContents = combine haddockContents
 630           , haddockKeepTempFiles = combine haddockKeepTempFiles
 631           , haddockIndex = combine haddockIndex
 632           , haddockBaseUrl = combine haddockBaseUrl
 633           , haddockLib = combine haddockLib
 634           , haddockOutputDir = combine haddockOutputDir
 635           }
 636         where
 637           combine = combine' savedHaddockFlags
 638           lastNonEmpty = lastNonEmpty' savedHaddockFlags
 639
 640       combinedSavedTestFlags =
 641         TestFlags
 642           { testCommonFlags = combinedSavedCommonFlags (testCommonFlags . savedTestFlags)
 643           , testHumanLog = combine testHumanLog
 644           , testMachineLog = combine testMachineLog
 645           , testShowDetails = combine testShowDetails
 646           , testKeepTix = combine testKeepTix
 647           , testWrapper = combine testWrapper
 648           , testFailWhenNoTestSuites = combine testFailWhenNoTestSuites
 649           , testOptions = lastNonEmpty testOptions
 650           }
 651         where
 652           combine = combine' savedTestFlags
 653           lastNonEmpty = lastNonEmpty' savedTestFlags
 654
 655       combinedSavedBenchmarkFlags =
 656         BenchmarkFlags
 657           { benchmarkCommonFlags = combinedSavedCommonFlags (benchmarkCommonFlags . savedBenchmarkFlags)
 658           , benchmarkOptions = lastNonEmpty benchmarkOptions
 659           }
 660         where
 661           lastNonEmpty = lastNonEmpty' savedBenchmarkFlags
 662
 663       combinedSavedReplMulti = combine' savedReplMulti id
 664
 665       combinedSavedProjectFlags =
 666         ProjectFlags
 667           { flagProjectDir = combine flagProjectDir
 668           , flagProjectFile = combine flagProjectFile
 669           , flagIgnoreProject = combine flagIgnoreProject
 670           }
 671         where
 672           combine = combine' savedProjectFlags
 673
 674 --
 675
 676 -- * Default config
 677
 678 --
 679
 680 -- | These are the absolute basic defaults. The fields that must be
 681 -- initialised. When we load the config from the file we layer the loaded
 682 -- values over these ones, so any missing fields in the file take their values
 683 -- from here.
 684 baseSavedConfig :: IO SavedConfig
 685 baseSavedConfig = do
 686   userPrefix <- defaultInstallPrefix
 687   cacheDir <- defaultCacheDir
 688   logsDir <- defaultLogsDir
 689   return
 690     mempty
 691       { savedConfigureFlags =
 692           mempty
 693             { configHcFlavor = toFlag defaultCompiler
 694             , configUserInstall = toFlag defaultUserInstall
 695             , configCommonFlags =
 696                 mempty
 697                   { setupVerbosity = toFlag normal
 698                   }
 699             }
 700       , savedUserInstallDirs =
 701           mempty
 702             { prefix = toFlag (toPathTemplate userPrefix)
 703             }
 704       , savedGlobalFlags =
 705           mempty
 706             { globalCacheDir = toFlag cacheDir
 707             , globalLogsDir = toFlag logsDir
 708             }
 709       }
 710
 711 -- | This is the initial configuration that we write out to the config file
 712 -- if the file does not exist (or the config we use if the file cannot be read
 713 -- for some other reason). When the config gets loaded it gets layered on top
 714 -- of 'baseSavedConfig' so we do not need to include it into the initial
 715 -- values we save into the config file.
 716 initialSavedConfig :: IO SavedConfig
 717 initialSavedConfig = do
 718   cacheDir <- defaultCacheDir
 719   logsDir <- defaultLogsDir
 720   installPath <- defaultInstallPath
 721   return
 722     mempty
 723       { savedGlobalFlags =
 724           mempty
 725             { globalCacheDir = toFlag cacheDir
 726             , globalRemoteRepos = toNubList [defaultRemoteRepo]
 727             }
 728       , savedInstallFlags =
 729           mempty
 730             { installSummaryFile = toNubList [toPathTemplate (logsDir </> "build.log")]
 731             , installBuildReports = toFlag NoReports
 732             , installNumJobs = toFlag Nothing
 733             }
 734       , savedClientInstallFlags =
 735           mempty
 736             { cinstInstalldir = toFlag installPath
 737             }
 738       }
 739
 740 -- | Issue a warning if both @$XDG_CONFIG_HOME/cabal/config@ and
 741 -- @~/.cabal@ exists.
 742 warnOnTwoConfigs :: Verbosity -> IO ()
 743 warnOnTwoConfigs verbosity = do
 744   defaultDir <- getAppUserDataDirectory "cabal"
 745   xdgCfgDir <- getXdgDirectory XdgConfig "cabal"
 746   when (defaultDir /= xdgCfgDir) $ do
 747     dotCabalExists <- doesDirectoryExist defaultDir
 748     let xdgCfg = xdgCfgDir </> "config"
 749     xdgCfgExists <- doesFileExist xdgCfg
 750     when (dotCabalExists && xdgCfgExists) $
 751       warn verbosity $
 752         "Both "
 753           <> defaultDir
 754           <> " and "
 755           <> xdgCfg
 756           <> " exist - ignoring the former.\n"
 757           <> "It is advisable to remove one of them. In that case, we will use the remaining one by default (unless '$CABAL_DIR' is explicitly set)."
 758
 759 -- | If @CABAL\_DIR@ is set, return @Just@ its value. Otherwise, if
 760 -- @~/.cabal@ exists and @$XDG_CONFIG_HOME/cabal/config@ does not
 761 -- exist, return @Just "~/.cabal"@.  Otherwise, return @Nothing@.  If
 762 -- this function returns Nothing, then it implies that we are not
 763 -- using a single directory for everything, but instead use XDG paths.
 764 -- Fundamentally, this function is used to implement transparent
 765 -- backwards compatibility with pre-XDG versions of cabal-install.
 766 maybeGetCabalDir :: IO (Maybe FilePath)
 767 maybeGetCabalDir = do
 768   mDir <- lookupEnv "CABAL_DIR"
 769   case mDir of
 770     Just dir -> return $ Just dir
 771     Nothing -> do
 772       defaultDir <- getAppUserDataDirectory "cabal"
 773       dotCabalExists <- doesDirectoryExist defaultDir
 774       xdgCfg <- getXdgDirectory XdgConfig ("cabal" </> "config")
 775       xdgCfgExists <- doesFileExist xdgCfg
 776       if dotCabalExists && not xdgCfgExists
 777         then return $ Just defaultDir
 778         else return Nothing
 779
 780 -- | The default behaviour of cabal-install is to use the XDG
 781 -- directory standard.  However, if @CABAL_DIR@ is set, we instead use
 782 -- that directory as a single store for everything cabal-related, like
 783 -- the old @~/.cabal@ behaviour.  Also, for backwards compatibility,
 784 -- if @~/.cabal@ exists we treat that as equivalent to @CABAL_DIR@
 785 -- being set.  This function abstracts that decision-making.
 786 getDefaultDir :: XdgDirectory -> FilePath -> IO FilePath
 787 getDefaultDir xdg subdir = do
 788   mDir <- maybeGetCabalDir
 789   case mDir of
 790     Just dir -> return $ dir </> subdir
 791     Nothing -> getXdgDirectory xdg $ "cabal" </> subdir
 792
 793 -- | The default prefix used for installation.
 794 defaultInstallPrefix :: IO FilePath
 795 defaultInstallPrefix = do
 796   mDir <- maybeGetCabalDir
 797   case mDir of
 798     Just dir ->
 799       return dir
 800     Nothing -> do
 801       dir <- getHomeDirectory
 802       return $ dir </> ".local"
 803
 804 defaultConfigFile :: IO FilePath
 805 defaultConfigFile =
 806   getDefaultDir XdgConfig "config"
 807
 808 defaultCacheHome :: IO FilePath
 809 defaultCacheHome =
 810   getDefaultDir XdgCache ""
 811
 812 defaultCacheDir :: IO FilePath
 813 defaultCacheDir =
 814   getDefaultDir XdgCache "packages"
 815
 816 defaultScriptBuildsDir :: IO FilePath
 817 defaultScriptBuildsDir =
 818   getDefaultDir XdgCache "script-builds"
 819
 820 defaultStoreDir :: IO FilePath
 821 defaultStoreDir =
 822   getDefaultDir XdgState "store"
 823
 824 defaultLogsDir :: IO FilePath
 825 defaultLogsDir =
 826   getDefaultDir XdgCache "logs"
 827
 828 defaultReportsDir :: IO FilePath
 829 defaultReportsDir =
 830   getDefaultDir XdgCache "reports"
 831
 832 defaultInstallPath :: IO FilePath
 833 defaultInstallPath = do
 834   mDir <- maybeGetCabalDir
 835   case mDir of
 836     Just dir ->
 837       return $ dir </> "bin"
 838     Nothing -> do
 839       dir <- getHomeDirectory
 840       return $ dir </> ".local" </> "bin"
 841
 842 defaultCompiler :: CompilerFlavor
 843 defaultCompiler = fromMaybe GHC defaultCompilerFlavor
 844
 845 defaultUserInstall :: Bool
 846 defaultUserInstall = True
 847
 848 -- We do per-user installs by default on all platforms. We used to default to
 849 -- global installs on Windows but that no longer works on Windows Vista or 7.
 850
 851 defaultRemoteRepo :: RemoteRepo
 852 defaultRemoteRepo = RemoteRepo name uri Nothing [] 0 False
 853   where
 854     str = "hackage.haskell.org"
 855     name = RepoName str
 856     uri = URI "http:" (Just (URIAuth "" str "")) "/" "" ""
 857
 858 -- Note that lots of old config files will have the old url
 859 -- http://hackage.haskell.org/packages/archive
 860 -- but new config files can use the new url (without the /packages/archive)
 861 -- and avoid having to do a http redirect
 862
 863 -- For the default repo we know extra information, fill this in.
 864 --
 865 -- We need this because the 'defaultRemoteRepo' above is only used for the
 866 -- first time when a config file is made. So for users with older config files
 867 -- we might have only have older info. This lets us fill that in even for old
 868 -- config files.
 869 --
 870 addInfoForKnownRepos :: RemoteRepo -> RemoteRepo
 871 addInfoForKnownRepos repo
 872   | remoteRepoName repo == remoteRepoName defaultRemoteRepo =
 873       useSecure . tryHttps . fixOldURI $ repo
 874   where
 875     fixOldURI r
 876       | isOldHackageURI (remoteRepoURI r) =
 877           r{remoteRepoURI = remoteRepoURI defaultRemoteRepo}
 878       | otherwise = r
 879
 880     tryHttps r = r{remoteRepoShouldTryHttps = True}
 881
 882     useSecure
 883       r@RemoteRepo
 884         { remoteRepoSecure = secure
 885         , remoteRepoRootKeys = []
 886         , remoteRepoKeyThreshold = 0
 887         }
 888         | secure /= Just False =
 889             r
 890               { -- Use hackage-security by default unless you opt-out with
 891                 -- secure: False
 892                 remoteRepoSecure = Just True
 893               , remoteRepoRootKeys = defaultHackageRemoteRepoKeys
 894               , remoteRepoKeyThreshold = defaultHackageRemoteRepoKeyThreshold
 895               }
 896     useSecure r = r
 897 addInfoForKnownRepos other = other
 898
 899 -- | The current hackage.haskell.org repo root keys that we ship with cabal.
 900
 901 ---
 902 -- This lets us bootstrap trust in this repo without user intervention.
 903 -- These keys need to be periodically updated when new root keys are added.
 904 -- See the root key procedures for details.
 905 --
 906 defaultHackageRemoteRepoKeys :: [String]
 907 defaultHackageRemoteRepoKeys =
 908   -- Key owners and public keys are provided as a convenience to readers.
 909   -- The canonical source for this mapping data is the hackage-root-keys
 910   -- repository and Hackage's root.json file.
 911   --
 912   -- Links:
 913   --  * https://github.com/haskell-infra/hackage-root-keys
 914   --  * https://hackage.haskell.org/root.json
 915   -- Please consult root.json on Hackage to map key IDs to public keys,
 916   -- and the hackage-root-keys repository to map public keys to their
 917   -- owners.
 918   [ -- Adam Gundry (uRPdSiL3/MNsk50z6NB55ABo0OrrNDXigtCul4vtzmw=)
 919     "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0"
 920   , -- Gershom Bazerman (bYoUXXQ9TtX10UriaMiQtTccuXPGnmldP68djzZ7cLo=)
 921     "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42"
 922   , -- John Wiegley (zazm5w480r+zPO6Z0+8fjGuxZtb9pAuoVmQ+VkuCvgU=)
 923     "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d"
 924   , -- Norman Ramsey (ZI8di3a9Un0s2RBrt5GwVRvfOXVuywADfXGPZfkiDb0=)
 925     "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921"
 926   , -- Mathieu Boespflug (ydN1nGGQ79K1Q0nN+ul+Ln8MxikTB95w0YdGd3v3kmg=)
 927     "be75553f3c7ba1dbe298da81f1d1b05c9d39dd8ed2616c9bddf1525ca8c03e48"
 928   , -- Joachim Breitner (5iUgwqZCWrCJktqMx0bBMIuoIyT4A1RYGozzchRN9rA=)
 929     "d26e46f3b631aae1433b89379a6c68bd417eb5d1c408f0643dcc07757fece522"
 930   ]
 931
 932 -- | The required threshold of root key signatures for hackage.haskell.org
 933 defaultHackageRemoteRepoKeyThreshold :: Int
 934 defaultHackageRemoteRepoKeyThreshold = 3
 935
 936 --
 937
 938 -- * Config file reading
 939
 940 --
 941
 942 -- | Loads the main configuration, and applies additional defaults to give the
 943 -- effective configuration. To loads just what is actually in the config file,
 944 -- use 'loadRawConfig'.
 945 loadConfig :: Verbosity -> Flag FilePath -> IO SavedConfig
 946 loadConfig verbosity configFileFlag = do
 947   warnOnTwoConfigs verbosity
 948   config <- loadRawConfig verbosity configFileFlag
 949   extendToEffectiveConfig config
 950
 951 extendToEffectiveConfig :: SavedConfig -> IO SavedConfig
 952 extendToEffectiveConfig config = do
 953   base <- baseSavedConfig
 954   let effective0 = base `mappend` config
 955       globalFlags0 = savedGlobalFlags effective0
 956       effective =
 957         effective0
 958           { savedGlobalFlags =
 959               globalFlags0
 960                 { globalRemoteRepos =
 961                     overNubList
 962                       (map addInfoForKnownRepos)
 963                       (globalRemoteRepos globalFlags0)
 964                 }
 965           }
 966   return effective
 967
 968 -- | Like 'loadConfig' but does not apply any additional defaults, it just
 969 -- loads what is actually in the config file. This is thus suitable for
 970 -- comparing or editing a config file, but not suitable for using as the
 971 -- effective configuration.
 972 loadRawConfig :: Verbosity -> Flag FilePath -> IO SavedConfig
 973 loadRawConfig verbosity configFileFlag = do
 974   (source, configFile) <- getConfigFilePathAndSource configFileFlag
 975   minp <- readConfigFile mempty configFile
 976   case minp of
 977     Nothing -> do
 978       notice verbosity $
 979         "Config file path source is " ++ sourceMsg source ++ "."
 980       -- 2021-10-07, issue #7705
 981       -- Only create default config file if name was not given explicitly
 982       -- via option --config-file or environment variable.
 983       case source of
 984         Default -> do
 985           notice verbosity msgNotFound
 986           createDefaultConfigFile verbosity [] configFile
 987         CommandlineOption -> failNoConfigFile
 988         EnvironmentVariable -> failNoConfigFile
 989       where
 990         msgNotFound
 991           | null configFile = "Config file name is empty"
 992           | otherwise = unwords ["Config file not found:", configFile]
 993         failNoConfigFile =
 994           dieWithException verbosity $ FailNoConfigFile msgNotFound
 995     Just (ParseOk ws conf) -> do
 996       unless (null ws) $
 997         warn verbosity $
 998           unlines (map (showPWarning configFile) ws)
 999       return conf
1000     Just (ParseFailed err) -> do
1001       let (line, msg) = locatedErrorMsg err
1002           errLineNo = maybe "" (\n -> ':' : show n) line
1003       dieWithException verbosity $ ParseFailedErr configFile msg errLineNo
1004   where
1005     sourceMsg CommandlineOption = "commandline option"
1006     sourceMsg EnvironmentVariable = "environment variable CABAL_CONFIG"
1007     sourceMsg Default = "default config file"
1008
1009 -- | Provenance of the config file.
1010 data ConfigFileSource
1011   = CommandlineOption
1012   | EnvironmentVariable
1013   | Default
1014
1015 -- | Returns the config file path, without checking that the file exists.
1016 -- The order of precedence is: input flag, CABAL_CONFIG, default location.
1017 getConfigFilePath :: Flag FilePath -> IO FilePath
1018 getConfigFilePath = fmap snd . getConfigFilePathAndSource
1019
1020 getConfigFilePathAndSource :: Flag FilePath -> IO (ConfigFileSource, FilePath)
1021 getConfigFilePathAndSource configFileFlag =
1022   getSource sources
1023   where
1024     sources =
1025       [ (CommandlineOption, return . flagToMaybe $ configFileFlag)
1026       , (EnvironmentVariable, lookup "CABAL_CONFIG" `liftM` getEnvironment)
1027       , (Default, Just `liftM` defaultConfigFile)
1028       ]
1029
1030     getSource [] = error "no config file path candidate found."
1031     getSource ((source, action) : xs) =
1032       action >>= maybe (getSource xs) (return . (,) source)
1033
1034 readConfigFile
1035   :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig))
1036 readConfigFile initial file =
1037   handleNotExists $
1038     fmap
1039       (Just . parseConfig (ConstraintSourceMainConfig file) initial)
1040       (BS.readFile file)
1041   where
1042     handleNotExists action = catchIO action $ \ioe ->
1043       if isDoesNotExistError ioe
1044         then return Nothing
1045         else ioError ioe
1046
1047 createDefaultConfigFile :: Verbosity -> [String] -> FilePath -> IO SavedConfig
1048 createDefaultConfigFile verbosity extraLines filePath = do
1049   commentConf <- commentSavedConfig
1050   initialConf <- initialSavedConfig
1051   extraConf <- parseExtraLines verbosity extraLines
1052   notice verbosity $ "Writing default configuration to " ++ filePath
1053   writeConfigFile filePath commentConf (initialConf `mappend` extraConf)
1054   return initialConf
1055
1056 writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO ()
1057 writeConfigFile file comments vals = do
1058   let tmpFile = file <.> "tmp"
1059   createDirectoryIfMissing True (takeDirectory file)
1060   writeFile tmpFile $
1061     explanation ++ showConfigWithComments comments vals ++ "\n"
1062   renameFile tmpFile file
1063   where
1064     explanation =
1065       unlines
1066         [ "-- This is the configuration file for the 'cabal' command line tool."
1067         , "--"
1068         , "-- The available configuration options are listed below."
1069         , "-- Some of them have default values listed."
1070         , "--"
1071         , "-- Lines (like this one) beginning with '--' are comments."
1072         , "-- Be careful with spaces and indentation because they are"
1073         , "-- used to indicate layout for nested sections."
1074         , "--"
1075         , "-- This config file was generated using the following versions"
1076         , "-- of Cabal and cabal-install:"
1077         , "-- Cabal library version: " ++ prettyShow cabalVersion
1078         , "-- cabal-install version: " ++ prettyShow cabalInstallVersion
1079         , ""
1080         , ""
1081         ]
1082
1083 -- | These are the default values that get used in Cabal if a no value is
1084 -- given. We use these here to include in comments when we write out the
1085 -- initial config file so that the user can see what default value they are
1086 -- overriding.
1087 commentSavedConfig :: IO SavedConfig
1088 commentSavedConfig = do
1089   userInstallDirs <- defaultInstallDirs defaultCompiler True True
1090   globalInstallDirs <- defaultInstallDirs defaultCompiler False True
1091   let conf0 =
1092         mempty
1093           { savedGlobalFlags =
1094               defaultGlobalFlags
1095                 { globalRemoteRepos = toNubList [defaultRemoteRepo]
1096                 , globalNix = mempty
1097                 }
1098           , savedInitFlags =
1099               mempty
1100                 { IT.interactive = toFlag False
1101                 , IT.cabalVersion = toFlag IT.defaultCabalVersion
1102                 , IT.language = toFlag Haskell2010
1103                 , IT.license = NoFlag
1104                 , IT.sourceDirs = Flag [IT.defaultSourceDir]
1105                 , IT.applicationDirs = Flag [IT.defaultApplicationDir]
1106                 , IT.quiet = Flag False
1107                 , IT.noComments = Flag False
1108                 , IT.minimal = Flag False
1109                 , IT.simpleProject = Flag False
1110                 }
1111           , savedInstallFlags = defaultInstallFlags
1112           , savedClientInstallFlags = defaultClientInstallFlags
1113           , savedConfigureExFlags =
1114               defaultConfigExFlags
1115                 { configAllowNewer = Just (AllowNewer mempty)
1116                 , configAllowOlder = Just (AllowOlder mempty)
1117                 }
1118           , savedConfigureFlags =
1119               (defaultConfigFlags defaultProgramDb)
1120                 { configUserInstall = toFlag defaultUserInstall
1121                 }
1122           , savedUserInstallDirs = fmap toFlag userInstallDirs
1123           , savedGlobalInstallDirs = fmap toFlag globalInstallDirs
1124           , savedUploadFlags = commandDefaultFlags uploadCommand
1125           , savedReportFlags = commandDefaultFlags reportCommand
1126           , savedHaddockFlags = defaultHaddockFlags
1127           , savedTestFlags = defaultTestFlags
1128           , savedBenchmarkFlags = defaultBenchmarkFlags
1129           }
1130   conf1 <- extendToEffectiveConfig conf0
1131   let globalFlagsConf1 = savedGlobalFlags conf1
1132       conf2 =
1133         conf1
1134           { savedGlobalFlags =
1135               globalFlagsConf1
1136                 { globalRemoteRepos =
1137                     overNubList
1138                       (map removeRootKeys)
1139                       (globalRemoteRepos globalFlagsConf1)
1140                 }
1141           }
1142   return conf2
1143   where
1144     -- Most people don't want to see default root keys, so don't print them.
1145     removeRootKeys :: RemoteRepo -> RemoteRepo
1146     removeRootKeys r = r{remoteRepoRootKeys = []}
1147
1148 -- | All config file fields.
1149 configFieldDescriptions :: ConstraintSource -> [FieldDescr SavedConfig]
1150 configFieldDescriptions src =
1151   toSavedConfig
1152     liftGlobalFlag
1153     (commandOptions (globalCommand []) ParseArgs)
1154     ["version", "numeric-version", "config-file"]
1155     []
1156     ++ toSavedConfig
1157       liftConfigFlag
1158       (configureOptions ParseArgs)
1159       ( ["builddir", "constraint", "dependency", "promised-dependency", "ipid"]
1160           ++ map fieldName installDirsFields
1161       )
1162       -- This is only here because viewAsFieldDescr gives us a parser
1163       -- that only recognises 'ghc' etc, the case-sensitive flag names, not
1164       -- what the normal case-insensitive parser gives us.
1165       [ simpleFieldParsec
1166           "compiler"
1167           (fromFlagOrDefault Disp.empty . fmap pretty)
1168           (Flag <$> parsec <|> pure NoFlag)
1169           configHcFlavor
1170           (\v flags -> flags{configHcFlavor = v})
1171       , -- TODO: The following is a temporary fix. The "optimization"
1172         -- and "debug-info" fields are OptArg, and viewAsFieldDescr
1173         -- fails on that. Instead of a hand-written hackaged parser
1174         -- and printer, we should handle this case properly in the
1175         -- library.
1176         liftField
1177           configOptimization
1178           ( \v flags ->
1179               flags{configOptimization = v}
1180           )
1181           $ let name = "optimization"
1182              in FieldDescr
1183                   name
1184                   ( \f -> case f of
1185                       Flag NoOptimisation -> Disp.text "False"
1186                       Flag NormalOptimisation -> Disp.text "True"
1187                       Flag MaximumOptimisation -> Disp.text "2"
1188                       _ -> Disp.empty
1189                   )
1190                   ( \line str _ -> case () of
1191                       _
1192                         | str == "False" -> ParseOk [] (Flag NoOptimisation)
1193                         | str == "True" -> ParseOk [] (Flag NormalOptimisation)
1194                         | str == "0" -> ParseOk [] (Flag NoOptimisation)
1195                         | str == "1" -> ParseOk [] (Flag NormalOptimisation)
1196                         | str == "2" -> ParseOk [] (Flag MaximumOptimisation)
1197                         | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation)
1198                         | lstr == "true" ->
1199                             ParseOk
1200                               [caseWarning]
1201                               (Flag NormalOptimisation)
1202                         | otherwise -> ParseFailed (NoParse name line)
1203                         where
1204                           lstr = lowercase str
1205                           caseWarning =
1206                             PWarning $
1207                               "The '"
1208                                 ++ name
1209                                 ++ "' field is case sensitive, use 'True' or 'False'."
1210                   )
1211       , liftField configDebugInfo (\v flags -> flags{configDebugInfo = v}) $
1212           let name = "debug-info"
1213            in FieldDescr
1214                 name
1215                 ( \f -> case f of
1216                     Flag NoDebugInfo -> Disp.text "False"
1217                     Flag MinimalDebugInfo -> Disp.text "1"
1218                     Flag NormalDebugInfo -> Disp.text "True"
1219                     Flag MaximalDebugInfo -> Disp.text "3"
1220                     _ -> Disp.empty
1221                 )
1222                 ( \line str _ -> case () of
1223                     _
1224                       | str == "False" -> ParseOk [] (Flag NoDebugInfo)
1225                       | str == "True" -> ParseOk [] (Flag NormalDebugInfo)
1226                       | str == "0" -> ParseOk [] (Flag NoDebugInfo)
1227                       | str == "1" -> ParseOk [] (Flag MinimalDebugInfo)
1228                       | str == "2" -> ParseOk [] (Flag NormalDebugInfo)
1229                       | str == "3" -> ParseOk [] (Flag MaximalDebugInfo)
1230                       | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo)
1231                       | lstr == "true" -> ParseOk [caseWarning] (Flag NormalDebugInfo)
1232                       | otherwise -> ParseFailed (NoParse name line)
1233                       where
1234                         lstr = lowercase str
1235                         caseWarning =
1236                           PWarning $
1237                             "The '"
1238                               ++ name
1239                               ++ "' field is case sensitive, use 'True' or 'False'."
1240                 )
1241       ]
1242     ++ toSavedConfig
1243       liftConfigExFlag
1244       (configureExOptions ParseArgs src)
1245       []
1246       [ let pkgs =
1247               (Just . AllowOlder . RelaxDepsSome)
1248                 `fmap` parsecOptCommaList parsec
1249             parseAllowOlder =
1250               ( (Just . AllowOlder . toRelaxDeps)
1251                   `fmap` parsec
1252               )
1253                 <|> pkgs
1254          in simpleFieldParsec
1255               "allow-older"
1256               (showRelaxDeps . fmap unAllowOlder)
1257               parseAllowOlder
1258               configAllowOlder
1259               (\v flags -> flags{configAllowOlder = v})
1260       , let pkgs =
1261               (Just . AllowNewer . RelaxDepsSome)
1262                 `fmap` parsecOptCommaList parsec
1263             parseAllowNewer =
1264               ( (Just . AllowNewer . toRelaxDeps)
1265                   `fmap` parsec
1266               )
1267                 <|> pkgs
1268          in simpleFieldParsec
1269               "allow-newer"
1270               (showRelaxDeps . fmap unAllowNewer)
1271               parseAllowNewer
1272               configAllowNewer
1273               (\v flags -> flags{configAllowNewer = v})
1274       ]
1275     ++ toSavedConfig
1276       liftInstallFlag
1277       (installOptions ParseArgs)
1278       ["dry-run", "only", "only-dependencies", "dependencies-only"]
1279       []
1280     ++ toSavedConfig
1281       liftClientInstallFlag
1282       (clientInstallOptions ParseArgs)
1283       []
1284       []
1285     ++ toSavedConfig
1286       liftUploadFlag
1287       (commandOptions uploadCommand ParseArgs)
1288       ["verbose", "check", "documentation", "publish"]
1289       []
1290     ++ toSavedConfig
1291       liftReportFlag
1292       (commandOptions reportCommand ParseArgs)
1293       ["verbose", "token", "username", "password"]
1294       []
1295     -- FIXME: this is a hack, hiding the user name and password.
1296     -- But otherwise it masks the upload ones. Either need to
1297     -- share the options or make then distinct. In any case
1298     -- they should probably be per-server.
1299
1300     ++ toSavedConfig
1301       liftReplFlag
1302       [multiReplOption]
1303       []
1304       []
1305     ++ [ viewAsFieldDescr $
1306           optionDistPref
1307             (setupDistPref . configCommonFlags . savedConfigureFlags)
1308             ( \distPref ->
1309                 updSavedCommonSetupFlags (\common -> common{setupDistPref = distPref})
1310             )
1311             ParseArgs
1312        ]
1313   where
1314     toSavedConfig lift options exclusions replacements =
1315       [ lift (fromMaybe field replacement)
1316       | opt <- options
1317       , let field = viewAsFieldDescr opt
1318             name = fieldName field
1319             replacement = find ((== name) . fieldName) replacements
1320       , name `notElem` exclusions
1321       ]
1322
1323     showRelaxDeps Nothing = mempty
1324     showRelaxDeps (Just rd)
1325       | isRelaxDeps rd = Disp.text "True"
1326       | otherwise = Disp.text "False"
1327
1328     toRelaxDeps True = RelaxDepsAll
1329     toRelaxDeps False = mempty
1330
1331 updSavedCommonSetupFlags
1332   :: (CommonSetupFlags -> CommonSetupFlags)
1333   -> SavedConfig
1334   -> SavedConfig
1335 updSavedCommonSetupFlags setFlag config =
1336   config
1337     { savedConfigureFlags =
1338         let flags = savedConfigureFlags config
1339             common = configCommonFlags flags
1340          in flags{configCommonFlags = setFlag common}
1341     , savedHaddockFlags =
1342         let flags = savedHaddockFlags config
1343             common = haddockCommonFlags flags
1344          in flags{haddockCommonFlags = setFlag common}
1345     , savedTestFlags =
1346         let flags = savedTestFlags config
1347             common = testCommonFlags flags
1348          in flags{testCommonFlags = setFlag common}
1349     , savedBenchmarkFlags =
1350         let flags = savedBenchmarkFlags config
1351             common = benchmarkCommonFlags flags
1352          in flags{benchmarkCommonFlags = setFlag common}
1353     }
1354
1355 -- TODO: next step, make the deprecated fields elicit a warning.
1356 --
1357 deprecatedFieldDescriptions :: [FieldDescr SavedConfig]
1358 deprecatedFieldDescriptions =
1359   [ liftGlobalFlag $
1360       listFieldParsec
1361         "repos"
1362         pretty
1363         parsec
1364         (fromNubList . globalRemoteRepos)
1365         (\rs cfg -> cfg{globalRemoteRepos = toNubList rs})
1366   , liftGlobalFlag $
1367       simpleFieldParsec
1368         "cachedir"
1369         (Disp.text . fromFlagOrDefault "")
1370         (optionalFlag parsecFilePath)
1371         globalCacheDir
1372         (\d cfg -> cfg{globalCacheDir = d})
1373   , liftUploadFlag $
1374       simpleFieldParsec
1375         "hackage-token"
1376         (Disp.text . fromFlagOrDefault "" . fmap unToken)
1377         (optionalFlag (fmap Token parsecToken))
1378         uploadToken
1379         (\d cfg -> cfg{uploadToken = d})
1380   , liftUploadFlag $
1381       simpleFieldParsec
1382         "hackage-username"
1383         (Disp.text . fromFlagOrDefault "" . fmap unUsername)
1384         (optionalFlag (fmap Username parsecToken))
1385         uploadUsername
1386         (\d cfg -> cfg{uploadUsername = d})
1387   , liftUploadFlag $
1388       simpleFieldParsec
1389         "hackage-password"
1390         (Disp.text . fromFlagOrDefault "" . fmap unPassword)
1391         (optionalFlag (fmap Password parsecToken))
1392         uploadPassword
1393         (\d cfg -> cfg{uploadPassword = d})
1394   , liftUploadFlag $
1395       spaceListField
1396         "hackage-password-command"
1397         Disp.text
1398         parseTokenQ
1399         (fromFlagOrDefault [] . uploadPasswordCmd)
1400         (\d cfg -> cfg{uploadPasswordCmd = Flag d})
1401   ]
1402     ++ map
1403       (modifyFieldName ("user-" ++) . liftUserInstallDirs)
1404       installDirsFields
1405     ++ map
1406       (modifyFieldName ("global-" ++) . liftGlobalInstallDirs)
1407       installDirsFields
1408   where
1409     optionalFlag :: ParsecParser a -> ParsecParser (Flag a)
1410     optionalFlag p = toFlag <$> p <|> pure mempty
1411
1412     modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a
1413     modifyFieldName f d = d{fieldName = f (fieldName d)}
1414
1415 liftUserInstallDirs
1416   :: FieldDescr (InstallDirs (Flag PathTemplate))
1417   -> FieldDescr SavedConfig
1418 liftUserInstallDirs =
1419   liftField
1420     savedUserInstallDirs
1421     (\flags conf -> conf{savedUserInstallDirs = flags})
1422
1423 liftGlobalInstallDirs
1424   :: FieldDescr (InstallDirs (Flag PathTemplate))
1425   -> FieldDescr SavedConfig
1426 liftGlobalInstallDirs =
1427   liftField
1428     savedGlobalInstallDirs
1429     (\flags conf -> conf{savedGlobalInstallDirs = flags})
1430
1431 liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig
1432 liftGlobalFlag =
1433   liftField
1434     savedGlobalFlags
1435     (\flags conf -> conf{savedGlobalFlags = flags})
1436
1437 liftConfigFlag :: FieldDescr ConfigFlags -> FieldDescr SavedConfig
1438 liftConfigFlag =
1439   liftField
1440     savedConfigureFlags
1441     (\flags conf -> conf{savedConfigureFlags = flags})
1442
1443 liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig
1444 liftConfigExFlag =
1445   liftField
1446     savedConfigureExFlags
1447     (\flags conf -> conf{savedConfigureExFlags = flags})
1448
1449 liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig
1450 liftInstallFlag =
1451   liftField
1452     savedInstallFlags
1453     (\flags conf -> conf{savedInstallFlags = flags})
1454
1455 liftClientInstallFlag :: FieldDescr ClientInstallFlags -> FieldDescr SavedConfig
1456 liftClientInstallFlag =
1457   liftField
1458     savedClientInstallFlags
1459     (\flags conf -> conf{savedClientInstallFlags = flags})
1460
1461 liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig
1462 liftUploadFlag =
1463   liftField
1464     savedUploadFlags
1465     (\flags conf -> conf{savedUploadFlags = flags})
1466
1467 liftReportFlag :: FieldDescr ReportFlags -> FieldDescr SavedConfig
1468 liftReportFlag =
1469   liftField
1470     savedReportFlags
1471     (\flags conf -> conf{savedReportFlags = flags})
1472
1473 liftReplFlag :: FieldDescr (Flag Bool) -> FieldDescr SavedConfig
1474 liftReplFlag =
1475   liftField
1476     savedReplMulti
1477     (\flags conf -> conf{savedReplMulti = flags})
1478
1479 parseConfig
1480   :: ConstraintSource
1481   -> SavedConfig
1482   -> BS.ByteString
1483   -> ParseResult SavedConfig
1484 parseConfig src initial = \str -> do
1485   fields <- readFields str
1486   let (knownSections, others) = partition isKnownSection fields
1487   config <- parse others
1488   let init0 = savedInitFlags config
1489       user0 = savedUserInstallDirs config
1490       global0 = savedGlobalInstallDirs config
1491   (remoteRepoSections0, localRepoSections0, haddockFlags, initFlags, user, global, paths, args) <-
1492     foldM
1493       parseSections
1494       ([], [], savedHaddockFlags config, init0, user0, global0, [], [])
1495       knownSections
1496
1497   let remoteRepoSections =
1498         reverse
1499           . nubBy ((==) `on` remoteRepoName)
1500           $ remoteRepoSections0
1501
1502   let localRepoSections =
1503         reverse
1504           . nubBy ((==) `on` localRepoName)
1505           $ localRepoSections0
1506
1507   return . fixConfigMultilines $
1508     config
1509       { savedGlobalFlags =
1510           (savedGlobalFlags config)
1511             { globalRemoteRepos = toNubList remoteRepoSections
1512             , globalLocalNoIndexRepos = toNubList localRepoSections
1513             , -- the global extra prog path comes from the configure flag prog path
1514               globalProgPathExtra = configProgramPathExtra (savedConfigureFlags config)
1515             }
1516       , savedConfigureFlags =
1517           (savedConfigureFlags config)
1518             { configProgramPaths = paths
1519             , configProgramArgs = args
1520             }
1521       , savedHaddockFlags = haddockFlags
1522       , savedInitFlags = initFlags
1523       , savedUserInstallDirs = user
1524       , savedGlobalInstallDirs = global
1525       }
1526   where
1527     isKnownSection (ParseUtils.Section _ "repository" _ _) = True
1528     isKnownSection (ParseUtils.F _ "remote-repo" _) = True
1529     isKnownSection (ParseUtils.Section _ "haddock" _ _) = True
1530     isKnownSection (ParseUtils.Section _ "init" _ _) = True
1531     isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True
1532     isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True
1533     isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True
1534     isKnownSection _ = False
1535
1536     -- Attempt to split fields that can represent lists of paths into
1537     -- actual lists on failure, leave the field untouched.
1538     splitMultiPath :: [String] -> [String]
1539     splitMultiPath [s] = case runP 0 "" (parseOptCommaList parseTokenQ) s of
1540       ParseOk _ res -> res
1541       _ -> [s]
1542     splitMultiPath xs = xs
1543
1544     splitMultiSymPath =
1545       map unsafeMakeSymbolicPath . splitMultiPath . map getSymbolicPath
1546
1547     -- This is a fixup, pending a full config parser rewrite, to
1548     -- ensure that config fields which can be comma-separated lists
1549     -- actually parse as comma-separated lists.
1550     fixConfigMultilines conf =
1551       conf
1552         { savedConfigureFlags =
1553             let scf = savedConfigureFlags conf
1554              in scf
1555                   { configProgramPathExtra =
1556                       toNubList $
1557                         splitMultiPath
1558                           (fromNubList $ configProgramPathExtra scf)
1559                   , configExtraLibDirs =
1560                       splitMultiSymPath
1561                         (configExtraLibDirs scf)
1562                   , configExtraLibDirsStatic =
1563                       splitMultiSymPath
1564                         (configExtraLibDirsStatic scf)
1565                   , configExtraFrameworkDirs =
1566                       splitMultiSymPath
1567                         (configExtraFrameworkDirs scf)
1568                   , configExtraIncludeDirs =
1569                       splitMultiSymPath
1570                         (configExtraIncludeDirs scf)
1571                   , configConfigureArgs =
1572                       splitMultiPath
1573                         (configConfigureArgs scf)
1574                   }
1575         , savedGlobalFlags =
1576             let sgf = savedGlobalFlags conf
1577              in sgf
1578                   { globalProgPathExtra =
1579                       toNubList $
1580                         splitMultiPath
1581                           (fromNubList $ globalProgPathExtra sgf)
1582                   }
1583         }
1584
1585     parse =
1586       parseFields
1587         ( configFieldDescriptions src
1588             ++ deprecatedFieldDescriptions
1589         )
1590         initial
1591
1592     parseSections
1593       (rs, ls, h, i, u, g, p, a)
1594       (ParseUtils.Section lineno "repository" name fs) = do
1595         name' <-
1596           maybe (ParseFailed $ NoParse "repository name" lineno) return $
1597             simpleParsec name
1598         r' <- parseFields remoteRepoFields (emptyRemoteRepo name') fs
1599         r'' <- postProcessRepo lineno name r'
1600         case r'' of
1601           Left local -> return (rs, local : ls, h, i, u, g, p, a)
1602           Right remote -> return (remote : rs, ls, h, i, u, g, p, a)
1603     parseSections
1604       (rs, ls, h, i, u, g, p, a)
1605       (ParseUtils.F lno "remote-repo" raw) = do
1606         let mr' = simpleParsec raw
1607         r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr'
1608         return (r' : rs, ls, h, i, u, g, p, a)
1609     parseSections
1610       accum@(rs, ls, h, i, u, g, p, a)
1611       (ParseUtils.Section _ "haddock" name fs)
1612         | name == "" = do
1613             h' <- parseFields haddockFlagsFields h fs
1614             return (rs, ls, h', i, u, g, p, a)
1615         | otherwise = do
1616             warning "The 'haddock' section should be unnamed"
1617             return accum
1618     parseSections
1619       accum@(rs, ls, h, i, u, g, p, a)
1620       (ParseUtils.Section _ "init" name fs)
1621         | name == "" = do
1622             i' <- parseFields initFlagsFields i fs
1623             return (rs, ls, h, i', u, g, p, a)
1624         | otherwise = do
1625             warning "The 'init' section should be unnamed"
1626             return accum
1627     parseSections
1628       accum@(rs, ls, h, i, u, g, p, a)
1629       (ParseUtils.Section _ "install-dirs" name fs)
1630         | name' == "user" = do
1631             u' <- parseFields installDirsFields u fs
1632             return (rs, ls, h, i, u', g, p, a)
1633         | name' == "global" = do
1634             g' <- parseFields installDirsFields g fs
1635             return (rs, ls, h, i, u, g', p, a)
1636         | otherwise = do
1637             warning "The 'install-paths' section should be for 'user' or 'global'"
1638             return accum
1639         where
1640           name' = lowercase name
1641     parseSections
1642       accum@(rs, ls, h, i, u, g, p, a)
1643       (ParseUtils.Section _ "program-locations" name fs)
1644         | name == "" = do
1645             p' <- parseFields withProgramsFields p fs
1646             return (rs, ls, h, i, u, g, p', a)
1647         | otherwise = do
1648             warning "The 'program-locations' section should be unnamed"
1649             return accum
1650     parseSections
1651       accum@(rs, ls, h, i, u, g, p, a)
1652       (ParseUtils.Section _ "program-default-options" name fs)
1653         | name == "" = do
1654             a' <- parseFields withProgramOptionsFields a fs
1655             return (rs, ls, h, i, u, g, p, a')
1656         | otherwise = do
1657             warning "The 'program-default-options' section should be unnamed"
1658             return accum
1659     parseSections accum f = do
1660       warning $ "Unrecognized stanza on line " ++ show (lineNo f)
1661       return accum
1662
1663 postProcessRepo :: Int -> String -> RemoteRepo -> ParseResult (Either LocalRepo RemoteRepo)
1664 postProcessRepo lineno reponameStr repo0 = do
1665   when (null reponameStr) $
1666     syntaxError lineno $
1667       "a 'repository' section requires the "
1668         ++ "repository name as an argument"
1669
1670   reponame <-
1671     maybe (fail $ "Invalid repository name " ++ reponameStr) return $
1672       simpleParsec reponameStr
1673
1674   case uriScheme (remoteRepoURI repo0) of
1675     -- TODO: check that there are no authority, query or fragment
1676     -- Note: the trailing colon is important
1677     "file+noindex:" -> do
1678       let uri = remoteRepoURI repo0
1679       return $ Left $ LocalRepo reponame (uriPath uri) (uriFragment uri == "#shared-cache")
1680     _ -> do
1681       let repo = repo0{remoteRepoName = reponame}
1682
1683       when (remoteRepoKeyThreshold repo > length (remoteRepoRootKeys repo)) $
1684         warning $
1685           "'key-threshold' for repository "
1686             ++ show (remoteRepoName repo)
1687             ++ " higher than number of keys"
1688
1689       when (not (null (remoteRepoRootKeys repo)) && remoteRepoSecure repo /= Just True) $
1690         warning $
1691           "'root-keys' for repository "
1692             ++ show (remoteRepoName repo)
1693             ++ " non-empty, but 'secure' not set to True."
1694
1695       return $ Right repo
1696
1697 showConfig :: SavedConfig -> String
1698 showConfig = showConfigWithComments mempty
1699
1700 showConfigWithComments :: SavedConfig -> SavedConfig -> String
1701 showConfigWithComments comment vals =
1702   Disp.render $
1703     case fmap
1704       (uncurry ppRemoteRepoSection)
1705       (zip (getRemoteRepos comment) (getRemoteRepos vals)) of
1706       [] -> Disp.text ""
1707       (x : xs) -> foldl' (\r r' -> r $+$ Disp.text "" $+$ r') x xs
1708       $+$ Disp.text ""
1709       $+$ ppFields
1710         (skipSomeFields (configFieldDescriptions ConstraintSourceUnknown))
1711         mcomment
1712         vals
1713       $+$ Disp.text ""
1714       $+$ ppSection
1715         "haddock"
1716         ""
1717         haddockFlagsFields
1718         (fmap savedHaddockFlags mcomment)
1719         (savedHaddockFlags vals)
1720       $+$ Disp.text ""
1721       $+$ ppSection
1722         "init"
1723         ""
1724         initFlagsFields
1725         (fmap savedInitFlags mcomment)
1726         (savedInitFlags vals)
1727       $+$ Disp.text ""
1728       $+$ installDirsSection "user" savedUserInstallDirs
1729       $+$ Disp.text ""
1730       $+$ installDirsSection "global" savedGlobalInstallDirs
1731       $+$ Disp.text ""
1732       $+$ configFlagsSection
1733         "program-locations"
1734         withProgramsFields
1735         configProgramPaths
1736       $+$ Disp.text ""
1737       $+$ configFlagsSection
1738         "program-default-options"
1739         withProgramOptionsFields
1740         configProgramArgs
1741   where
1742     getRemoteRepos = fromNubList . globalRemoteRepos . savedGlobalFlags
1743     mcomment = Just comment
1744     installDirsSection name field =
1745       ppSection
1746         "install-dirs"
1747         name
1748         installDirsFields
1749         (fmap field mcomment)
1750         (field vals)
1751     configFlagsSection name fields field =
1752       ppSection
1753         name
1754         ""
1755         fields
1756         (fmap (field . savedConfigureFlags) mcomment)
1757         ((field . savedConfigureFlags) vals)
1758
1759     -- skip fields based on field name.  currently only skips "remote-repo",
1760     -- because that is rendered as a section.  (see 'ppRemoteRepoSection'.)
1761     skipSomeFields = filter ((/= "remote-repo") . fieldName)
1762
1763 -- | Fields for the 'install-dirs' sections.
1764 installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))]
1765 installDirsFields = map viewAsFieldDescr installDirsOptions
1766
1767 ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc
1768 ppRemoteRepoSection def vals =
1769   ppSection
1770     "repository"
1771     (unRepoName (remoteRepoName vals))
1772     remoteRepoFields
1773     (Just def)
1774     vals
1775
1776 remoteRepoFields :: [FieldDescr RemoteRepo]
1777 remoteRepoFields =
1778   [ simpleField
1779       "url"
1780       (text . show)
1781       (parseTokenQ >>= parseURI')
1782       remoteRepoURI
1783       (\x repo -> repo{remoteRepoURI = x})
1784   , simpleFieldParsec
1785       "secure"
1786       showSecure
1787       (Just `fmap` parsec)
1788       remoteRepoSecure
1789       (\x repo -> repo{remoteRepoSecure = x})
1790   , listField
1791       "root-keys"
1792       text
1793       parseTokenQ
1794       remoteRepoRootKeys
1795       (\x repo -> repo{remoteRepoRootKeys = x})
1796   , simpleFieldParsec
1797       "key-threshold"
1798       showThreshold
1799       P.integral
1800       remoteRepoKeyThreshold
1801       (\x repo -> repo{remoteRepoKeyThreshold = x})
1802   ]
1803   where
1804     parseURI' uriString =
1805       case parseURI uriString of
1806         Nothing -> fail $ "remote-repo: no parse on " ++ show uriString
1807         Just uri -> return uri
1808
1809     showSecure Nothing = mempty -- default 'secure' setting
1810     showSecure (Just True) = text "True" -- user explicitly enabled it
1811     showSecure (Just False) = text "False" -- user explicitly disabled it
1812
1813     -- If the key-threshold is set to 0, we omit it as this is the default
1814     -- and it looks odd to have a value for key-threshold but not for 'secure'
1815     -- (note that an empty list of keys is already omitted by default, since
1816     -- that is what we do for all list fields)
1817     showThreshold 0 = mempty
1818     showThreshold t = text (show t)
1819
1820 -- | Fields for the 'haddock' section.
1821 haddockFlagsFields :: [FieldDescr HaddockFlags]
1822 haddockFlagsFields =
1823   [ field
1824   | opt <- haddockOptions ParseArgs
1825   , let field = viewAsFieldDescr opt
1826         name = fieldName field
1827   , name `notElem` exclusions
1828   ]
1829   where
1830     exclusions = ["verbose", "builddir", "for-hackage"]
1831
1832 -- | Fields for the 'init' section.
1833 initFlagsFields :: [FieldDescr IT.InitFlags]
1834 initFlagsFields =
1835   [ field
1836   | opt <- initOptions ParseArgs
1837   , let field = viewAsFieldDescr opt
1838         name = fieldName field
1839   , name `notElem` exclusions
1840   ]
1841   where
1842     exclusions =
1843       [ "author"
1844       , "email"
1845       , "overwrite"
1846       , "package-dir"
1847       , "packagedir"
1848       , "package-name"
1849       , "version"
1850       , "homepage"
1851       , "synopsis"
1852       , "category"
1853       , "extra-source-file"
1854       , "lib"
1855       , "exe"
1856       , "libandexe"
1857       , "main-is"
1858       , "expose-module"
1859       , "exposed-modules"
1860       , "extension"
1861       , "dependency"
1862       , "build-tool"
1863       , "with-compiler"
1864       , "verbose"
1865       ]
1866
1867 -- | Fields for the 'program-locations' section.
1868 withProgramsFields :: [FieldDescr [(String, FilePath)]]
1869 withProgramsFields =
1870   map viewAsFieldDescr $
1871     programDbPaths'
1872       (++ "-location")
1873       defaultProgramDb
1874       ParseArgs
1875       id
1876       (++)
1877
1878 -- | Fields for the 'program-default-options' section.
1879 withProgramOptionsFields :: [FieldDescr [(String, [String])]]
1880 withProgramOptionsFields =
1881   map viewAsFieldDescr $
1882     programDbOptions defaultProgramDb ParseArgs id (++)
1883
1884 parseExtraLines :: Verbosity -> [String] -> IO SavedConfig
1885 parseExtraLines verbosity extraLines =
1886   case parseConfig
1887     (ConstraintSourceMainConfig "additional lines")
1888     mempty
1889     (toUTF8BS (unlines extraLines)) of
1890     ParseFailed err ->
1891       let (line, msg) = locatedErrorMsg err
1892           errLineNo = maybe "" (\n -> ':' : show n) line
1893        in dieWithException verbosity $ ParseExtraLinesFailedErr msg errLineNo
1894     ParseOk [] r -> return r
1895     ParseOk ws _ ->
1896       dieWithException verbosity $ ParseExtraLinesOkError ws
1897
1898 -- | Get the differences (as a pseudo code diff) between the user's
1899 -- config file and the one that cabal would generate if it didn't exist.
1900 userConfigDiff :: Verbosity -> GlobalFlags -> [String] -> IO [String]
1901 userConfigDiff verbosity globalFlags extraLines = do
1902   userConfig <- loadRawConfig normal (globalConfigFile globalFlags)
1903   extraConfig <- parseExtraLines verbosity extraLines
1904   testConfig <- initialSavedConfig
1905   return $
1906     reverse . foldl' createDiff [] . M.toList $
1907       M.unionWith
1908         combine
1909         (M.fromList . map justFst $ filterShow testConfig)
1910         (M.fromList . map justSnd $ filterShow (userConfig `mappend` extraConfig))
1911   where
1912     justFst (a, b) = (a, (Just b, Nothing))
1913     justSnd (a, b) = (a, (Nothing, Just b))
1914
1915     combine (Nothing, Just b) (Just a, Nothing) = (Just a, Just b)
1916     combine (Just a, Nothing) (Nothing, Just b) = (Just a, Just b)
1917     combine x y =
1918       error $
1919         "Can't happen : userConfigDiff "
1920           ++ show x
1921           ++ " "
1922           ++ show y
1923
1924     createDiff :: [String] -> (String, (Maybe String, Maybe String)) -> [String]
1925     createDiff acc (key, (Just a, Just b))
1926       | a == b = acc
1927       | otherwise =
1928           ("+ " ++ key ++ ": " ++ b)
1929             : ("- " ++ key ++ ": " ++ a)
1930             : acc
1931     createDiff acc (key, (Nothing, Just b)) = ("+ " ++ key ++ ": " ++ b) : acc
1932     createDiff acc (key, (Just a, Nothing)) = ("- " ++ key ++ ": " ++ a) : acc
1933     createDiff acc (_, (Nothing, Nothing)) = acc
1934
1935     filterShow :: SavedConfig -> [(String, String)]
1936     filterShow cfg =
1937       map keyValueSplit
1938         . filter (\s -> not (null s) && ':' `elem` s)
1939         . map nonComment
1940         . lines
1941         $ showConfig cfg
1942
1943     nonComment [] = []
1944     nonComment ('-' : '-' : _) = []
1945     nonComment (x : xs) = x : nonComment xs
1946
1947     topAndTail = reverse . dropWhile isSpace . reverse . dropWhile isSpace
1948
1949     keyValueSplit s =
1950       let (left, right) = break (== ':') s
1951        in (topAndTail left, topAndTail (drop 1 right))
1952
1953 -- | Update the user's config file keeping the user's customizations.
1954 userConfigUpdate :: Verbosity -> GlobalFlags -> [String] -> IO ()
1955 userConfigUpdate verbosity globalFlags extraLines = do
1956   userConfig <- loadRawConfig normal (globalConfigFile globalFlags)
1957   extraConfig <- parseExtraLines verbosity extraLines
1958   newConfig <- initialSavedConfig
1959   commentConf <- commentSavedConfig
1960   cabalFile <- getConfigFilePath $ globalConfigFile globalFlags
1961   let backup = cabalFile ++ ".backup"
1962   notice verbosity $ "Renaming " ++ cabalFile ++ " to " ++ backup ++ "."
1963   renameFile cabalFile backup
1964   notice verbosity $ "Writing merged config to " ++ cabalFile ++ "."
1965   writeConfigFile
1966     cabalFile
1967     commentConf
1968     (newConfig `mappend` userConfig `mappend` extraConfig)