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

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