{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}

-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

-- |
-- Module      :  Distribution.Client.Config
-- Copyright   :  (c) David Himmelstrup 2005
-- License     :  BSD-like
--
-- Maintainer  :  lemmih@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
-- Utilities for handling saved state such as known packages, known servers and
-- downloaded packages.
module Distribution.Client.Config
  ( SavedConfig (..)
  , loadConfig
  , getConfigFilePath
  , showConfig
  , showConfigWithComments
  , parseConfig
  , defaultConfigFile
  , defaultCacheDir
  , defaultCacheHome
  , defaultScriptBuildsDir
  , defaultStoreDir
  , defaultCompiler
  , defaultInstallPath
  , defaultLogsDir
  , defaultReportsDir
  , defaultUserInstall
  , baseSavedConfig
  , commentSavedConfig
  , initialSavedConfig
  , configFieldDescriptions
  , haddockFlagsFields
  , installDirsFields
  , withProgramsFields
  , withProgramOptionsFields
  , userConfigDiff
  , userConfigUpdate
  , createDefaultConfigFile
  , remoteRepoFields
  , postProcessRepo
  ) where

import Distribution.Client.Compat.Prelude
import Distribution.Compat.Environment
  ( getEnvironment
  , lookupEnv
  )
import Prelude ()

import Language.Haskell.Extension (Language (Haskell2010))

import Distribution.Deprecated.ViewAsFieldDescr
  ( viewAsFieldDescr
  )

import Distribution.Client.BuildReports.Types
  ( ReportLevel (..)
  )
import Distribution.Client.CmdInstall.ClientInstallFlags
  ( ClientInstallFlags (..)
  , clientInstallOptions
  , defaultClientInstallFlags
  )
import qualified Distribution.Client.Init.Defaults as IT
import qualified Distribution.Client.Init.Types as IT
  ( InitFlags (..)
  )
import Distribution.Client.Setup
  ( ConfigExFlags (..)
  , GlobalFlags (..)
  , InstallFlags (..)
  , ReportFlags (..)
  , UploadFlags (..)
  , configureExOptions
  , defaultConfigExFlags
  , defaultGlobalFlags
  , defaultInstallFlags
  , globalCommand
  , initOptions
  , installOptions
  , reportCommand
  , uploadCommand
  )
import Distribution.Client.Types
  ( AllowNewer (..)
  , AllowOlder (..)
  , LocalRepo (..)
  , RelaxDeps (..)
  , RemoteRepo (..)
  , RepoName (..)
  , emptyRemoteRepo
  , isRelaxDeps
  , unRepoName
  )
import Distribution.Client.Types.Credentials
  ( Password (..)
  , Token (..)
  , Username (..)
  )
import Distribution.Utils.NubList
  ( NubList
  , fromNubList
  , overNubList
  , toNubList
  )

import qualified Data.ByteString as BS
import qualified Data.Map as M
import Distribution.Client.Errors
import Distribution.Client.HttpUtils
  ( isOldHackageURI
  )
import Distribution.Client.ParseUtils
  ( parseFields
  , ppFields
  , ppSection
  )
import Distribution.Client.ProjectFlags (ProjectFlags (..))
import Distribution.Client.ReplFlags
import Distribution.Client.Version
  ( cabalInstallVersion
  )
import qualified Distribution.Compat.CharParsing as P
import Distribution.Compiler
  ( CompilerFlavor (..)
  , defaultCompilerFlavor
  )
import Distribution.Deprecated.ParseUtils
  ( FieldDescr (..)
  , PError (..)
  , PWarning (..)
  , ParseResult (..)
  , liftField
  , lineNo
  , listField
  , listFieldParsec
  , locatedErrorMsg
  , parseOptCommaList
  , parseTokenQ
  , readFields
  , runP
  , showPWarning
  , simpleField
  , simpleFieldParsec
  , spaceListField
  , syntaxError
  , warning
  )
import qualified Distribution.Deprecated.ParseUtils as ParseUtils
  ( Field (..)
  )
import Distribution.Parsec (ParsecParser, parsecFilePath, parsecOptCommaList, parsecToken)
import Distribution.Simple.Command
  ( CommandUI (commandOptions)
  , ShowOrParseArgs (..)
  , commandDefaultFlags
  )
import Distribution.Simple.Compiler
  ( DebugInfoLevel (..)
  , OptimisationLevel (..)
  )
import Distribution.Simple.InstallDirs
  ( InstallDirs (..)
  , PathTemplate
  , defaultInstallDirs
  , toPathTemplate
  )
import Distribution.Simple.Program
  ( defaultProgramDb
  )
import Distribution.Simple.Setup
  ( BenchmarkFlags (..)
  , CommonSetupFlags (..)
  , ConfigFlags (..)
  , Flag (..)
  , HaddockFlags (..)
  , TestFlags (..)
  , configureOptions
  , defaultBenchmarkFlags
  , defaultConfigFlags
  , defaultHaddockFlags
  , defaultTestFlags
  , flagToMaybe
  , fromFlagOrDefault
  , haddockOptions
  , installDirsOptions
  , optionDistPref
  , programDbOptions
  , programDbPaths'
  , toFlag
  )
import Distribution.Simple.Utils
  ( cabalVersion
  , dieWithException
  , lowercase
  , notice
  , toUTF8BS
  , warn
  )
import Distribution.Solver.Types.ConstraintSource
import Distribution.Utils.Path (getSymbolicPath, unsafeMakeSymbolicPath)
import Distribution.Verbosity
  ( normal
  )
import Network.URI
  ( URI (..)
  , URIAuth (..)
  , parseURI
  )
import System.Directory
  ( XdgDirectory (XdgCache, XdgConfig, XdgState)
  , createDirectoryIfMissing
  , doesDirectoryExist
  , doesFileExist
  , getAppUserDataDirectory
  , getHomeDirectory
  , getXdgDirectory
  , renameFile
  )
import System.FilePath
  ( normalise
  , takeDirectory
  , (<.>)
  , (</>)
  )
import System.IO.Error
  ( isDoesNotExistError
  )
import Text.PrettyPrint
  ( ($+$)
  )
import qualified Text.PrettyPrint as Disp
  ( empty
  , render
  , text
  )
import Text.PrettyPrint.HughesPJ
  ( Doc
  , text
  )

--

-- * Configuration saved in the config file

--

data SavedConfig = SavedConfig
  { savedGlobalFlags :: GlobalFlags
  , savedInitFlags :: IT.InitFlags
  , savedInstallFlags :: InstallFlags
  , savedClientInstallFlags :: ClientInstallFlags
  , savedConfigureFlags :: ConfigFlags
  , savedConfigureExFlags :: ConfigExFlags
  , savedUserInstallDirs :: InstallDirs (Flag PathTemplate)
  , savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate)
  , savedUploadFlags :: UploadFlags
  , savedReportFlags :: ReportFlags
  , savedHaddockFlags :: HaddockFlags
  , savedTestFlags :: TestFlags
  , savedBenchmarkFlags :: BenchmarkFlags
  , savedProjectFlags :: ProjectFlags
  , savedReplMulti :: Flag Bool
  }
  deriving (Generic)

instance Monoid SavedConfig where
  mempty = gmempty
  mappend = (<>)

instance Semigroup SavedConfig where
  a <> b =
    SavedConfig
      { savedGlobalFlags = combinedSavedGlobalFlags
      , savedInitFlags = combinedSavedInitFlags
      , savedInstallFlags = combinedSavedInstallFlags
      , savedClientInstallFlags = combinedSavedClientInstallFlags
      , savedConfigureFlags = combinedSavedConfigureFlags
      , savedConfigureExFlags = combinedSavedConfigureExFlags
      , savedUserInstallDirs = combinedSavedUserInstallDirs
      , savedGlobalInstallDirs = combinedSavedGlobalInstallDirs
      , savedUploadFlags = combinedSavedUploadFlags
      , savedReportFlags = combinedSavedReportFlags
      , savedHaddockFlags = combinedSavedHaddockFlags
      , savedTestFlags = combinedSavedTestFlags
      , savedBenchmarkFlags = combinedSavedBenchmarkFlags
      , savedProjectFlags = combinedSavedProjectFlags
      , savedReplMulti = combinedSavedReplMulti
      }
    where
      -- This is ugly, but necessary. If we're mappending two config files, we
      -- want the values of the *non-empty* list fields from the second one to
      -- \*override* the corresponding values from the first one. Default
      -- behaviour (concatenation) is confusing and makes some use cases (see
      -- #1884) impossible.
      --
      -- However, we also want to allow specifying multiple values for a list
      -- field in a *single* config file. For example, we want the following to
      -- continue to work:
      --
      -- remote-repo: hackage.haskell.org:http://hackage.haskell.org/
      -- remote-repo: private-collection:http://hackage.local/
      --
      -- So we can't just wrap the list fields inside Flags; we have to do some
      -- special-casing just for SavedConfig.

      -- NB: the signature prevents us from using 'combine' on lists.
      combine' :: (SavedConfig -> flags) -> (flags -> Flag a) -> Flag a
      combine' field subfield =
        (subfield . field $ a) `mappend` (subfield . field $ b)

      combineMonoid
        :: Monoid mon
        => (SavedConfig -> flags)
        -> (flags -> mon)
        -> mon
      combineMonoid field subfield =
        (subfield . field $ a) `mappend` (subfield . field $ b)

      lastNonEmpty' :: (SavedConfig -> flags) -> (flags -> [a]) -> [a]
      lastNonEmpty' field subfield =
        let a' = subfield . field $ a
            b' = subfield . field $ b
         in case b' of
              [] -> a'
              _ -> b'

      lastNonMempty'
        :: (Eq a, Monoid a) => (SavedConfig -> flags) -> (flags -> a) -> a
      lastNonMempty' field subfield =
        let a' = subfield . field $ a
            b' = subfield . field $ b
         in if b' == mempty then a' else b'

      lastNonEmptyNL'
        :: (SavedConfig -> flags)
        -> (flags -> NubList a)
        -> NubList a
      lastNonEmptyNL' field subfield =
        let a' = subfield . field $ a
            b' = subfield . field $ b
         in case fromNubList b' of
              [] -> a'
              _ -> b'

      combinedSavedGlobalFlags =
        GlobalFlags
          { globalVersion = combine globalVersion
          , globalNumericVersion = combine globalNumericVersion
          , globalConfigFile = combine globalConfigFile
          , globalConstraintsFile = combine globalConstraintsFile
          , globalRemoteRepos = lastNonEmptyNL globalRemoteRepos
          , globalCacheDir = combine globalCacheDir
          , globalLocalNoIndexRepos = lastNonEmptyNL globalLocalNoIndexRepos
          , globalActiveRepos = combine globalActiveRepos
          , globalLogsDir = combine globalLogsDir
          , globalIgnoreExpiry = combine globalIgnoreExpiry
          , globalHttpTransport = combine globalHttpTransport
          , globalNix = combine globalNix
          , globalStoreDir = combine globalStoreDir
          , globalProgPathExtra = lastNonEmptyNL globalProgPathExtra
          }
        where
          combine = combine' savedGlobalFlags
          lastNonEmptyNL = lastNonEmptyNL' savedGlobalFlags

      combinedSavedInitFlags =
        IT.InitFlags
          { IT.applicationDirs = combineMonoid savedInitFlags IT.applicationDirs
          , IT.author = combine IT.author
          , IT.buildTools = combineMonoid savedInitFlags IT.buildTools
          , IT.cabalVersion = combine IT.cabalVersion
          , IT.category = combine IT.category
          , IT.dependencies = combineMonoid savedInitFlags IT.dependencies
          , IT.email = combine IT.email
          , IT.exposedModules = combineMonoid savedInitFlags IT.exposedModules
          , IT.extraSrc = combineMonoid savedInitFlags IT.extraSrc
          , IT.extraDoc = combineMonoid savedInitFlags IT.extraDoc
          , IT.homepage = combine IT.homepage
          , IT.initHcPath = combine IT.initHcPath
          , IT.initVerbosity = combine IT.initVerbosity
          , IT.initializeTestSuite = combine IT.initializeTestSuite
          , IT.interactive = combine IT.interactive
          , IT.language = combine IT.language
          , IT.license = combine IT.license
          , IT.mainIs = combine IT.mainIs
          , IT.minimal = combine IT.minimal
          , IT.noComments = combine IT.noComments
          , IT.otherExts = combineMonoid savedInitFlags IT.otherExts
          , IT.otherModules = combineMonoid savedInitFlags IT.otherModules
          , IT.overwrite = combine IT.overwrite
          , IT.packageDir = combine IT.packageDir
          , IT.packageName = combine IT.packageName
          , IT.packageType = combine IT.packageType
          , IT.quiet = combine IT.quiet
          , IT.simpleProject = combine IT.simpleProject
          , IT.sourceDirs = combineMonoid savedInitFlags IT.sourceDirs
          , IT.synopsis = combine IT.synopsis
          , IT.testDirs = combineMonoid savedInitFlags IT.testDirs
          , IT.version = combine IT.version
          }
        where
          combine = combine' savedInitFlags

      combinedSavedInstallFlags =
        InstallFlags
          { installDocumentation = combine installDocumentation
          , installHaddockIndex = combine installHaddockIndex
          , installDryRun = combine installDryRun
          , installOnlyDownload = combine installOnlyDownload
          , installDest = combine installDest
          , installMaxBackjumps = combine installMaxBackjumps
          , installReorderGoals = combine installReorderGoals
          , installCountConflicts = combine installCountConflicts
          , installFineGrainedConflicts = combine installFineGrainedConflicts
          , installMinimizeConflictSet = combine installMinimizeConflictSet
          , installIndependentGoals = combine installIndependentGoals
          , installPreferOldest = combine installPreferOldest
          , installShadowPkgs = combine installShadowPkgs
          , installStrongFlags = combine installStrongFlags
          , installAllowBootLibInstalls = combine installAllowBootLibInstalls
          , installOnlyConstrained = combine installOnlyConstrained
          , installReinstall = combine installReinstall
          , installAvoidReinstalls = combine installAvoidReinstalls
          , installOverrideReinstall = combine installOverrideReinstall
          , installUpgradeDeps = combine installUpgradeDeps
          , installOnly = combine installOnly
          , installOnlyDeps = combine installOnlyDeps
          , installIndexState = combine installIndexState
          , installRootCmd = combine installRootCmd
          , installSummaryFile = lastNonEmptyNL installSummaryFile
          , installLogFile = combine installLogFile
          , installBuildReports = combine installBuildReports
          , installReportPlanningFailure = combine installReportPlanningFailure
          , installSymlinkBinDir = combine installSymlinkBinDir
          , installPerComponent = combine installPerComponent
          , installNumJobs = combine installNumJobs
          , installUseSemaphore = combine installUseSemaphore
          , installKeepGoing = combine installKeepGoing
          , installRunTests = combine installRunTests
          , installOfflineMode = combine installOfflineMode
          }
        where
          combine = combine' savedInstallFlags
          lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags

      combinedSavedClientInstallFlags =
        ClientInstallFlags
          { cinstInstallLibs = combine cinstInstallLibs
          , cinstEnvironmentPath = combine cinstEnvironmentPath
          , cinstOverwritePolicy = combine cinstOverwritePolicy
          , cinstInstallMethod = combine cinstInstallMethod
          , cinstInstalldir = combine cinstInstalldir
          }
        where
          combine = combine' savedClientInstallFlags

      combinedSavedCommonFlags which =
        CommonSetupFlags
          { setupDistPref = combine setupDistPref
          , setupWorkingDir = combine setupWorkingDir
          , setupCabalFilePath = combine setupCabalFilePath
          , setupVerbosity = combine setupVerbosity
          , setupTargets = lastNonEmpty setupTargets
          }
        where
          lastNonEmpty = lastNonEmpty' which
          combine = combine' which

      combinedSavedConfigureFlags =
        ConfigFlags
          { configCommonFlags = combinedSavedCommonFlags (configCommonFlags . savedConfigureFlags)
          , configPrograms_ = configPrograms_ . savedConfigureFlags $ b
          , -- TODO: NubListify
            configProgramPaths = lastNonEmpty configProgramPaths
          , -- TODO: NubListify
            configProgramArgs = lastNonEmpty configProgramArgs
          , configProgramPathExtra = lastNonEmptyNL configProgramPathExtra
          , configInstantiateWith = lastNonEmpty configInstantiateWith
          , configHcFlavor = combine configHcFlavor
          , configHcPath = combine configHcPath
          , configHcPkg = combine configHcPkg
          , configVanillaLib = combine configVanillaLib
          , configProfLib = combine configProfLib
          , configProf = combine configProf
          , configProfShared = combine configProfShared
          , configSharedLib = combine configSharedLib
          , configStaticLib = combine configStaticLib
          , configDynExe = combine configDynExe
          , configFullyStaticExe = combine configFullyStaticExe
          , configProfExe = combine configProfExe
          , configProfDetail = combine configProfDetail
          , configProfLibDetail = combine configProfLibDetail
          , -- TODO: NubListify
            configConfigureArgs = lastNonEmpty configConfigureArgs
          , configOptimization = combine configOptimization
          , configDebugInfo = combine configDebugInfo
          , configProgPrefix = combine configProgPrefix
          , configProgSuffix = combine configProgSuffix
          , -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.
            configInstallDirs =
              (configInstallDirs . savedConfigureFlags $ a)
                `mappend` (configInstallDirs . savedConfigureFlags $ b)
          , configScratchDir = combine configScratchDir
          , -- TODO: NubListify
            configExtraLibDirs = lastNonEmpty configExtraLibDirs
          , configExtraLibDirsStatic = lastNonEmpty configExtraLibDirsStatic
          , -- TODO: NubListify
            configExtraFrameworkDirs = lastNonEmpty configExtraFrameworkDirs
          , -- TODO: NubListify
            configExtraIncludeDirs = lastNonEmpty configExtraIncludeDirs
          , configDeterministic = combine configDeterministic
          , configIPID = combine configIPID
          , configCID = combine configCID
          , configUserInstall = combine configUserInstall
          , -- TODO: NubListify
            configPackageDBs = lastNonEmpty configPackageDBs
          , configGHCiLib = combine configGHCiLib
          , configSplitSections = combine configSplitSections
          , configSplitObjs = combine configSplitObjs
          , configStripExes = combine configStripExes
          , configStripLibs = combine configStripLibs
          , -- TODO: NubListify
            configConstraints = lastNonEmpty configConstraints
          , -- TODO: NubListify
            configDependencies = lastNonEmpty configDependencies
          , configPromisedDependencies = lastNonEmpty configPromisedDependencies
          , -- TODO: NubListify
            configConfigurationsFlags = lastNonMempty configConfigurationsFlags
          , configTests = combine configTests
          , configBenchmarks = combine configBenchmarks
          , configCoverage = combine configCoverage
          , configLibCoverage = combine configLibCoverage
          , configExactConfiguration = combine configExactConfiguration
          , configFlagError = combine configFlagError
          , configRelocatable = combine configRelocatable
          , configUseResponseFiles = combine configUseResponseFiles
          , configDumpBuildInfo = combine configDumpBuildInfo
          , configAllowDependingOnPrivateLibs =
              combine configAllowDependingOnPrivateLibs
          , configCoverageFor = combine configCoverageFor
          , configIgnoreBuildTools = combine configIgnoreBuildTools
          }
        where
          combine = combine' savedConfigureFlags
          lastNonEmpty = lastNonEmpty' savedConfigureFlags
          lastNonEmptyNL = lastNonEmptyNL' savedConfigureFlags
          lastNonMempty = lastNonMempty' savedConfigureFlags

      combinedSavedConfigureExFlags =
        ConfigExFlags
          { configCabalVersion = combine configCabalVersion
          , configAppend = combine configAppend
          , configBackup = combine configBackup
          , -- TODO: NubListify
            configExConstraints = lastNonEmpty configExConstraints
          , -- TODO: NubListify
            configPreferences = lastNonEmpty configPreferences
          , configSolver = combine configSolver
          , configAllowNewer =
              combineMonoid savedConfigureExFlags configAllowNewer
          , configAllowOlder =
              combineMonoid savedConfigureExFlags configAllowOlder
          , configWriteGhcEnvironmentFilesPolicy =
              combine configWriteGhcEnvironmentFilesPolicy
          }
        where
          combine = combine' savedConfigureExFlags
          lastNonEmpty = lastNonEmpty' savedConfigureExFlags

      -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.
      combinedSavedUserInstallDirs =
        savedUserInstallDirs a
          `mappend` savedUserInstallDirs b

      -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.
      combinedSavedGlobalInstallDirs =
        savedGlobalInstallDirs a
          `mappend` savedGlobalInstallDirs b

      combinedSavedUploadFlags =
        UploadFlags
          { uploadCandidate = combine uploadCandidate
          , uploadDoc = combine uploadDoc
          , uploadToken = combine uploadToken
          , uploadUsername = combine uploadUsername
          , uploadPassword = combine uploadPassword
          , uploadPasswordCmd = combine uploadPasswordCmd
          , uploadVerbosity = combine uploadVerbosity
          }
        where
          combine = combine' savedUploadFlags

      combinedSavedReportFlags =
        ReportFlags
          { reportToken = combine reportToken
          , reportUsername = combine reportUsername
          , reportPassword = combine reportPassword
          , reportVerbosity = combine reportVerbosity
          }
        where
          combine = combine' savedReportFlags

      combinedSavedHaddockFlags =
        HaddockFlags
          { haddockCommonFlags = combinedSavedCommonFlags (haddockCommonFlags . savedHaddockFlags)
          , -- TODO: NubListify
            haddockProgramPaths = lastNonEmpty haddockProgramPaths
          , -- TODO: NubListify
            haddockProgramArgs = lastNonEmpty haddockProgramArgs
          , haddockHoogle = combine haddockHoogle
          , haddockHtml = combine haddockHtml
          , haddockHtmlLocation = combine haddockHtmlLocation
          , haddockForHackage = combine haddockForHackage
          , haddockExecutables = combine haddockExecutables
          , haddockTestSuites = combine haddockTestSuites
          , haddockBenchmarks = combine haddockBenchmarks
          , haddockForeignLibs = combine haddockForeignLibs
          , haddockInternal = combine haddockInternal
          , haddockCss = combine haddockCss
          , haddockLinkedSource = combine haddockLinkedSource
          , haddockQuickJump = combine haddockQuickJump
          , haddockHscolourCss = combine haddockHscolourCss
          , haddockContents = combine haddockContents
          , haddockKeepTempFiles = combine haddockKeepTempFiles
          , haddockIndex = combine haddockIndex
          , haddockBaseUrl = combine haddockBaseUrl
          , haddockResourcesDir = combine haddockResourcesDir
          , haddockOutputDir = combine haddockOutputDir
          , haddockUseUnicode = combine haddockUseUnicode
          }
        where
          combine = combine' savedHaddockFlags
          lastNonEmpty = lastNonEmpty' savedHaddockFlags

      combinedSavedTestFlags =
        TestFlags
          { testCommonFlags = combinedSavedCommonFlags (testCommonFlags . savedTestFlags)
          , testHumanLog = combine testHumanLog
          , testMachineLog = combine testMachineLog
          , testShowDetails = combine testShowDetails
          , testKeepTix = combine testKeepTix
          , testWrapper = combine testWrapper
          , testFailWhenNoTestSuites = combine testFailWhenNoTestSuites
          , testOptions = lastNonEmpty testOptions
          }
        where
          combine = combine' savedTestFlags
          lastNonEmpty = lastNonEmpty' savedTestFlags

      combinedSavedBenchmarkFlags =
        BenchmarkFlags
          { benchmarkCommonFlags = combinedSavedCommonFlags (benchmarkCommonFlags . savedBenchmarkFlags)
          , benchmarkOptions = lastNonEmpty benchmarkOptions
          }
        where
          lastNonEmpty = lastNonEmpty' savedBenchmarkFlags

      combinedSavedReplMulti = combine' savedReplMulti id

      combinedSavedProjectFlags =
        ProjectFlags
          { flagProjectDir = combine flagProjectDir
          , flagProjectFile = combine flagProjectFile
          , flagIgnoreProject = combine flagIgnoreProject
          }
        where
          combine = combine' savedProjectFlags

--

-- * Default config

--

-- | These are the absolute basic defaults. The fields that must be
-- initialised. When we load the config from the file we layer the loaded
-- values over these ones, so any missing fields in the file take their values
-- from here.
baseSavedConfig :: IO SavedConfig
baseSavedConfig = do
  userPrefix <- defaultInstallPrefix
  cacheDir <- defaultCacheDir
  logsDir <- defaultLogsDir
  return
    mempty
      { savedConfigureFlags =
          mempty
            { configHcFlavor = toFlag defaultCompiler
            , configUserInstall = toFlag defaultUserInstall
            , configCommonFlags =
                mempty
                  { setupVerbosity = toFlag normal
                  }
            }
      , savedUserInstallDirs =
          mempty
            { prefix = toFlag (toPathTemplate userPrefix)
            }
      , savedGlobalFlags =
          mempty
            { globalCacheDir = toFlag cacheDir
            , globalLogsDir = toFlag logsDir
            }
      }

-- | This is the initial configuration that we write out to the config file
-- if the file does not exist (or the config we use if the file cannot be read
-- for some other reason). When the config gets loaded it gets layered on top
-- of 'baseSavedConfig' so we do not need to include it into the initial
-- values we save into the config file.
initialSavedConfig :: IO SavedConfig
initialSavedConfig = do
  cacheDir <- defaultCacheDir
  logsDir <- defaultLogsDir
  installPath <- defaultInstallPath
  return
    mempty
      { savedGlobalFlags =
          mempty
            { globalCacheDir = toFlag cacheDir
            , globalRemoteRepos = toNubList [defaultRemoteRepo]
            }
      , savedInstallFlags =
          mempty
            { installSummaryFile = toNubList [toPathTemplate (logsDir </> "build.log")]
            , installBuildReports = toFlag NoReports
            , installNumJobs = toFlag Nothing
            }
      , savedClientInstallFlags =
          mempty
            { cinstInstalldir = toFlag installPath
            }
      }

-- | Issue a warning if both @$XDG_CONFIG_HOME/cabal/config@ and
-- @~/.cabal@ exists.
warnOnTwoConfigs :: Verbosity -> IO ()
warnOnTwoConfigs verbosity = do
  defaultDir <- getAppUserDataDirectory "cabal"
  xdgCfgDir <- getXdgDirectory XdgConfig "cabal"
  when (defaultDir /= xdgCfgDir) $ do
    dotCabalExists <- doesDirectoryExist defaultDir
    let xdgCfg = xdgCfgDir </> "config"
    xdgCfgExists <- doesFileExist xdgCfg
    when (dotCabalExists && xdgCfgExists) $
      warn verbosity $
        "Both "
          <> defaultDir
          <> " and "
          <> xdgCfg
          <> " exist - ignoring the former.\n"
          <> "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)."

-- | If @CABAL\_DIR@ is set, return @Just@ its value. Otherwise, if
-- @~/.cabal@ exists and @$XDG_CONFIG_HOME/cabal/config@ does not
-- exist, return @Just "~/.cabal"@.  Otherwise, return @Nothing@.  If
-- this function returns Nothing, then it implies that we are not
-- using a single directory for everything, but instead use XDG paths.
-- Fundamentally, this function is used to implement transparent
-- backwards compatibility with pre-XDG versions of cabal-install.
maybeGetCabalDir :: IO (Maybe FilePath)
maybeGetCabalDir = do
  mDir <- lookupEnv "CABAL_DIR"
  case mDir of
    Just dir -> return $ Just dir
    Nothing -> do
      defaultDir <- getAppUserDataDirectory "cabal"
      dotCabalExists <- doesDirectoryExist defaultDir
      xdgCfg <- getXdgDirectory XdgConfig ("cabal" </> "config")
      xdgCfgExists <- doesFileExist xdgCfg
      if dotCabalExists && not xdgCfgExists
        then return $ Just defaultDir
        else return Nothing

-- | The default behaviour of cabal-install is to use the XDG
-- directory standard.  However, if @CABAL_DIR@ is set, we instead use
-- that directory as a single store for everything cabal-related, like
-- the old @~/.cabal@ behaviour.  Also, for backwards compatibility,
-- if @~/.cabal@ exists we treat that as equivalent to @CABAL_DIR@
-- being set.  This function abstracts that decision-making.
getDefaultDir :: XdgDirectory -> FilePath -> IO FilePath
getDefaultDir xdg subdir = do
  mDir <- maybeGetCabalDir
  case mDir of
    Just dir -> return $ dir </> subdir
    Nothing -> getXdgDirectory xdg $ "cabal" </> subdir

-- | The default prefix used for installation.
defaultInstallPrefix :: IO FilePath
defaultInstallPrefix = do
  mDir <- maybeGetCabalDir
  case mDir of
    Just dir ->
      return dir
    Nothing -> do
      dir <- getHomeDirectory
      return $ dir </> ".local"

defaultConfigFile :: IO FilePath
defaultConfigFile =
  getDefaultDir XdgConfig "config"

defaultCacheHome :: IO FilePath
defaultCacheHome =
  getDefaultDir XdgCache ""

defaultCacheDir :: IO FilePath
defaultCacheDir =
  getDefaultDir XdgCache "packages"

defaultScriptBuildsDir :: IO FilePath
defaultScriptBuildsDir =
  getDefaultDir XdgCache "script-builds"

defaultStoreDir :: IO FilePath
defaultStoreDir =
  getDefaultDir XdgState "store"

defaultLogsDir :: IO FilePath
defaultLogsDir =
  getDefaultDir XdgCache "logs"

defaultReportsDir :: IO FilePath
defaultReportsDir =
  getDefaultDir XdgCache "reports"

defaultInstallPath :: IO FilePath
defaultInstallPath = do
  mDir <- maybeGetCabalDir
  case mDir of
    Just dir ->
      return $ dir </> "bin"
    Nothing -> do
      dir <- getHomeDirectory
      return $ dir </> ".local" </> "bin"

defaultCompiler :: CompilerFlavor
defaultCompiler = fromMaybe GHC defaultCompilerFlavor

defaultUserInstall :: Bool
defaultUserInstall = True

-- We do per-user installs by default on all platforms. We used to default to
-- global installs on Windows but that no longer works on Windows Vista or 7.

defaultRemoteRepo :: RemoteRepo
defaultRemoteRepo = RemoteRepo name uri Nothing [] 0 False
  where
    str = "hackage.haskell.org"
    name = RepoName str
    uri = URI "http:" (Just (URIAuth "" str "")) "/" "" ""

-- Note that lots of old config files will have the old url
-- http://hackage.haskell.org/packages/archive
-- but new config files can use the new url (without the /packages/archive)
-- and avoid having to do a http redirect

-- For the default repo we know extra information, fill this in.
--
-- We need this because the 'defaultRemoteRepo' above is only used for the
-- first time when a config file is made. So for users with older config files
-- we might have only have older info. This lets us fill that in even for old
-- config files.
--
addInfoForKnownRepos :: RemoteRepo -> RemoteRepo
addInfoForKnownRepos repo
  | remoteRepoName repo == remoteRepoName defaultRemoteRepo =
      useSecure . tryHttps . fixOldURI $ repo
  where
    fixOldURI r
      | isOldHackageURI (remoteRepoURI r) =
          r{remoteRepoURI = remoteRepoURI defaultRemoteRepo}
      | otherwise = r

    tryHttps r = r{remoteRepoShouldTryHttps = True}

    useSecure
      r@RemoteRepo
        { remoteRepoSecure = secure
        , remoteRepoRootKeys = []
        , remoteRepoKeyThreshold = 0
        }
        | secure /= Just False =
            r
              { -- Use hackage-security by default unless you opt-out with
                -- secure: False
                remoteRepoSecure = Just True
              , remoteRepoRootKeys = defaultHackageRemoteRepoKeys
              , remoteRepoKeyThreshold = defaultHackageRemoteRepoKeyThreshold
              }
    useSecure r = r
addInfoForKnownRepos other = other

-- | The current hackage.haskell.org repo root keys that we ship with cabal.

---
-- This lets us bootstrap trust in this repo without user intervention.
-- These keys need to be periodically updated when new root keys are added.
-- See the root key procedures for details.
--
defaultHackageRemoteRepoKeys :: [String]
defaultHackageRemoteRepoKeys =
  -- Key owners and public keys are provided as a convenience to readers.
  -- The canonical source for this mapping data is the hackage-root-keys
  -- repository and Hackage's root.json file.
  --
  -- Links:
  --  * https://github.com/haskell-infra/hackage-root-keys
  --  * https://hackage.haskell.org/root.json
  -- Please consult root.json on Hackage to map key IDs to public keys,
  -- and the hackage-root-keys repository to map public keys to their
  -- owners.
  [ -- Adam Gundry (uRPdSiL3/MNsk50z6NB55ABo0OrrNDXigtCul4vtzmw=)
    "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0"
  , -- Gershom Bazerman (bYoUXXQ9TtX10UriaMiQtTccuXPGnmldP68djzZ7cLo=)
    "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42"
  , -- John Wiegley (zazm5w480r+zPO6Z0+8fjGuxZtb9pAuoVmQ+VkuCvgU=)
    "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d"
  , -- Norman Ramsey (ZI8di3a9Un0s2RBrt5GwVRvfOXVuywADfXGPZfkiDb0=)
    "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921"
  , -- Mathieu Boespflug (ydN1nGGQ79K1Q0nN+ul+Ln8MxikTB95w0YdGd3v3kmg=)
    "be75553f3c7ba1dbe298da81f1d1b05c9d39dd8ed2616c9bddf1525ca8c03e48"
  , -- Joachim Breitner (5iUgwqZCWrCJktqMx0bBMIuoIyT4A1RYGozzchRN9rA=)
    "d26e46f3b631aae1433b89379a6c68bd417eb5d1c408f0643dcc07757fece522"
  ]

-- | The required threshold of root key signatures for hackage.haskell.org
defaultHackageRemoteRepoKeyThreshold :: Int
defaultHackageRemoteRepoKeyThreshold = 3

--

-- * Config file reading

--

-- | Loads the main configuration, and applies additional defaults to give the
-- effective configuration. To loads just what is actually in the config file,
-- use 'loadRawConfig'.
loadConfig :: Verbosity -> Flag FilePath -> IO SavedConfig
loadConfig verbosity configFileFlag = do
  warnOnTwoConfigs verbosity
  config <- loadRawConfig verbosity configFileFlag
  extendToEffectiveConfig config

extendToEffectiveConfig :: SavedConfig -> IO SavedConfig
extendToEffectiveConfig config = do
  base <- baseSavedConfig
  let effective0 = base `mappend` config
      globalFlags0 = savedGlobalFlags effective0
      effective =
        effective0
          { savedGlobalFlags =
              globalFlags0
                { globalRemoteRepos =
                    overNubList
                      (map addInfoForKnownRepos)
                      (globalRemoteRepos globalFlags0)
                }
          }
  return effective

-- | Like 'loadConfig' but does not apply any additional defaults, it just
-- loads what is actually in the config file. This is thus suitable for
-- comparing or editing a config file, but not suitable for using as the
-- effective configuration.
loadRawConfig :: Verbosity -> Flag FilePath -> IO SavedConfig
loadRawConfig verbosity configFileFlag = do
  (source, configFile) <- getConfigFilePathAndSource configFileFlag
  minp <- readConfigFile mempty configFile
  case minp of
    Nothing -> do
      notice verbosity $
        "Config file path source is " ++ sourceMsg source ++ "."
      -- 2021-10-07, issue #7705
      -- Only create default config file if name was not given explicitly
      -- via option --config-file or environment variable.
      case source of
        Default -> do
          notice verbosity msgNotFound
          createDefaultConfigFile verbosity [] configFile
        CommandlineOption -> failNoConfigFile
        EnvironmentVariable -> failNoConfigFile
      where
        msgNotFound
          | null configFile = "Config file name is empty"
          | otherwise = unwords ["Config file not found:", configFile]
        failNoConfigFile =
          dieWithException verbosity $ FailNoConfigFile msgNotFound
    Just (ParseOk ws conf) -> do
      unless (null ws) $
        warn verbosity $
          unlines (map (showPWarning configFile) ws)
      return conf
    Just (ParseFailed err) -> do
      let (line, msg) = locatedErrorMsg err
          errLineNo = maybe "" (\n -> ':' : show n) line
      dieWithException verbosity $ ParseFailedErr configFile msg errLineNo
  where
    sourceMsg CommandlineOption = "commandline option"
    sourceMsg EnvironmentVariable = "environment variable CABAL_CONFIG"
    sourceMsg Default = "default config file"

-- | Provenance of the config file.
data ConfigFileSource
  = CommandlineOption
  | EnvironmentVariable
  | Default

-- | Returns the config file path, without checking that the file exists.
-- The order of precedence is: input flag, CABAL_CONFIG, default location.
getConfigFilePath :: Flag FilePath -> IO FilePath
getConfigFilePath = fmap snd . getConfigFilePathAndSource

getConfigFilePathAndSource :: Flag FilePath -> IO (ConfigFileSource, FilePath)
getConfigFilePathAndSource configFileFlag =
  getSource sources
  where
    sources =
      [ (CommandlineOption, return . flagToMaybe $ configFileFlag)
      , (EnvironmentVariable, lookup "CABAL_CONFIG" `liftM` getEnvironment)
      , (Default, Just `liftM` defaultConfigFile)
      ]

    getSource [] = error "no config file path candidate found."
    getSource ((source, action) : xs) =
      action >>= maybe (getSource xs) (return . (,) source)

readConfigFile
  :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig))
readConfigFile initial file =
  handleNotExists $
    fmap
      (Just . parseConfig (ConstraintSourceMainConfig file) initial)
      (BS.readFile file)
  where
    handleNotExists action = catchIO action $ \ioe ->
      if isDoesNotExistError ioe
        then return Nothing
        else ioError ioe

createDefaultConfigFile :: Verbosity -> [String] -> FilePath -> IO SavedConfig
createDefaultConfigFile verbosity extraLines filePath = do
  commentConf <- commentSavedConfig
  initialConf <- initialSavedConfig
  extraConf <- parseExtraLines verbosity extraLines
  notice verbosity $ "Writing default configuration to " ++ filePath
  writeConfigFile filePath commentConf (initialConf `mappend` extraConf)
  return initialConf

writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO ()
writeConfigFile file comments vals = do
  let tmpFile = file <.> "tmp"
  createDirectoryIfMissing True (takeDirectory file)
  writeFile tmpFile $
    explanation ++ showConfigWithComments comments vals ++ "\n"
  renameFile tmpFile file
  where
    explanation =
      unlines
        [ "-- This is the configuration file for the 'cabal' command line tool."
        , "--"
        , "-- The available configuration options are listed below."
        , "-- Some of them have default values listed."
        , "--"
        , "-- Lines (like this one) beginning with '--' are comments."
        , "-- Be careful with spaces and indentation because they are"
        , "-- used to indicate layout for nested sections."
        , "--"
        , "-- This config file was generated using the following versions"
        , "-- of Cabal and cabal-install:"
        , "-- Cabal library version: " ++ prettyShow cabalVersion
        , "-- cabal-install version: " ++ prettyShow cabalInstallVersion
        , ""
        , ""
        ]

-- | These are the default values that get used in Cabal if a no value is
-- given. We use these here to include in comments when we write out the
-- initial config file so that the user can see what default value they are
-- overriding.
commentSavedConfig :: IO SavedConfig
commentSavedConfig = do
  userInstallDirs <- defaultInstallDirs defaultCompiler True True
  globalInstallDirs <- defaultInstallDirs defaultCompiler False True
  let conf0 =
        mempty
          { savedGlobalFlags =
              defaultGlobalFlags
                { globalRemoteRepos = toNubList [defaultRemoteRepo]
                , globalNix = mempty
                }
          , savedInitFlags =
              mempty
                { IT.interactive = toFlag False
                , IT.cabalVersion = toFlag IT.defaultCabalVersion
                , IT.language = toFlag Haskell2010
                , IT.license = NoFlag
                , IT.sourceDirs = Flag [IT.defaultSourceDir]
                , IT.applicationDirs = Flag [IT.defaultApplicationDir]
                , IT.quiet = Flag False
                , IT.noComments = Flag False
                , IT.minimal = Flag False
                , IT.simpleProject = Flag False
                }
          , savedInstallFlags = defaultInstallFlags
          , savedClientInstallFlags = defaultClientInstallFlags
          , savedConfigureExFlags =
              defaultConfigExFlags
                { configAllowNewer = Just (AllowNewer mempty)
                , configAllowOlder = Just (AllowOlder mempty)
                }
          , savedConfigureFlags =
              (defaultConfigFlags defaultProgramDb)
                { configUserInstall = toFlag defaultUserInstall
                }
          , savedUserInstallDirs = fmap toFlag userInstallDirs
          , savedGlobalInstallDirs = fmap toFlag globalInstallDirs
          , savedUploadFlags = commandDefaultFlags uploadCommand
          , savedReportFlags = commandDefaultFlags reportCommand
          , savedHaddockFlags = defaultHaddockFlags
          , savedTestFlags = defaultTestFlags
          , savedBenchmarkFlags = defaultBenchmarkFlags
          }
  conf1 <- extendToEffectiveConfig conf0
  let globalFlagsConf1 = savedGlobalFlags conf1
      conf2 =
        conf1
          { savedGlobalFlags =
              globalFlagsConf1
                { globalRemoteRepos =
                    overNubList
                      (map removeRootKeys)
                      (globalRemoteRepos globalFlagsConf1)
                }
          }
  return conf2
  where
    -- Most people don't want to see default root keys, so don't print them.
    removeRootKeys :: RemoteRepo -> RemoteRepo
    removeRootKeys r = r{remoteRepoRootKeys = []}

-- | All config file fields.
configFieldDescriptions :: ConstraintSource -> [FieldDescr SavedConfig]
configFieldDescriptions src =
  toSavedConfig
    liftGlobalFlag
    (commandOptions (globalCommand []) ParseArgs)
    ["version", "numeric-version", "config-file"]
    []
    ++ toSavedConfig
      liftConfigFlag
      (configureOptions ParseArgs)
      ( ["builddir", "constraint", "dependency", "promised-dependency", "ipid"]
          ++ map fieldName installDirsFields
      )
      -- This is only here because viewAsFieldDescr gives us a parser
      -- that only recognises 'ghc' etc, the case-sensitive flag names, not
      -- what the normal case-insensitive parser gives us.
      [ simpleFieldParsec
          "compiler"
          (fromFlagOrDefault Disp.empty . fmap pretty)
          (Flag <$> parsec <|> pure NoFlag)
          configHcFlavor
          (\v flags -> flags{configHcFlavor = v})
      , -- TODO: The following is a temporary fix. The "optimization"
        -- and "debug-info" fields are OptArg, and viewAsFieldDescr
        -- fails on that. Instead of a hand-written hackaged parser
        -- and printer, we should handle this case properly in the
        -- library.
        liftField
          configOptimization
          ( \v flags ->
              flags{configOptimization = v}
          )
          $ let name = "optimization"
             in FieldDescr
                  name
                  ( \f -> case f of
                      Flag NoOptimisation -> Disp.text "False"
                      Flag NormalOptimisation -> Disp.text "True"
                      Flag MaximumOptimisation -> Disp.text "2"
                      _ -> Disp.empty
                  )
                  ( \line str _ -> case () of
                      _
                        | str == "False" -> ParseOk [] (Flag NoOptimisation)
                        | str == "True" -> ParseOk [] (Flag NormalOptimisation)
                        | str == "0" -> ParseOk [] (Flag NoOptimisation)
                        | str == "1" -> ParseOk [] (Flag NormalOptimisation)
                        | str == "2" -> ParseOk [] (Flag MaximumOptimisation)
                        | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation)
                        | lstr == "true" ->
                            ParseOk
                              [caseWarning]
                              (Flag NormalOptimisation)
                        | otherwise -> ParseFailed (NoParse name line)
                        where
                          lstr = lowercase str
                          caseWarning =
                            PWarning $
                              "The '"
                                ++ name
                                ++ "' field is case sensitive, use 'True' or 'False'."
                  )
      , liftField configDebugInfo (\v flags -> flags{configDebugInfo = v}) $
          let name = "debug-info"
           in FieldDescr
                name
                ( \f -> case f of
                    Flag NoDebugInfo -> Disp.text "False"
                    Flag MinimalDebugInfo -> Disp.text "1"
                    Flag NormalDebugInfo -> Disp.text "True"
                    Flag MaximalDebugInfo -> Disp.text "3"
                    _ -> Disp.empty
                )
                ( \line str _ -> case () of
                    _
                      | str == "False" -> ParseOk [] (Flag NoDebugInfo)
                      | str == "True" -> ParseOk [] (Flag NormalDebugInfo)
                      | str == "0" -> ParseOk [] (Flag NoDebugInfo)
                      | str == "1" -> ParseOk [] (Flag MinimalDebugInfo)
                      | str == "2" -> ParseOk [] (Flag NormalDebugInfo)
                      | str == "3" -> ParseOk [] (Flag MaximalDebugInfo)
                      | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo)
                      | lstr == "true" -> ParseOk [caseWarning] (Flag NormalDebugInfo)
                      | otherwise -> ParseFailed (NoParse name line)
                      where
                        lstr = lowercase str
                        caseWarning =
                          PWarning $
                            "The '"
                              ++ name
                              ++ "' field is case sensitive, use 'True' or 'False'."
                )
      ]
    ++ toSavedConfig
      liftConfigExFlag
      (configureExOptions ParseArgs src)
      []
      [ let pkgs =
              (Just . AllowOlder . RelaxDepsSome)
                `fmap` parsecOptCommaList parsec
            parseAllowOlder =
              ( (Just . AllowOlder . toRelaxDeps)
                  `fmap` parsec
              )
                <|> pkgs
         in simpleFieldParsec
              "allow-older"
              (showRelaxDeps . fmap unAllowOlder)
              parseAllowOlder
              configAllowOlder
              (\v flags -> flags{configAllowOlder = v})
      , let pkgs =
              (Just . AllowNewer . RelaxDepsSome)
                `fmap` parsecOptCommaList parsec
            parseAllowNewer =
              ( (Just . AllowNewer . toRelaxDeps)
                  `fmap` parsec
              )
                <|> pkgs
         in simpleFieldParsec
              "allow-newer"
              (showRelaxDeps . fmap unAllowNewer)
              parseAllowNewer
              configAllowNewer
              (\v flags -> flags{configAllowNewer = v})
      ]
    ++ toSavedConfig
      liftInstallFlag
      (installOptions ParseArgs)
      ["dry-run", "only", "only-dependencies", "dependencies-only"]
      []
    ++ toSavedConfig
      liftClientInstallFlag
      (clientInstallOptions ParseArgs)
      []
      []
    ++ toSavedConfig
      liftUploadFlag
      (commandOptions uploadCommand ParseArgs)
      ["verbose", "check", "documentation", "publish"]
      []
    ++ toSavedConfig
      liftReportFlag
      (commandOptions reportCommand ParseArgs)
      ["verbose", "token", "username", "password"]
      []
    -- FIXME: this is a hack, hiding the user name and password.
    -- But otherwise it masks the upload ones. Either need to
    -- share the options or make then distinct. In any case
    -- they should probably be per-server.

    ++ toSavedConfig
      liftReplFlag
      [multiReplOption]
      []
      []
    ++ [ viewAsFieldDescr $
          optionDistPref
            (setupDistPref . configCommonFlags . savedConfigureFlags)
            ( \distPref ->
                updSavedCommonSetupFlags (\common -> common{setupDistPref = distPref})
            )
            ParseArgs
       ]
  where
    toSavedConfig lift options exclusions replacements =
      [ lift (fromMaybe field replacement)
      | opt <- options
      , let field = viewAsFieldDescr opt
            name = fieldName field
            replacement = find ((== name) . fieldName) replacements
      , name `notElem` exclusions
      ]

    showRelaxDeps Nothing = mempty
    showRelaxDeps (Just rd)
      | isRelaxDeps rd = Disp.text "True"
      | otherwise = Disp.text "False"

    toRelaxDeps True = RelaxDepsAll
    toRelaxDeps False = mempty

updSavedCommonSetupFlags
  :: (CommonSetupFlags -> CommonSetupFlags)
  -> SavedConfig
  -> SavedConfig
updSavedCommonSetupFlags setFlag config =
  config
    { savedConfigureFlags =
        let flags = savedConfigureFlags config
            common = configCommonFlags flags
         in flags{configCommonFlags = setFlag common}
    , savedHaddockFlags =
        let flags = savedHaddockFlags config
            common = haddockCommonFlags flags
         in flags{haddockCommonFlags = setFlag common}
    , savedTestFlags =
        let flags = savedTestFlags config
            common = testCommonFlags flags
         in flags{testCommonFlags = setFlag common}
    , savedBenchmarkFlags =
        let flags = savedBenchmarkFlags config
            common = benchmarkCommonFlags flags
         in flags{benchmarkCommonFlags = setFlag common}
    }

-- TODO: next step, make the deprecated fields elicit a warning.
--
deprecatedFieldDescriptions :: [FieldDescr SavedConfig]
deprecatedFieldDescriptions =
  [ liftGlobalFlag $
      listFieldParsec
        "repos"
        pretty
        parsec
        (fromNubList . globalRemoteRepos)
        (\rs cfg -> cfg{globalRemoteRepos = toNubList rs})
  , liftGlobalFlag $
      simpleFieldParsec
        "cachedir"
        (Disp.text . fromFlagOrDefault "")
        (optionalFlag parsecFilePath)
        globalCacheDir
        (\d cfg -> cfg{globalCacheDir = d})
  , liftUploadFlag $
      simpleFieldParsec
        "hackage-token"
        (Disp.text . fromFlagOrDefault "" . fmap unToken)
        (optionalFlag (fmap Token parsecToken))
        uploadToken
        (\d cfg -> cfg{uploadToken = d})
  , liftUploadFlag $
      simpleFieldParsec
        "hackage-username"
        (Disp.text . fromFlagOrDefault "" . fmap unUsername)
        (optionalFlag (fmap Username parsecToken))
        uploadUsername
        (\d cfg -> cfg{uploadUsername = d})
  , liftUploadFlag $
      simpleFieldParsec
        "hackage-password"
        (Disp.text . fromFlagOrDefault "" . fmap unPassword)
        (optionalFlag (fmap Password parsecToken))
        uploadPassword
        (\d cfg -> cfg{uploadPassword = d})
  , liftUploadFlag $
      spaceListField
        "hackage-password-command"
        Disp.text
        parseTokenQ
        (fromFlagOrDefault [] . uploadPasswordCmd)
        (\d cfg -> cfg{uploadPasswordCmd = Flag d})
  ]
    ++ map
      (modifyFieldName ("user-" ++) . liftUserInstallDirs)
      installDirsFields
    ++ map
      (modifyFieldName ("global-" ++) . liftGlobalInstallDirs)
      installDirsFields
  where
    optionalFlag :: ParsecParser a -> ParsecParser (Flag a)
    optionalFlag p = toFlag <$> p <|> pure mempty

    modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a
    modifyFieldName f d = d{fieldName = f (fieldName d)}

liftUserInstallDirs
  :: FieldDescr (InstallDirs (Flag PathTemplate))
  -> FieldDescr SavedConfig
liftUserInstallDirs =
  liftField
    savedUserInstallDirs
    (\flags conf -> conf{savedUserInstallDirs = flags})

liftGlobalInstallDirs
  :: FieldDescr (InstallDirs (Flag PathTemplate))
  -> FieldDescr SavedConfig
liftGlobalInstallDirs =
  liftField
    savedGlobalInstallDirs
    (\flags conf -> conf{savedGlobalInstallDirs = flags})

liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig
liftGlobalFlag =
  liftField
    savedGlobalFlags
    (\flags conf -> conf{savedGlobalFlags = flags})

liftConfigFlag :: FieldDescr ConfigFlags -> FieldDescr SavedConfig
liftConfigFlag =
  liftField
    savedConfigureFlags
    (\flags conf -> conf{savedConfigureFlags = flags})

liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig
liftConfigExFlag =
  liftField
    savedConfigureExFlags
    (\flags conf -> conf{savedConfigureExFlags = flags})

liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig
liftInstallFlag =
  liftField
    savedInstallFlags
    (\flags conf -> conf{savedInstallFlags = flags})

liftClientInstallFlag :: FieldDescr ClientInstallFlags -> FieldDescr SavedConfig
liftClientInstallFlag =
  liftField
    savedClientInstallFlags
    (\flags conf -> conf{savedClientInstallFlags = flags})

liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig
liftUploadFlag =
  liftField
    savedUploadFlags
    (\flags conf -> conf{savedUploadFlags = flags})

liftReportFlag :: FieldDescr ReportFlags -> FieldDescr SavedConfig
liftReportFlag =
  liftField
    savedReportFlags
    (\flags conf -> conf{savedReportFlags = flags})

liftReplFlag :: FieldDescr (Flag Bool) -> FieldDescr SavedConfig
liftReplFlag =
  liftField
    savedReplMulti
    (\flags conf -> conf{savedReplMulti = flags})

parseConfig
  :: ConstraintSource
  -> SavedConfig
  -> BS.ByteString
  -> ParseResult SavedConfig
parseConfig src initial = \str -> do
  fields <- readFields str
  let (knownSections, others) = partition isKnownSection fields
  config <- parse others
  let init0 = savedInitFlags config
      user0 = savedUserInstallDirs config
      global0 = savedGlobalInstallDirs config
  (remoteRepoSections0, localRepoSections0, haddockFlags, initFlags, user, global, paths, args) <-
    foldM
      parseSections
      ([], [], savedHaddockFlags config, init0, user0, global0, [], [])
      knownSections

  let remoteRepoSections =
        reverse
          . nubBy ((==) `on` remoteRepoName)
          $ remoteRepoSections0

  let localRepoSections =
        reverse
          . nubBy ((==) `on` localRepoName)
          $ localRepoSections0

  return . fixConfigMultilines $
    config
      { savedGlobalFlags =
          (savedGlobalFlags config)
            { globalRemoteRepos = toNubList remoteRepoSections
            , globalLocalNoIndexRepos = toNubList localRepoSections
            , -- the global extra prog path comes from the configure flag prog path
              globalProgPathExtra = configProgramPathExtra (savedConfigureFlags config)
            }
      , savedConfigureFlags =
          (savedConfigureFlags config)
            { configProgramPaths = paths
            , configProgramArgs = args
            }
      , savedHaddockFlags = haddockFlags
      , savedInitFlags = initFlags
      , savedUserInstallDirs = user
      , savedGlobalInstallDirs = global
      }
  where
    isKnownSection (ParseUtils.Section _ "repository" _ _) = True
    isKnownSection (ParseUtils.F _ "remote-repo" _) = True
    isKnownSection (ParseUtils.Section _ "haddock" _ _) = True
    isKnownSection (ParseUtils.Section _ "init" _ _) = True
    isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True
    isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True
    isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True
    isKnownSection _ = False

    -- Attempt to split fields that can represent lists of paths into
    -- actual lists on failure, leave the field untouched.
    splitMultiPath :: [String] -> [String]
    splitMultiPath [s] = case runP 0 "" (parseOptCommaList parseTokenQ) s of
      ParseOk _ res -> res
      _ -> [s]
    splitMultiPath xs = xs

    splitMultiSymPath =
      map unsafeMakeSymbolicPath . splitMultiPath . map getSymbolicPath

    -- This is a fixup, pending a full config parser rewrite, to
    -- ensure that config fields which can be comma-separated lists
    -- actually parse as comma-separated lists.
    fixConfigMultilines conf =
      conf
        { savedConfigureFlags =
            let scf = savedConfigureFlags conf
             in scf
                  { configProgramPathExtra =
                      toNubList $
                        splitMultiPath
                          (fromNubList $ configProgramPathExtra scf)
                  , configExtraLibDirs =
                      splitMultiSymPath
                        (configExtraLibDirs scf)
                  , configExtraLibDirsStatic =
                      splitMultiSymPath
                        (configExtraLibDirsStatic scf)
                  , configExtraFrameworkDirs =
                      splitMultiSymPath
                        (configExtraFrameworkDirs scf)
                  , configExtraIncludeDirs =
                      splitMultiSymPath
                        (configExtraIncludeDirs scf)
                  , configConfigureArgs =
                      splitMultiPath
                        (configConfigureArgs scf)
                  }
        , savedGlobalFlags =
            let sgf = savedGlobalFlags conf
             in sgf
                  { globalProgPathExtra =
                      toNubList $
                        splitMultiPath
                          (fromNubList $ globalProgPathExtra sgf)
                  }
        }

    parse =
      parseFields
        ( configFieldDescriptions src
            ++ deprecatedFieldDescriptions
        )
        initial

    parseSections
      (rs, ls, h, i, u, g, p, a)
      (ParseUtils.Section lineno "repository" name fs) = do
        name' <-
          maybe (ParseFailed $ NoParse "repository name" lineno) return $
            simpleParsec name
        r' <- parseFields remoteRepoFields (emptyRemoteRepo name') fs
        r'' <- postProcessRepo lineno name r'
        case r'' of
          Left local -> return (rs, local : ls, h, i, u, g, p, a)
          Right remote -> return (remote : rs, ls, h, i, u, g, p, a)
    parseSections
      (rs, ls, h, i, u, g, p, a)
      (ParseUtils.F lno "remote-repo" raw) = do
        let mr' = simpleParsec raw
        r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr'
        return (r' : rs, ls, h, i, u, g, p, a)
    parseSections
      accum@(rs, ls, h, i, u, g, p, a)
      (ParseUtils.Section _ "haddock" name fs)
        | name == "" = do
            h' <- parseFields haddockFlagsFields h fs
            return (rs, ls, h', i, u, g, p, a)
        | otherwise = do
            warning "The 'haddock' section should be unnamed"
            return accum
    parseSections
      accum@(rs, ls, h, i, u, g, p, a)
      (ParseUtils.Section _ "init" name fs)
        | name == "" = do
            i' <- parseFields initFlagsFields i fs
            return (rs, ls, h, i', u, g, p, a)
        | otherwise = do
            warning "The 'init' section should be unnamed"
            return accum
    parseSections
      accum@(rs, ls, h, i, u, g, p, a)
      (ParseUtils.Section _ "install-dirs" name fs)
        | name' == "user" = do
            u' <- parseFields installDirsFields u fs
            return (rs, ls, h, i, u', g, p, a)
        | name' == "global" = do
            g' <- parseFields installDirsFields g fs
            return (rs, ls, h, i, u, g', p, a)
        | otherwise = do
            warning "The 'install-paths' section should be for 'user' or 'global'"
            return accum
        where
          name' = lowercase name
    parseSections
      accum@(rs, ls, h, i, u, g, p, a)
      (ParseUtils.Section _ "program-locations" name fs)
        | name == "" = do
            p' <- parseFields withProgramsFields p fs
            return (rs, ls, h, i, u, g, p', a)
        | otherwise = do
            warning "The 'program-locations' section should be unnamed"
            return accum
    parseSections
      accum@(rs, ls, h, i, u, g, p, a)
      (ParseUtils.Section _ "program-default-options" name fs)
        | name == "" = do
            a' <- parseFields withProgramOptionsFields a fs
            return (rs, ls, h, i, u, g, p, a')
        | otherwise = do
            warning "The 'program-default-options' section should be unnamed"
            return accum
    parseSections accum f = do
      warning $ "Unrecognized stanza on line " ++ show (lineNo f)
      return accum

postProcessRepo :: Int -> String -> RemoteRepo -> ParseResult (Either LocalRepo RemoteRepo)
postProcessRepo lineno reponameStr repo0 = do
  when (null reponameStr) $
    syntaxError lineno $
      "a 'repository' section requires the "
        ++ "repository name as an argument"

  reponame <-
    maybe (fail $ "Invalid repository name " ++ reponameStr) return $
      simpleParsec reponameStr

  case uriScheme (remoteRepoURI repo0) of
    -- TODO: check that there are no authority, query or fragment
    -- Note: the trailing colon is important
    "file+noindex:" -> do
      let uri = remoteRepoURI repo0
      return $
        Left $
          LocalRepo
            reponame
            (normalise (uriPath uri))
            (uriFragment uri == "#shared-cache")
    _ -> do
      let repo = repo0{remoteRepoName = reponame}

      when (remoteRepoKeyThreshold repo > length (remoteRepoRootKeys repo)) $
        warning $
          "'key-threshold' for repository "
            ++ show (remoteRepoName repo)
            ++ " higher than number of keys"

      when (not (null (remoteRepoRootKeys repo)) && remoteRepoSecure repo /= Just True) $
        warning $
          "'root-keys' for repository "
            ++ show (remoteRepoName repo)
            ++ " non-empty, but 'secure' not set to True."

      return $ Right repo

showConfig :: SavedConfig -> String
showConfig = showConfigWithComments mempty

showConfigWithComments :: SavedConfig -> SavedConfig -> String
showConfigWithComments comment vals =
  Disp.render $
    case fmap
      (uncurry ppRemoteRepoSection)
      (zip (getRemoteRepos comment) (getRemoteRepos vals)) of
      [] -> Disp.text ""
      (x : xs) -> foldl' (\r r' -> r $+$ Disp.text "" $+$ r') x xs
      $+$ Disp.text ""
      $+$ ppFields
        (skipSomeFields (configFieldDescriptions ConstraintSourceUnknown))
        mcomment
        vals
      $+$ Disp.text ""
      $+$ ppSection
        "haddock"
        ""
        haddockFlagsFields
        (fmap savedHaddockFlags mcomment)
        (savedHaddockFlags vals)
      $+$ Disp.text ""
      $+$ ppSection
        "init"
        ""
        initFlagsFields
        (fmap savedInitFlags mcomment)
        (savedInitFlags vals)
      $+$ Disp.text ""
      $+$ installDirsSection "user" savedUserInstallDirs
      $+$ Disp.text ""
      $+$ installDirsSection "global" savedGlobalInstallDirs
      $+$ Disp.text ""
      $+$ configFlagsSection
        "program-locations"
        withProgramsFields
        configProgramPaths
      $+$ Disp.text ""
      $+$ configFlagsSection
        "program-default-options"
        withProgramOptionsFields
        configProgramArgs
  where
    getRemoteRepos = fromNubList . globalRemoteRepos . savedGlobalFlags
    mcomment = Just comment
    installDirsSection name field =
      ppSection
        "install-dirs"
        name
        installDirsFields
        (fmap field mcomment)
        (field vals)
    configFlagsSection name fields field =
      ppSection
        name
        ""
        fields
        (fmap (field . savedConfigureFlags) mcomment)
        ((field . savedConfigureFlags) vals)

    -- skip fields based on field name.  currently only skips "remote-repo",
    -- because that is rendered as a section.  (see 'ppRemoteRepoSection'.)
    skipSomeFields = filter ((/= "remote-repo") . fieldName)

-- | Fields for the 'install-dirs' sections.
installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))]
installDirsFields = map viewAsFieldDescr installDirsOptions

ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc
ppRemoteRepoSection def vals =
  ppSection
    "repository"
    (unRepoName (remoteRepoName vals))
    remoteRepoFields
    (Just def)
    vals

remoteRepoFields :: [FieldDescr RemoteRepo]
remoteRepoFields =
  [ simpleField
      "url"
      (text . show)
      (parseTokenQ >>= parseURI')
      remoteRepoURI
      (\x repo -> repo{remoteRepoURI = x})
  , simpleFieldParsec
      "secure"
      showSecure
      (Just `fmap` parsec)
      remoteRepoSecure
      (\x repo -> repo{remoteRepoSecure = x})
  , listField
      "root-keys"
      text
      parseTokenQ
      remoteRepoRootKeys
      (\x repo -> repo{remoteRepoRootKeys = x})
  , simpleFieldParsec
      "key-threshold"
      showThreshold
      P.integral
      remoteRepoKeyThreshold
      (\x repo -> repo{remoteRepoKeyThreshold = x})
  ]
  where
    parseURI' uriString =
      case parseURI uriString of
        Nothing -> fail $ "remote-repo: no parse on " ++ show uriString
        Just uri -> return uri

    showSecure Nothing = mempty -- default 'secure' setting
    showSecure (Just True) = text "True" -- user explicitly enabled it
    showSecure (Just False) = text "False" -- user explicitly disabled it

    -- If the key-threshold is set to 0, we omit it as this is the default
    -- and it looks odd to have a value for key-threshold but not for 'secure'
    -- (note that an empty list of keys is already omitted by default, since
    -- that is what we do for all list fields)
    showThreshold 0 = mempty
    showThreshold t = text (show t)

-- | Fields for the 'haddock' section.
haddockFlagsFields :: [FieldDescr HaddockFlags]
haddockFlagsFields =
  [ field
  | opt <- haddockOptions ParseArgs
  , let field = viewAsFieldDescr opt
        name = fieldName field
  , name `notElem` exclusions
  ]
  where
    exclusions = ["verbose", "builddir", "for-hackage"]

-- | Fields for the 'init' section.
initFlagsFields :: [FieldDescr IT.InitFlags]
initFlagsFields =
  [ field
  | opt <- initOptions ParseArgs
  , let field = viewAsFieldDescr opt
        name = fieldName field
  , name `notElem` exclusions
  ]
  where
    exclusions =
      [ "author"
      , "email"
      , "overwrite"
      , "package-dir"
      , "packagedir"
      , "package-name"
      , "version"
      , "homepage"
      , "synopsis"
      , "category"
      , "extra-source-file"
      , "lib"
      , "exe"
      , "libandexe"
      , "main-is"
      , "expose-module"
      , "exposed-modules"
      , "extension"
      , "dependency"
      , "build-tool"
      , "with-compiler"
      , "verbose"
      ]

-- | Fields for the 'program-locations' section.
withProgramsFields :: [FieldDescr [(String, FilePath)]]
withProgramsFields =
  map viewAsFieldDescr $
    programDbPaths'
      (++ "-location")
      defaultProgramDb
      ParseArgs
      id
      (++)

-- | Fields for the 'program-default-options' section.
withProgramOptionsFields :: [FieldDescr [(String, [String])]]
withProgramOptionsFields =
  map viewAsFieldDescr $
    programDbOptions defaultProgramDb ParseArgs id (++)

parseExtraLines :: Verbosity -> [String] -> IO SavedConfig
parseExtraLines verbosity extraLines =
  case parseConfig
    (ConstraintSourceMainConfig "additional lines")
    mempty
    (toUTF8BS (unlines extraLines)) of
    ParseFailed err ->
      let (line, msg) = locatedErrorMsg err
          errLineNo = maybe "" (\n -> ':' : show n) line
       in dieWithException verbosity $ ParseExtraLinesFailedErr msg errLineNo
    ParseOk [] r -> return r
    ParseOk ws _ ->
      dieWithException verbosity $ ParseExtraLinesOkError ws

-- | Get the differences (as a pseudo code diff) between the user's
-- config file and the one that cabal would generate if it didn't exist.
userConfigDiff :: Verbosity -> GlobalFlags -> [String] -> IO [String]
userConfigDiff verbosity globalFlags extraLines = do
  userConfig <- loadRawConfig normal (globalConfigFile globalFlags)
  extraConfig <- parseExtraLines verbosity extraLines
  testConfig <- initialSavedConfig
  return $
    reverse . foldl' createDiff [] . M.toList $
      M.unionWith
        combine
        (M.fromList . map justFst $ filterShow testConfig)
        (M.fromList . map justSnd $ filterShow (userConfig `mappend` extraConfig))
  where
    justFst (a, b) = (a, (Just b, Nothing))
    justSnd (a, b) = (a, (Nothing, Just b))

    combine (Nothing, Just b) (Just a, Nothing) = (Just a, Just b)
    combine (Just a, Nothing) (Nothing, Just b) = (Just a, Just b)
    combine x y =
      error $
        "Can't happen : userConfigDiff "
          ++ show x
          ++ " "
          ++ show y

    createDiff :: [String] -> (String, (Maybe String, Maybe String)) -> [String]
    createDiff acc (key, (Just a, Just b))
      | a == b = acc
      | otherwise =
          ("+ " ++ key ++ ": " ++ b)
            : ("- " ++ key ++ ": " ++ a)
            : acc
    createDiff acc (key, (Nothing, Just b)) = ("+ " ++ key ++ ": " ++ b) : acc
    createDiff acc (key, (Just a, Nothing)) = ("- " ++ key ++ ": " ++ a) : acc
    createDiff acc (_, (Nothing, Nothing)) = acc

    filterShow :: SavedConfig -> [(String, String)]
    filterShow cfg =
      map keyValueSplit
        . filter (\s -> not (null s) && ':' `elem` s)
        . map nonComment
        . lines
        $ showConfig cfg

    nonComment [] = []
    nonComment ('-' : '-' : _) = []
    nonComment (x : xs) = x : nonComment xs

    topAndTail = reverse . dropWhile isSpace . reverse . dropWhile isSpace

    keyValueSplit s =
      let (left, right) = break (== ':') s
       in (topAndTail left, topAndTail (drop 1 right))

-- | Update the user's config file keeping the user's customizations.
userConfigUpdate :: Verbosity -> GlobalFlags -> [String] -> IO ()
userConfigUpdate verbosity globalFlags extraLines = do
  userConfig <- loadRawConfig normal (globalConfigFile globalFlags)
  extraConfig <- parseExtraLines verbosity extraLines
  newConfig <- initialSavedConfig
  commentConf <- commentSavedConfig
  cabalFile <- getConfigFilePath $ globalConfigFile globalFlags
  let backup = cabalFile ++ ".backup"
  notice verbosity $ "Renaming " ++ cabalFile ++ " to " ++ backup ++ "."
  renameFile cabalFile backup
  notice verbosity $ "Writing merged config to " ++ cabalFile ++ "."
  writeConfigFile
    cabalFile
    commentConf
    (newConfig `mappend` userConfig `mappend` extraConfig)
