{-# 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
  { SavedConfig -> GlobalFlags
savedGlobalFlags :: GlobalFlags
  , SavedConfig -> InitFlags
savedInitFlags :: IT.InitFlags
  , SavedConfig -> InstallFlags
savedInstallFlags :: InstallFlags
  , SavedConfig -> ClientInstallFlags
savedClientInstallFlags :: ClientInstallFlags
  , SavedConfig -> ConfigFlags
savedConfigureFlags :: ConfigFlags
  , SavedConfig -> ConfigExFlags
savedConfigureExFlags :: ConfigExFlags
  , SavedConfig -> InstallDirs (Flag PathTemplate)
savedUserInstallDirs :: InstallDirs (Flag PathTemplate)
  , SavedConfig -> InstallDirs (Flag PathTemplate)
savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate)
  , SavedConfig -> UploadFlags
savedUploadFlags :: UploadFlags
  , SavedConfig -> ReportFlags
savedReportFlags :: ReportFlags
  , SavedConfig -> HaddockFlags
savedHaddockFlags :: HaddockFlags
  , SavedConfig -> TestFlags
savedTestFlags :: TestFlags
  , SavedConfig -> BenchmarkFlags
savedBenchmarkFlags :: BenchmarkFlags
  , SavedConfig -> ProjectFlags
savedProjectFlags :: ProjectFlags
  , SavedConfig -> Flag Bool
savedReplMulti :: Flag Bool
  }
  deriving ((forall x. SavedConfig -> Rep SavedConfig x)
-> (forall x. Rep SavedConfig x -> SavedConfig)
-> Generic SavedConfig
forall x. Rep SavedConfig x -> SavedConfig
forall x. SavedConfig -> Rep SavedConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SavedConfig -> Rep SavedConfig x
from :: forall x. SavedConfig -> Rep SavedConfig x
$cto :: forall x. Rep SavedConfig x -> SavedConfig
to :: forall x. Rep SavedConfig x -> SavedConfig
Generic)

instance Monoid SavedConfig where
  mempty :: SavedConfig
mempty = SavedConfig
forall a. (Generic a, GMonoid (Rep a)) => a
gmempty
  mappend :: SavedConfig -> SavedConfig -> SavedConfig
mappend = SavedConfig -> SavedConfig -> SavedConfig
forall a. Semigroup a => a -> a -> a
(<>)

instance Semigroup SavedConfig where
  SavedConfig
a <> :: SavedConfig -> SavedConfig -> SavedConfig
<> SavedConfig
b =
    SavedConfig
      { savedGlobalFlags :: GlobalFlags
savedGlobalFlags = GlobalFlags
combinedSavedGlobalFlags
      , savedInitFlags :: InitFlags
savedInitFlags = InitFlags
combinedSavedInitFlags
      , savedInstallFlags :: InstallFlags
savedInstallFlags = InstallFlags
combinedSavedInstallFlags
      , savedClientInstallFlags :: ClientInstallFlags
savedClientInstallFlags = ClientInstallFlags
combinedSavedClientInstallFlags
      , savedConfigureFlags :: ConfigFlags
savedConfigureFlags = ConfigFlags
combinedSavedConfigureFlags
      , savedConfigureExFlags :: ConfigExFlags
savedConfigureExFlags = ConfigExFlags
combinedSavedConfigureExFlags
      , savedUserInstallDirs :: InstallDirs (Flag PathTemplate)
savedUserInstallDirs = InstallDirs (Flag PathTemplate)
combinedSavedUserInstallDirs
      , savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate)
savedGlobalInstallDirs = InstallDirs (Flag PathTemplate)
combinedSavedGlobalInstallDirs
      , savedUploadFlags :: UploadFlags
savedUploadFlags = UploadFlags
combinedSavedUploadFlags
      , savedReportFlags :: ReportFlags
savedReportFlags = ReportFlags
combinedSavedReportFlags
      , savedHaddockFlags :: HaddockFlags
savedHaddockFlags = HaddockFlags
combinedSavedHaddockFlags
      , savedTestFlags :: TestFlags
savedTestFlags = TestFlags
combinedSavedTestFlags
      , savedBenchmarkFlags :: BenchmarkFlags
savedBenchmarkFlags = BenchmarkFlags
combinedSavedBenchmarkFlags
      , savedProjectFlags :: ProjectFlags
savedProjectFlags = ProjectFlags
combinedSavedProjectFlags
      , savedReplMulti :: Flag Bool
savedReplMulti = Flag Bool
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' :: forall flags a.
(SavedConfig -> flags) -> (flags -> Flag a) -> Flag a
combine' SavedConfig -> flags
field flags -> Flag a
subfield =
        (flags -> Flag a
subfield (flags -> Flag a)
-> (SavedConfig -> flags) -> SavedConfig -> Flag a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> flags
field (SavedConfig -> Flag a) -> SavedConfig -> Flag a
forall a b. (a -> b) -> a -> b
$ SavedConfig
a) Flag a -> Flag a -> Flag a
forall a. Monoid a => a -> a -> a
`mappend` (flags -> Flag a
subfield (flags -> Flag a)
-> (SavedConfig -> flags) -> SavedConfig -> Flag a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> flags
field (SavedConfig -> Flag a) -> SavedConfig -> Flag a
forall a b. (a -> b) -> a -> b
$ SavedConfig
b)

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

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

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

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

      combinedSavedGlobalFlags :: GlobalFlags
combinedSavedGlobalFlags =
        GlobalFlags
          { globalVersion :: Flag Bool
globalVersion = (GlobalFlags -> Flag Bool) -> Flag Bool
forall {a}. (GlobalFlags -> Flag a) -> Flag a
combine GlobalFlags -> Flag Bool
globalVersion
          , globalNumericVersion :: Flag Bool
globalNumericVersion = (GlobalFlags -> Flag Bool) -> Flag Bool
forall {a}. (GlobalFlags -> Flag a) -> Flag a
combine GlobalFlags -> Flag Bool
globalNumericVersion
          , globalConfigFile :: Flag String
globalConfigFile = (GlobalFlags -> Flag String) -> Flag String
forall {a}. (GlobalFlags -> Flag a) -> Flag a
combine GlobalFlags -> Flag String
globalConfigFile
          , globalConstraintsFile :: Flag String
globalConstraintsFile = (GlobalFlags -> Flag String) -> Flag String
forall {a}. (GlobalFlags -> Flag a) -> Flag a
combine GlobalFlags -> Flag String
globalConstraintsFile
          , globalRemoteRepos :: NubList RemoteRepo
globalRemoteRepos = (GlobalFlags -> NubList RemoteRepo) -> NubList RemoteRepo
forall {a}. (GlobalFlags -> NubList a) -> NubList a
lastNonEmptyNL GlobalFlags -> NubList RemoteRepo
globalRemoteRepos
          , globalCacheDir :: Flag String
globalCacheDir = (GlobalFlags -> Flag String) -> Flag String
forall {a}. (GlobalFlags -> Flag a) -> Flag a
combine GlobalFlags -> Flag String
globalCacheDir
          , globalLocalNoIndexRepos :: NubList LocalRepo
globalLocalNoIndexRepos = (GlobalFlags -> NubList LocalRepo) -> NubList LocalRepo
forall {a}. (GlobalFlags -> NubList a) -> NubList a
lastNonEmptyNL GlobalFlags -> NubList LocalRepo
globalLocalNoIndexRepos
          , globalActiveRepos :: Flag ActiveRepos
globalActiveRepos = (GlobalFlags -> Flag ActiveRepos) -> Flag ActiveRepos
forall {a}. (GlobalFlags -> Flag a) -> Flag a
combine GlobalFlags -> Flag ActiveRepos
globalActiveRepos
          , globalLogsDir :: Flag String
globalLogsDir = (GlobalFlags -> Flag String) -> Flag String
forall {a}. (GlobalFlags -> Flag a) -> Flag a
combine GlobalFlags -> Flag String
globalLogsDir
          , globalIgnoreExpiry :: Flag Bool
globalIgnoreExpiry = (GlobalFlags -> Flag Bool) -> Flag Bool
forall {a}. (GlobalFlags -> Flag a) -> Flag a
combine GlobalFlags -> Flag Bool
globalIgnoreExpiry
          , globalHttpTransport :: Flag String
globalHttpTransport = (GlobalFlags -> Flag String) -> Flag String
forall {a}. (GlobalFlags -> Flag a) -> Flag a
combine GlobalFlags -> Flag String
globalHttpTransport
          , globalNix :: Flag Bool
globalNix = (GlobalFlags -> Flag Bool) -> Flag Bool
forall {a}. (GlobalFlags -> Flag a) -> Flag a
combine GlobalFlags -> Flag Bool
globalNix
          , globalStoreDir :: Flag String
globalStoreDir = (GlobalFlags -> Flag String) -> Flag String
forall {a}. (GlobalFlags -> Flag a) -> Flag a
combine GlobalFlags -> Flag String
globalStoreDir
          , globalProgPathExtra :: NubList String
globalProgPathExtra = (GlobalFlags -> NubList String) -> NubList String
forall {a}. (GlobalFlags -> NubList a) -> NubList a
lastNonEmptyNL GlobalFlags -> NubList String
globalProgPathExtra
          }
        where
          combine :: (GlobalFlags -> Flag a) -> Flag a
combine = (SavedConfig -> GlobalFlags) -> (GlobalFlags -> Flag a) -> Flag a
forall flags a.
(SavedConfig -> flags) -> (flags -> Flag a) -> Flag a
combine' SavedConfig -> GlobalFlags
savedGlobalFlags
          lastNonEmptyNL :: (GlobalFlags -> NubList a) -> NubList a
lastNonEmptyNL = (SavedConfig -> GlobalFlags)
-> (GlobalFlags -> NubList a) -> NubList a
forall flags a.
(SavedConfig -> flags) -> (flags -> NubList a) -> NubList a
lastNonEmptyNL' SavedConfig -> GlobalFlags
savedGlobalFlags

      combinedSavedInitFlags :: InitFlags
combinedSavedInitFlags =
        IT.InitFlags
          { applicationDirs :: Flag [String]
IT.applicationDirs = (SavedConfig -> InitFlags)
-> (InitFlags -> Flag [String]) -> Flag [String]
forall mon flags.
Monoid mon =>
(SavedConfig -> flags) -> (flags -> mon) -> mon
combineMonoid SavedConfig -> InitFlags
savedInitFlags InitFlags -> Flag [String]
IT.applicationDirs
          , author :: Flag String
IT.author = (InitFlags -> Flag String) -> Flag String
forall {a}. (InitFlags -> Flag a) -> Flag a
combine InitFlags -> Flag String
IT.author
          , buildTools :: Flag [String]
IT.buildTools = (SavedConfig -> InitFlags)
-> (InitFlags -> Flag [String]) -> Flag [String]
forall mon flags.
Monoid mon =>
(SavedConfig -> flags) -> (flags -> mon) -> mon
combineMonoid SavedConfig -> InitFlags
savedInitFlags InitFlags -> Flag [String]
IT.buildTools
          , cabalVersion :: Flag CabalSpecVersion
IT.cabalVersion = (InitFlags -> Flag CabalSpecVersion) -> Flag CabalSpecVersion
forall {a}. (InitFlags -> Flag a) -> Flag a
combine InitFlags -> Flag CabalSpecVersion
IT.cabalVersion
          , category :: Flag String
IT.category = (InitFlags -> Flag String) -> Flag String
forall {a}. (InitFlags -> Flag a) -> Flag a
combine InitFlags -> Flag String
IT.category
          , dependencies :: Flag [Dependency]
IT.dependencies = (SavedConfig -> InitFlags)
-> (InitFlags -> Flag [Dependency]) -> Flag [Dependency]
forall mon flags.
Monoid mon =>
(SavedConfig -> flags) -> (flags -> mon) -> mon
combineMonoid SavedConfig -> InitFlags
savedInitFlags InitFlags -> Flag [Dependency]
IT.dependencies
          , email :: Flag String
IT.email = (InitFlags -> Flag String) -> Flag String
forall {a}. (InitFlags -> Flag a) -> Flag a
combine InitFlags -> Flag String
IT.email
          , exposedModules :: Flag [ModuleName]
IT.exposedModules = (SavedConfig -> InitFlags)
-> (InitFlags -> Flag [ModuleName]) -> Flag [ModuleName]
forall mon flags.
Monoid mon =>
(SavedConfig -> flags) -> (flags -> mon) -> mon
combineMonoid SavedConfig -> InitFlags
savedInitFlags InitFlags -> Flag [ModuleName]
IT.exposedModules
          , extraSrc :: Flag [String]
IT.extraSrc = (SavedConfig -> InitFlags)
-> (InitFlags -> Flag [String]) -> Flag [String]
forall mon flags.
Monoid mon =>
(SavedConfig -> flags) -> (flags -> mon) -> mon
combineMonoid SavedConfig -> InitFlags
savedInitFlags InitFlags -> Flag [String]
IT.extraSrc
          , extraDoc :: Flag [String]
IT.extraDoc = (SavedConfig -> InitFlags)
-> (InitFlags -> Flag [String]) -> Flag [String]
forall mon flags.
Monoid mon =>
(SavedConfig -> flags) -> (flags -> mon) -> mon
combineMonoid SavedConfig -> InitFlags
savedInitFlags InitFlags -> Flag [String]
IT.extraDoc
          , homepage :: Flag String
IT.homepage = (InitFlags -> Flag String) -> Flag String
forall {a}. (InitFlags -> Flag a) -> Flag a
combine InitFlags -> Flag String
IT.homepage
          , initHcPath :: Flag String
IT.initHcPath = (InitFlags -> Flag String) -> Flag String
forall {a}. (InitFlags -> Flag a) -> Flag a
combine InitFlags -> Flag String
IT.initHcPath
          , initVerbosity :: Flag Verbosity
IT.initVerbosity = (InitFlags -> Flag Verbosity) -> Flag Verbosity
forall {a}. (InitFlags -> Flag a) -> Flag a
combine InitFlags -> Flag Verbosity
IT.initVerbosity
          , initializeTestSuite :: Flag Bool
IT.initializeTestSuite = (InitFlags -> Flag Bool) -> Flag Bool
forall {a}. (InitFlags -> Flag a) -> Flag a
combine InitFlags -> Flag Bool
IT.initializeTestSuite
          , interactive :: Flag Bool
IT.interactive = (InitFlags -> Flag Bool) -> Flag Bool
forall {a}. (InitFlags -> Flag a) -> Flag a
combine InitFlags -> Flag Bool
IT.interactive
          , language :: Flag Language
IT.language = (InitFlags -> Flag Language) -> Flag Language
forall {a}. (InitFlags -> Flag a) -> Flag a
combine InitFlags -> Flag Language
IT.language
          , license :: Flag SpecLicense
IT.license = (InitFlags -> Flag SpecLicense) -> Flag SpecLicense
forall {a}. (InitFlags -> Flag a) -> Flag a
combine InitFlags -> Flag SpecLicense
IT.license
          , mainIs :: Flag String
IT.mainIs = (InitFlags -> Flag String) -> Flag String
forall {a}. (InitFlags -> Flag a) -> Flag a
combine InitFlags -> Flag String
IT.mainIs
          , minimal :: Flag Bool
IT.minimal = (InitFlags -> Flag Bool) -> Flag Bool
forall {a}. (InitFlags -> Flag a) -> Flag a
combine InitFlags -> Flag Bool
IT.minimal
          , noComments :: Flag Bool
IT.noComments = (InitFlags -> Flag Bool) -> Flag Bool
forall {a}. (InitFlags -> Flag a) -> Flag a
combine InitFlags -> Flag Bool
IT.noComments
          , otherExts :: Flag [Extension]
IT.otherExts = (SavedConfig -> InitFlags)
-> (InitFlags -> Flag [Extension]) -> Flag [Extension]
forall mon flags.
Monoid mon =>
(SavedConfig -> flags) -> (flags -> mon) -> mon
combineMonoid SavedConfig -> InitFlags
savedInitFlags InitFlags -> Flag [Extension]
IT.otherExts
          , otherModules :: Flag [ModuleName]
IT.otherModules = (SavedConfig -> InitFlags)
-> (InitFlags -> Flag [ModuleName]) -> Flag [ModuleName]
forall mon flags.
Monoid mon =>
(SavedConfig -> flags) -> (flags -> mon) -> mon
combineMonoid SavedConfig -> InitFlags
savedInitFlags InitFlags -> Flag [ModuleName]
IT.otherModules
          , overwrite :: Flag Bool
IT.overwrite = (InitFlags -> Flag Bool) -> Flag Bool
forall {a}. (InitFlags -> Flag a) -> Flag a
combine InitFlags -> Flag Bool
IT.overwrite
          , packageDir :: Flag String
IT.packageDir = (InitFlags -> Flag String) -> Flag String
forall {a}. (InitFlags -> Flag a) -> Flag a
combine InitFlags -> Flag String
IT.packageDir
          , packageName :: Flag PackageName
IT.packageName = (InitFlags -> Flag PackageName) -> Flag PackageName
forall {a}. (InitFlags -> Flag a) -> Flag a
combine InitFlags -> Flag PackageName
IT.packageName
          , packageType :: Flag PackageType
IT.packageType = (InitFlags -> Flag PackageType) -> Flag PackageType
forall {a}. (InitFlags -> Flag a) -> Flag a
combine InitFlags -> Flag PackageType
IT.packageType
          , quiet :: Flag Bool
IT.quiet = (InitFlags -> Flag Bool) -> Flag Bool
forall {a}. (InitFlags -> Flag a) -> Flag a
combine InitFlags -> Flag Bool
IT.quiet
          , simpleProject :: Flag Bool
IT.simpleProject = (InitFlags -> Flag Bool) -> Flag Bool
forall {a}. (InitFlags -> Flag a) -> Flag a
combine InitFlags -> Flag Bool
IT.simpleProject
          , sourceDirs :: Flag [String]
IT.sourceDirs = (SavedConfig -> InitFlags)
-> (InitFlags -> Flag [String]) -> Flag [String]
forall mon flags.
Monoid mon =>
(SavedConfig -> flags) -> (flags -> mon) -> mon
combineMonoid SavedConfig -> InitFlags
savedInitFlags InitFlags -> Flag [String]
IT.sourceDirs
          , synopsis :: Flag String
IT.synopsis = (InitFlags -> Flag String) -> Flag String
forall {a}. (InitFlags -> Flag a) -> Flag a
combine InitFlags -> Flag String
IT.synopsis
          , testDirs :: Flag [String]
IT.testDirs = (SavedConfig -> InitFlags)
-> (InitFlags -> Flag [String]) -> Flag [String]
forall mon flags.
Monoid mon =>
(SavedConfig -> flags) -> (flags -> mon) -> mon
combineMonoid SavedConfig -> InitFlags
savedInitFlags InitFlags -> Flag [String]
IT.testDirs
          , version :: Flag Version
IT.version = (InitFlags -> Flag Version) -> Flag Version
forall {a}. (InitFlags -> Flag a) -> Flag a
combine InitFlags -> Flag Version
IT.version
          }
        where
          combine :: (InitFlags -> Flag a) -> Flag a
combine = (SavedConfig -> InitFlags) -> (InitFlags -> Flag a) -> Flag a
forall flags a.
(SavedConfig -> flags) -> (flags -> Flag a) -> Flag a
combine' SavedConfig -> InitFlags
savedInitFlags

      combinedSavedInstallFlags :: InstallFlags
combinedSavedInstallFlags =
        InstallFlags
          { installDocumentation :: Flag Bool
installDocumentation = (InstallFlags -> Flag Bool) -> Flag Bool
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag Bool
installDocumentation
          , installHaddockIndex :: Flag PathTemplate
installHaddockIndex = (InstallFlags -> Flag PathTemplate) -> Flag PathTemplate
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag PathTemplate
installHaddockIndex
          , installDryRun :: Flag Bool
installDryRun = (InstallFlags -> Flag Bool) -> Flag Bool
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag Bool
installDryRun
          , installOnlyDownload :: Flag Bool
installOnlyDownload = (InstallFlags -> Flag Bool) -> Flag Bool
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag Bool
installOnlyDownload
          , installDest :: Flag CopyDest
installDest = (InstallFlags -> Flag CopyDest) -> Flag CopyDest
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag CopyDest
installDest
          , installMaxBackjumps :: Flag Int
installMaxBackjumps = (InstallFlags -> Flag Int) -> Flag Int
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag Int
installMaxBackjumps
          , installReorderGoals :: Flag ReorderGoals
installReorderGoals = (InstallFlags -> Flag ReorderGoals) -> Flag ReorderGoals
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag ReorderGoals
installReorderGoals
          , installCountConflicts :: Flag CountConflicts
installCountConflicts = (InstallFlags -> Flag CountConflicts) -> Flag CountConflicts
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag CountConflicts
installCountConflicts
          , installFineGrainedConflicts :: Flag FineGrainedConflicts
installFineGrainedConflicts = (InstallFlags -> Flag FineGrainedConflicts)
-> Flag FineGrainedConflicts
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag FineGrainedConflicts
installFineGrainedConflicts
          , installMinimizeConflictSet :: Flag MinimizeConflictSet
installMinimizeConflictSet = (InstallFlags -> Flag MinimizeConflictSet)
-> Flag MinimizeConflictSet
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag MinimizeConflictSet
installMinimizeConflictSet
          , installIndependentGoals :: Flag IndependentGoals
installIndependentGoals = (InstallFlags -> Flag IndependentGoals) -> Flag IndependentGoals
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag IndependentGoals
installIndependentGoals
          , installPreferOldest :: Flag PreferOldest
installPreferOldest = (InstallFlags -> Flag PreferOldest) -> Flag PreferOldest
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag PreferOldest
installPreferOldest
          , installShadowPkgs :: Flag ShadowPkgs
installShadowPkgs = (InstallFlags -> Flag ShadowPkgs) -> Flag ShadowPkgs
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag ShadowPkgs
installShadowPkgs
          , installStrongFlags :: Flag StrongFlags
installStrongFlags = (InstallFlags -> Flag StrongFlags) -> Flag StrongFlags
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag StrongFlags
installStrongFlags
          , installAllowBootLibInstalls :: Flag AllowBootLibInstalls
installAllowBootLibInstalls = (InstallFlags -> Flag AllowBootLibInstalls)
-> Flag AllowBootLibInstalls
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag AllowBootLibInstalls
installAllowBootLibInstalls
          , installOnlyConstrained :: Flag OnlyConstrained
installOnlyConstrained = (InstallFlags -> Flag OnlyConstrained) -> Flag OnlyConstrained
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag OnlyConstrained
installOnlyConstrained
          , installReinstall :: Flag Bool
installReinstall = (InstallFlags -> Flag Bool) -> Flag Bool
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag Bool
installReinstall
          , installAvoidReinstalls :: Flag AvoidReinstalls
installAvoidReinstalls = (InstallFlags -> Flag AvoidReinstalls) -> Flag AvoidReinstalls
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag AvoidReinstalls
installAvoidReinstalls
          , installOverrideReinstall :: Flag Bool
installOverrideReinstall = (InstallFlags -> Flag Bool) -> Flag Bool
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag Bool
installOverrideReinstall
          , installUpgradeDeps :: Flag Bool
installUpgradeDeps = (InstallFlags -> Flag Bool) -> Flag Bool
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag Bool
installUpgradeDeps
          , installOnly :: Flag Bool
installOnly = (InstallFlags -> Flag Bool) -> Flag Bool
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag Bool
installOnly
          , installOnlyDeps :: Flag Bool
installOnlyDeps = (InstallFlags -> Flag Bool) -> Flag Bool
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag Bool
installOnlyDeps
          , installIndexState :: Flag TotalIndexState
installIndexState = (InstallFlags -> Flag TotalIndexState) -> Flag TotalIndexState
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag TotalIndexState
installIndexState
          , installRootCmd :: Flag String
installRootCmd = (InstallFlags -> Flag String) -> Flag String
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag String
installRootCmd
          , installSummaryFile :: NubList PathTemplate
installSummaryFile = (InstallFlags -> NubList PathTemplate) -> NubList PathTemplate
forall {a}. (InstallFlags -> NubList a) -> NubList a
lastNonEmptyNL InstallFlags -> NubList PathTemplate
installSummaryFile
          , installLogFile :: Flag PathTemplate
installLogFile = (InstallFlags -> Flag PathTemplate) -> Flag PathTemplate
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag PathTemplate
installLogFile
          , installBuildReports :: Flag ReportLevel
installBuildReports = (InstallFlags -> Flag ReportLevel) -> Flag ReportLevel
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag ReportLevel
installBuildReports
          , installReportPlanningFailure :: Flag Bool
installReportPlanningFailure = (InstallFlags -> Flag Bool) -> Flag Bool
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag Bool
installReportPlanningFailure
          , installSymlinkBinDir :: Flag String
installSymlinkBinDir = (InstallFlags -> Flag String) -> Flag String
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag String
installSymlinkBinDir
          , installPerComponent :: Flag Bool
installPerComponent = (InstallFlags -> Flag Bool) -> Flag Bool
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag Bool
installPerComponent
          , installNumJobs :: Flag (Maybe Int)
installNumJobs = (InstallFlags -> Flag (Maybe Int)) -> Flag (Maybe Int)
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag (Maybe Int)
installNumJobs
          , installUseSemaphore :: Flag Bool
installUseSemaphore = (InstallFlags -> Flag Bool) -> Flag Bool
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag Bool
installUseSemaphore
          , installKeepGoing :: Flag Bool
installKeepGoing = (InstallFlags -> Flag Bool) -> Flag Bool
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag Bool
installKeepGoing
          , installRunTests :: Flag Bool
installRunTests = (InstallFlags -> Flag Bool) -> Flag Bool
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag Bool
installRunTests
          , installOfflineMode :: Flag Bool
installOfflineMode = (InstallFlags -> Flag Bool) -> Flag Bool
forall {a}. (InstallFlags -> Flag a) -> Flag a
combine InstallFlags -> Flag Bool
installOfflineMode
          }
        where
          combine :: (InstallFlags -> Flag a) -> Flag a
combine = (SavedConfig -> InstallFlags) -> (InstallFlags -> Flag a) -> Flag a
forall flags a.
(SavedConfig -> flags) -> (flags -> Flag a) -> Flag a
combine' SavedConfig -> InstallFlags
savedInstallFlags
          lastNonEmptyNL :: (InstallFlags -> NubList a) -> NubList a
lastNonEmptyNL = (SavedConfig -> InstallFlags)
-> (InstallFlags -> NubList a) -> NubList a
forall flags a.
(SavedConfig -> flags) -> (flags -> NubList a) -> NubList a
lastNonEmptyNL' SavedConfig -> InstallFlags
savedInstallFlags

      combinedSavedClientInstallFlags :: ClientInstallFlags
combinedSavedClientInstallFlags =
        ClientInstallFlags
          { cinstInstallLibs :: Flag Bool
cinstInstallLibs = (ClientInstallFlags -> Flag Bool) -> Flag Bool
forall {a}. (ClientInstallFlags -> Flag a) -> Flag a
combine ClientInstallFlags -> Flag Bool
cinstInstallLibs
          , cinstEnvironmentPath :: Flag String
cinstEnvironmentPath = (ClientInstallFlags -> Flag String) -> Flag String
forall {a}. (ClientInstallFlags -> Flag a) -> Flag a
combine ClientInstallFlags -> Flag String
cinstEnvironmentPath
          , cinstOverwritePolicy :: Flag OverwritePolicy
cinstOverwritePolicy = (ClientInstallFlags -> Flag OverwritePolicy)
-> Flag OverwritePolicy
forall {a}. (ClientInstallFlags -> Flag a) -> Flag a
combine ClientInstallFlags -> Flag OverwritePolicy
cinstOverwritePolicy
          , cinstInstallMethod :: Flag InstallMethod
cinstInstallMethod = (ClientInstallFlags -> Flag InstallMethod) -> Flag InstallMethod
forall {a}. (ClientInstallFlags -> Flag a) -> Flag a
combine ClientInstallFlags -> Flag InstallMethod
cinstInstallMethod
          , cinstInstalldir :: Flag String
cinstInstalldir = (ClientInstallFlags -> Flag String) -> Flag String
forall {a}. (ClientInstallFlags -> Flag a) -> Flag a
combine ClientInstallFlags -> Flag String
cinstInstalldir
          }
        where
          combine :: (ClientInstallFlags -> Flag a) -> Flag a
combine = (SavedConfig -> ClientInstallFlags)
-> (ClientInstallFlags -> Flag a) -> Flag a
forall flags a.
(SavedConfig -> flags) -> (flags -> Flag a) -> Flag a
combine' SavedConfig -> ClientInstallFlags
savedClientInstallFlags

      combinedSavedCommonFlags :: (SavedConfig -> CommonSetupFlags) -> CommonSetupFlags
combinedSavedCommonFlags SavedConfig -> CommonSetupFlags
which =
        CommonSetupFlags
          { setupDistPref :: Flag (SymbolicPath Pkg ('Dir Dist))
setupDistPref = (CommonSetupFlags -> Flag (SymbolicPath Pkg ('Dir Dist)))
-> Flag (SymbolicPath Pkg ('Dir Dist))
forall {a}. (CommonSetupFlags -> Flag a) -> Flag a
combine CommonSetupFlags -> Flag (SymbolicPath Pkg ('Dir Dist))
setupDistPref
          , setupWorkingDir :: Flag (SymbolicPath CWD ('Dir Pkg))
setupWorkingDir = (CommonSetupFlags -> Flag (SymbolicPath CWD ('Dir Pkg)))
-> Flag (SymbolicPath CWD ('Dir Pkg))
forall {a}. (CommonSetupFlags -> Flag a) -> Flag a
combine CommonSetupFlags -> Flag (SymbolicPath CWD ('Dir Pkg))
setupWorkingDir
          , setupCabalFilePath :: Flag (SymbolicPath Pkg 'File)
setupCabalFilePath = (CommonSetupFlags -> Flag (SymbolicPath Pkg 'File))
-> Flag (SymbolicPath Pkg 'File)
forall {a}. (CommonSetupFlags -> Flag a) -> Flag a
combine CommonSetupFlags -> Flag (SymbolicPath Pkg 'File)
setupCabalFilePath
          , setupVerbosity :: Flag Verbosity
setupVerbosity = (CommonSetupFlags -> Flag Verbosity) -> Flag Verbosity
forall {a}. (CommonSetupFlags -> Flag a) -> Flag a
combine CommonSetupFlags -> Flag Verbosity
setupVerbosity
          , setupTargets :: [String]
setupTargets = (CommonSetupFlags -> [String]) -> [String]
forall {a}. (CommonSetupFlags -> [a]) -> [a]
lastNonEmpty CommonSetupFlags -> [String]
setupTargets
          }
        where
          lastNonEmpty :: (CommonSetupFlags -> [a]) -> [a]
lastNonEmpty = (SavedConfig -> CommonSetupFlags)
-> (CommonSetupFlags -> [a]) -> [a]
forall flags a. (SavedConfig -> flags) -> (flags -> [a]) -> [a]
lastNonEmpty' SavedConfig -> CommonSetupFlags
which
          combine :: (CommonSetupFlags -> Flag a) -> Flag a
combine = (SavedConfig -> CommonSetupFlags)
-> (CommonSetupFlags -> Flag a) -> Flag a
forall flags a.
(SavedConfig -> flags) -> (flags -> Flag a) -> Flag a
combine' SavedConfig -> CommonSetupFlags
which

      combinedSavedConfigureFlags :: ConfigFlags
combinedSavedConfigureFlags =
        ConfigFlags
          { configCommonFlags :: CommonSetupFlags
configCommonFlags = (SavedConfig -> CommonSetupFlags) -> CommonSetupFlags
combinedSavedCommonFlags (ConfigFlags -> CommonSetupFlags
configCommonFlags (ConfigFlags -> CommonSetupFlags)
-> (SavedConfig -> ConfigFlags) -> SavedConfig -> CommonSetupFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> ConfigFlags
savedConfigureFlags)
          , configPrograms_ :: Option' (Last' ProgramDb)
configPrograms_ = ConfigFlags -> Option' (Last' ProgramDb)
configPrograms_ (ConfigFlags -> Option' (Last' ProgramDb))
-> (SavedConfig -> ConfigFlags)
-> SavedConfig
-> Option' (Last' ProgramDb)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> ConfigFlags
savedConfigureFlags (SavedConfig -> Option' (Last' ProgramDb))
-> SavedConfig -> Option' (Last' ProgramDb)
forall a b. (a -> b) -> a -> b
$ SavedConfig
b
          , -- TODO: NubListify
            configProgramPaths :: [(String, String)]
configProgramPaths = (ConfigFlags -> [(String, String)]) -> [(String, String)]
forall {a}. (ConfigFlags -> [a]) -> [a]
lastNonEmpty ConfigFlags -> [(String, String)]
configProgramPaths
          , -- TODO: NubListify
            configProgramArgs :: [(String, [String])]
configProgramArgs = (ConfigFlags -> [(String, [String])]) -> [(String, [String])]
forall {a}. (ConfigFlags -> [a]) -> [a]
lastNonEmpty ConfigFlags -> [(String, [String])]
configProgramArgs
          , configProgramPathExtra :: NubList String
configProgramPathExtra = (ConfigFlags -> NubList String) -> NubList String
forall {a}. (ConfigFlags -> NubList a) -> NubList a
lastNonEmptyNL ConfigFlags -> NubList String
configProgramPathExtra
          , configInstantiateWith :: [(ModuleName, Module)]
configInstantiateWith = (ConfigFlags -> [(ModuleName, Module)]) -> [(ModuleName, Module)]
forall {a}. (ConfigFlags -> [a]) -> [a]
lastNonEmpty ConfigFlags -> [(ModuleName, Module)]
configInstantiateWith
          , configHcFlavor :: Flag CompilerFlavor
configHcFlavor = (ConfigFlags -> Flag CompilerFlavor) -> Flag CompilerFlavor
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag CompilerFlavor
configHcFlavor
          , configHcPath :: Flag String
configHcPath = (ConfigFlags -> Flag String) -> Flag String
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag String
configHcPath
          , configHcPkg :: Flag String
configHcPkg = (ConfigFlags -> Flag String) -> Flag String
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag String
configHcPkg
          , configVanillaLib :: Flag Bool
configVanillaLib = (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configVanillaLib
          , configProfLib :: Flag Bool
configProfLib = (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configProfLib
          , configProf :: Flag Bool
configProf = (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configProf
          , configProfShared :: Flag Bool
configProfShared = (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configProfShared
          , configSharedLib :: Flag Bool
configSharedLib = (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configSharedLib
          , configStaticLib :: Flag Bool
configStaticLib = (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configStaticLib
          , configDynExe :: Flag Bool
configDynExe = (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configDynExe
          , configFullyStaticExe :: Flag Bool
configFullyStaticExe = (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configFullyStaticExe
          , configProfExe :: Flag Bool
configProfExe = (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configProfExe
          , configProfDetail :: Flag ProfDetailLevel
configProfDetail = (ConfigFlags -> Flag ProfDetailLevel) -> Flag ProfDetailLevel
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag ProfDetailLevel
configProfDetail
          , configProfLibDetail :: Flag ProfDetailLevel
configProfLibDetail = (ConfigFlags -> Flag ProfDetailLevel) -> Flag ProfDetailLevel
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag ProfDetailLevel
configProfLibDetail
          , -- TODO: NubListify
            configConfigureArgs :: [String]
configConfigureArgs = (ConfigFlags -> [String]) -> [String]
forall {a}. (ConfigFlags -> [a]) -> [a]
lastNonEmpty ConfigFlags -> [String]
configConfigureArgs
          , configOptimization :: Flag OptimisationLevel
configOptimization = (ConfigFlags -> Flag OptimisationLevel) -> Flag OptimisationLevel
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag OptimisationLevel
configOptimization
          , configDebugInfo :: Flag DebugInfoLevel
configDebugInfo = (ConfigFlags -> Flag DebugInfoLevel) -> Flag DebugInfoLevel
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag DebugInfoLevel
configDebugInfo
          , configProgPrefix :: Flag PathTemplate
configProgPrefix = (ConfigFlags -> Flag PathTemplate) -> Flag PathTemplate
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag PathTemplate
configProgPrefix
          , configProgSuffix :: Flag PathTemplate
configProgSuffix = (ConfigFlags -> Flag PathTemplate) -> Flag PathTemplate
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag PathTemplate
configProgSuffix
          , -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.
            configInstallDirs :: InstallDirs (Flag PathTemplate)
configInstallDirs =
              (ConfigFlags -> InstallDirs (Flag PathTemplate)
configInstallDirs (ConfigFlags -> InstallDirs (Flag PathTemplate))
-> (SavedConfig -> ConfigFlags)
-> SavedConfig
-> InstallDirs (Flag PathTemplate)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> ConfigFlags
savedConfigureFlags (SavedConfig -> InstallDirs (Flag PathTemplate))
-> SavedConfig -> InstallDirs (Flag PathTemplate)
forall a b. (a -> b) -> a -> b
$ SavedConfig
a)
                InstallDirs (Flag PathTemplate)
-> InstallDirs (Flag PathTemplate)
-> InstallDirs (Flag PathTemplate)
forall a. Monoid a => a -> a -> a
`mappend` (ConfigFlags -> InstallDirs (Flag PathTemplate)
configInstallDirs (ConfigFlags -> InstallDirs (Flag PathTemplate))
-> (SavedConfig -> ConfigFlags)
-> SavedConfig
-> InstallDirs (Flag PathTemplate)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> ConfigFlags
savedConfigureFlags (SavedConfig -> InstallDirs (Flag PathTemplate))
-> SavedConfig -> InstallDirs (Flag PathTemplate)
forall a b. (a -> b) -> a -> b
$ SavedConfig
b)
          , configScratchDir :: Flag String
configScratchDir = (ConfigFlags -> Flag String) -> Flag String
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag String
configScratchDir
          , -- TODO: NubListify
            configExtraLibDirs :: [SymbolicPath Pkg ('Dir Lib)]
configExtraLibDirs = (ConfigFlags -> [SymbolicPath Pkg ('Dir Lib)])
-> [SymbolicPath Pkg ('Dir Lib)]
forall {a}. (ConfigFlags -> [a]) -> [a]
lastNonEmpty ConfigFlags -> [SymbolicPath Pkg ('Dir Lib)]
configExtraLibDirs
          , configExtraLibDirsStatic :: [SymbolicPath Pkg ('Dir Lib)]
configExtraLibDirsStatic = (ConfigFlags -> [SymbolicPath Pkg ('Dir Lib)])
-> [SymbolicPath Pkg ('Dir Lib)]
forall {a}. (ConfigFlags -> [a]) -> [a]
lastNonEmpty ConfigFlags -> [SymbolicPath Pkg ('Dir Lib)]
configExtraLibDirsStatic
          , -- TODO: NubListify
            configExtraFrameworkDirs :: [SymbolicPath Pkg ('Dir Framework)]
configExtraFrameworkDirs = (ConfigFlags -> [SymbolicPath Pkg ('Dir Framework)])
-> [SymbolicPath Pkg ('Dir Framework)]
forall {a}. (ConfigFlags -> [a]) -> [a]
lastNonEmpty ConfigFlags -> [SymbolicPath Pkg ('Dir Framework)]
configExtraFrameworkDirs
          , -- TODO: NubListify
            configExtraIncludeDirs :: [SymbolicPath Pkg ('Dir Include)]
configExtraIncludeDirs = (ConfigFlags -> [SymbolicPath Pkg ('Dir Include)])
-> [SymbolicPath Pkg ('Dir Include)]
forall {a}. (ConfigFlags -> [a]) -> [a]
lastNonEmpty ConfigFlags -> [SymbolicPath Pkg ('Dir Include)]
configExtraIncludeDirs
          , configDeterministic :: Flag Bool
configDeterministic = (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configDeterministic
          , configIPID :: Flag String
configIPID = (ConfigFlags -> Flag String) -> Flag String
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag String
configIPID
          , configCID :: Flag ComponentId
configCID = (ConfigFlags -> Flag ComponentId) -> Flag ComponentId
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag ComponentId
configCID
          , configUserInstall :: Flag Bool
configUserInstall = (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configUserInstall
          , -- TODO: NubListify
            configPackageDBs :: [Maybe PackageDB]
configPackageDBs = (ConfigFlags -> [Maybe PackageDB]) -> [Maybe PackageDB]
forall {a}. (ConfigFlags -> [a]) -> [a]
lastNonEmpty ConfigFlags -> [Maybe PackageDB]
configPackageDBs
          , configGHCiLib :: Flag Bool
configGHCiLib = (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configGHCiLib
          , configSplitSections :: Flag Bool
configSplitSections = (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configSplitSections
          , configSplitObjs :: Flag Bool
configSplitObjs = (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configSplitObjs
          , configStripExes :: Flag Bool
configStripExes = (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configStripExes
          , configStripLibs :: Flag Bool
configStripLibs = (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configStripLibs
          , -- TODO: NubListify
            configConstraints :: [PackageVersionConstraint]
configConstraints = (ConfigFlags -> [PackageVersionConstraint])
-> [PackageVersionConstraint]
forall {a}. (ConfigFlags -> [a]) -> [a]
lastNonEmpty ConfigFlags -> [PackageVersionConstraint]
configConstraints
          , -- TODO: NubListify
            configDependencies :: [GivenComponent]
configDependencies = (ConfigFlags -> [GivenComponent]) -> [GivenComponent]
forall {a}. (ConfigFlags -> [a]) -> [a]
lastNonEmpty ConfigFlags -> [GivenComponent]
configDependencies
          , configPromisedDependencies :: [PromisedComponent]
configPromisedDependencies = (ConfigFlags -> [PromisedComponent]) -> [PromisedComponent]
forall {a}. (ConfigFlags -> [a]) -> [a]
lastNonEmpty ConfigFlags -> [PromisedComponent]
configPromisedDependencies
          , -- TODO: NubListify
            configConfigurationsFlags :: FlagAssignment
configConfigurationsFlags = (ConfigFlags -> FlagAssignment) -> FlagAssignment
lastNonMempty ConfigFlags -> FlagAssignment
configConfigurationsFlags
          , configTests :: Flag Bool
configTests = (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configTests
          , configBenchmarks :: Flag Bool
configBenchmarks = (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configBenchmarks
          , configCoverage :: Flag Bool
configCoverage = (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configCoverage
          , configLibCoverage :: Flag Bool
configLibCoverage = (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configLibCoverage
          , configExactConfiguration :: Flag Bool
configExactConfiguration = (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configExactConfiguration
          , configFlagError :: Flag String
configFlagError = (ConfigFlags -> Flag String) -> Flag String
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag String
configFlagError
          , configRelocatable :: Flag Bool
configRelocatable = (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configRelocatable
          , configUseResponseFiles :: Flag Bool
configUseResponseFiles = (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configUseResponseFiles
          , configDumpBuildInfo :: Flag DumpBuildInfo
configDumpBuildInfo = (ConfigFlags -> Flag DumpBuildInfo) -> Flag DumpBuildInfo
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag DumpBuildInfo
configDumpBuildInfo
          , configAllowDependingOnPrivateLibs :: Flag Bool
configAllowDependingOnPrivateLibs =
              (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configAllowDependingOnPrivateLibs
          , configCoverageFor :: Flag [UnitId]
configCoverageFor = (ConfigFlags -> Flag [UnitId]) -> Flag [UnitId]
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag [UnitId]
configCoverageFor
          , configIgnoreBuildTools :: Flag Bool
configIgnoreBuildTools = (ConfigFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigFlags -> Flag a) -> Flag a
combine ConfigFlags -> Flag Bool
configIgnoreBuildTools
          }
        where
          combine :: (ConfigFlags -> Flag a) -> Flag a
combine = (SavedConfig -> ConfigFlags) -> (ConfigFlags -> Flag a) -> Flag a
forall flags a.
(SavedConfig -> flags) -> (flags -> Flag a) -> Flag a
combine' SavedConfig -> ConfigFlags
savedConfigureFlags
          lastNonEmpty :: (ConfigFlags -> [a]) -> [a]
lastNonEmpty = (SavedConfig -> ConfigFlags) -> (ConfigFlags -> [a]) -> [a]
forall flags a. (SavedConfig -> flags) -> (flags -> [a]) -> [a]
lastNonEmpty' SavedConfig -> ConfigFlags
savedConfigureFlags
          lastNonEmptyNL :: (ConfigFlags -> NubList a) -> NubList a
lastNonEmptyNL = (SavedConfig -> ConfigFlags)
-> (ConfigFlags -> NubList a) -> NubList a
forall flags a.
(SavedConfig -> flags) -> (flags -> NubList a) -> NubList a
lastNonEmptyNL' SavedConfig -> ConfigFlags
savedConfigureFlags
          lastNonMempty :: (ConfigFlags -> FlagAssignment) -> FlagAssignment
lastNonMempty = (SavedConfig -> ConfigFlags)
-> (ConfigFlags -> FlagAssignment) -> FlagAssignment
forall a flags.
(Eq a, Monoid a) =>
(SavedConfig -> flags) -> (flags -> a) -> a
lastNonMempty' SavedConfig -> ConfigFlags
savedConfigureFlags

      combinedSavedConfigureExFlags :: ConfigExFlags
combinedSavedConfigureExFlags =
        ConfigExFlags
          { configCabalVersion :: Flag Version
configCabalVersion = (ConfigExFlags -> Flag Version) -> Flag Version
forall {a}. (ConfigExFlags -> Flag a) -> Flag a
combine ConfigExFlags -> Flag Version
configCabalVersion
          , configAppend :: Flag Bool
configAppend = (ConfigExFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigExFlags -> Flag a) -> Flag a
combine ConfigExFlags -> Flag Bool
configAppend
          , configBackup :: Flag Bool
configBackup = (ConfigExFlags -> Flag Bool) -> Flag Bool
forall {a}. (ConfigExFlags -> Flag a) -> Flag a
combine ConfigExFlags -> Flag Bool
configBackup
          , -- TODO: NubListify
            configExConstraints :: [(UserConstraint, ConstraintSource)]
configExConstraints = (ConfigExFlags -> [(UserConstraint, ConstraintSource)])
-> [(UserConstraint, ConstraintSource)]
forall {a}. (ConfigExFlags -> [a]) -> [a]
lastNonEmpty ConfigExFlags -> [(UserConstraint, ConstraintSource)]
configExConstraints
          , -- TODO: NubListify
            configPreferences :: [PackageVersionConstraint]
configPreferences = (ConfigExFlags -> [PackageVersionConstraint])
-> [PackageVersionConstraint]
forall {a}. (ConfigExFlags -> [a]) -> [a]
lastNonEmpty ConfigExFlags -> [PackageVersionConstraint]
configPreferences
          , configSolver :: Flag PreSolver
configSolver = (ConfigExFlags -> Flag PreSolver) -> Flag PreSolver
forall {a}. (ConfigExFlags -> Flag a) -> Flag a
combine ConfigExFlags -> Flag PreSolver
configSolver
          , configAllowNewer :: Maybe AllowNewer
configAllowNewer =
              (SavedConfig -> ConfigExFlags)
-> (ConfigExFlags -> Maybe AllowNewer) -> Maybe AllowNewer
forall mon flags.
Monoid mon =>
(SavedConfig -> flags) -> (flags -> mon) -> mon
combineMonoid SavedConfig -> ConfigExFlags
savedConfigureExFlags ConfigExFlags -> Maybe AllowNewer
configAllowNewer
          , configAllowOlder :: Maybe AllowOlder
configAllowOlder =
              (SavedConfig -> ConfigExFlags)
-> (ConfigExFlags -> Maybe AllowOlder) -> Maybe AllowOlder
forall mon flags.
Monoid mon =>
(SavedConfig -> flags) -> (flags -> mon) -> mon
combineMonoid SavedConfig -> ConfigExFlags
savedConfigureExFlags ConfigExFlags -> Maybe AllowOlder
configAllowOlder
          , configWriteGhcEnvironmentFilesPolicy :: Flag WriteGhcEnvironmentFilesPolicy
configWriteGhcEnvironmentFilesPolicy =
              (ConfigExFlags -> Flag WriteGhcEnvironmentFilesPolicy)
-> Flag WriteGhcEnvironmentFilesPolicy
forall {a}. (ConfigExFlags -> Flag a) -> Flag a
combine ConfigExFlags -> Flag WriteGhcEnvironmentFilesPolicy
configWriteGhcEnvironmentFilesPolicy
          }
        where
          combine :: (ConfigExFlags -> Flag a) -> Flag a
combine = (SavedConfig -> ConfigExFlags)
-> (ConfigExFlags -> Flag a) -> Flag a
forall flags a.
(SavedConfig -> flags) -> (flags -> Flag a) -> Flag a
combine' SavedConfig -> ConfigExFlags
savedConfigureExFlags
          lastNonEmpty :: (ConfigExFlags -> [a]) -> [a]
lastNonEmpty = (SavedConfig -> ConfigExFlags) -> (ConfigExFlags -> [a]) -> [a]
forall flags a. (SavedConfig -> flags) -> (flags -> [a]) -> [a]
lastNonEmpty' SavedConfig -> ConfigExFlags
savedConfigureExFlags

      -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.
      combinedSavedUserInstallDirs :: InstallDirs (Flag PathTemplate)
combinedSavedUserInstallDirs =
        SavedConfig -> InstallDirs (Flag PathTemplate)
savedUserInstallDirs SavedConfig
a
          InstallDirs (Flag PathTemplate)
-> InstallDirs (Flag PathTemplate)
-> InstallDirs (Flag PathTemplate)
forall a. Monoid a => a -> a -> a
`mappend` SavedConfig -> InstallDirs (Flag PathTemplate)
savedUserInstallDirs SavedConfig
b

      -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.
      combinedSavedGlobalInstallDirs :: InstallDirs (Flag PathTemplate)
combinedSavedGlobalInstallDirs =
        SavedConfig -> InstallDirs (Flag PathTemplate)
savedGlobalInstallDirs SavedConfig
a
          InstallDirs (Flag PathTemplate)
-> InstallDirs (Flag PathTemplate)
-> InstallDirs (Flag PathTemplate)
forall a. Monoid a => a -> a -> a
`mappend` SavedConfig -> InstallDirs (Flag PathTemplate)
savedGlobalInstallDirs SavedConfig
b

      combinedSavedUploadFlags :: UploadFlags
combinedSavedUploadFlags =
        UploadFlags
          { uploadCandidate :: Flag IsCandidate
uploadCandidate = (UploadFlags -> Flag IsCandidate) -> Flag IsCandidate
forall {a}. (UploadFlags -> Flag a) -> Flag a
combine UploadFlags -> Flag IsCandidate
uploadCandidate
          , uploadDoc :: Flag Bool
uploadDoc = (UploadFlags -> Flag Bool) -> Flag Bool
forall {a}. (UploadFlags -> Flag a) -> Flag a
combine UploadFlags -> Flag Bool
uploadDoc
          , uploadToken :: Flag Token
uploadToken = (UploadFlags -> Flag Token) -> Flag Token
forall {a}. (UploadFlags -> Flag a) -> Flag a
combine UploadFlags -> Flag Token
uploadToken
          , uploadUsername :: Flag Username
uploadUsername = (UploadFlags -> Flag Username) -> Flag Username
forall {a}. (UploadFlags -> Flag a) -> Flag a
combine UploadFlags -> Flag Username
uploadUsername
          , uploadPassword :: Flag Password
uploadPassword = (UploadFlags -> Flag Password) -> Flag Password
forall {a}. (UploadFlags -> Flag a) -> Flag a
combine UploadFlags -> Flag Password
uploadPassword
          , uploadPasswordCmd :: Flag [String]
uploadPasswordCmd = (UploadFlags -> Flag [String]) -> Flag [String]
forall {a}. (UploadFlags -> Flag a) -> Flag a
combine UploadFlags -> Flag [String]
uploadPasswordCmd
          , uploadVerbosity :: Flag Verbosity
uploadVerbosity = (UploadFlags -> Flag Verbosity) -> Flag Verbosity
forall {a}. (UploadFlags -> Flag a) -> Flag a
combine UploadFlags -> Flag Verbosity
uploadVerbosity
          }
        where
          combine :: (UploadFlags -> Flag a) -> Flag a
combine = (SavedConfig -> UploadFlags) -> (UploadFlags -> Flag a) -> Flag a
forall flags a.
(SavedConfig -> flags) -> (flags -> Flag a) -> Flag a
combine' SavedConfig -> UploadFlags
savedUploadFlags

      combinedSavedReportFlags :: ReportFlags
combinedSavedReportFlags =
        ReportFlags
          { reportToken :: Flag Token
reportToken = (ReportFlags -> Flag Token) -> Flag Token
forall {a}. (ReportFlags -> Flag a) -> Flag a
combine ReportFlags -> Flag Token
reportToken
          , reportUsername :: Flag Username
reportUsername = (ReportFlags -> Flag Username) -> Flag Username
forall {a}. (ReportFlags -> Flag a) -> Flag a
combine ReportFlags -> Flag Username
reportUsername
          , reportPassword :: Flag Password
reportPassword = (ReportFlags -> Flag Password) -> Flag Password
forall {a}. (ReportFlags -> Flag a) -> Flag a
combine ReportFlags -> Flag Password
reportPassword
          , reportVerbosity :: Flag Verbosity
reportVerbosity = (ReportFlags -> Flag Verbosity) -> Flag Verbosity
forall {a}. (ReportFlags -> Flag a) -> Flag a
combine ReportFlags -> Flag Verbosity
reportVerbosity
          }
        where
          combine :: (ReportFlags -> Flag a) -> Flag a
combine = (SavedConfig -> ReportFlags) -> (ReportFlags -> Flag a) -> Flag a
forall flags a.
(SavedConfig -> flags) -> (flags -> Flag a) -> Flag a
combine' SavedConfig -> ReportFlags
savedReportFlags

      combinedSavedHaddockFlags :: HaddockFlags
combinedSavedHaddockFlags =
        HaddockFlags
          { haddockCommonFlags :: CommonSetupFlags
haddockCommonFlags = (SavedConfig -> CommonSetupFlags) -> CommonSetupFlags
combinedSavedCommonFlags (HaddockFlags -> CommonSetupFlags
haddockCommonFlags (HaddockFlags -> CommonSetupFlags)
-> (SavedConfig -> HaddockFlags) -> SavedConfig -> CommonSetupFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> HaddockFlags
savedHaddockFlags)
          , -- TODO: NubListify
            haddockProgramPaths :: [(String, String)]
haddockProgramPaths = (HaddockFlags -> [(String, String)]) -> [(String, String)]
forall {a}. (HaddockFlags -> [a]) -> [a]
lastNonEmpty HaddockFlags -> [(String, String)]
haddockProgramPaths
          , -- TODO: NubListify
            haddockProgramArgs :: [(String, [String])]
haddockProgramArgs = (HaddockFlags -> [(String, [String])]) -> [(String, [String])]
forall {a}. (HaddockFlags -> [a]) -> [a]
lastNonEmpty HaddockFlags -> [(String, [String])]
haddockProgramArgs
          , haddockHoogle :: Flag Bool
haddockHoogle = (HaddockFlags -> Flag Bool) -> Flag Bool
forall {a}. (HaddockFlags -> Flag a) -> Flag a
combine HaddockFlags -> Flag Bool
haddockHoogle
          , haddockHtml :: Flag Bool
haddockHtml = (HaddockFlags -> Flag Bool) -> Flag Bool
forall {a}. (HaddockFlags -> Flag a) -> Flag a
combine HaddockFlags -> Flag Bool
haddockHtml
          , haddockHtmlLocation :: Flag String
haddockHtmlLocation = (HaddockFlags -> Flag String) -> Flag String
forall {a}. (HaddockFlags -> Flag a) -> Flag a
combine HaddockFlags -> Flag String
haddockHtmlLocation
          , haddockForHackage :: Flag HaddockTarget
haddockForHackage = (HaddockFlags -> Flag HaddockTarget) -> Flag HaddockTarget
forall {a}. (HaddockFlags -> Flag a) -> Flag a
combine HaddockFlags -> Flag HaddockTarget
haddockForHackage
          , haddockExecutables :: Flag Bool
haddockExecutables = (HaddockFlags -> Flag Bool) -> Flag Bool
forall {a}. (HaddockFlags -> Flag a) -> Flag a
combine HaddockFlags -> Flag Bool
haddockExecutables
          , haddockTestSuites :: Flag Bool
haddockTestSuites = (HaddockFlags -> Flag Bool) -> Flag Bool
forall {a}. (HaddockFlags -> Flag a) -> Flag a
combine HaddockFlags -> Flag Bool
haddockTestSuites
          , haddockBenchmarks :: Flag Bool
haddockBenchmarks = (HaddockFlags -> Flag Bool) -> Flag Bool
forall {a}. (HaddockFlags -> Flag a) -> Flag a
combine HaddockFlags -> Flag Bool
haddockBenchmarks
          , haddockForeignLibs :: Flag Bool
haddockForeignLibs = (HaddockFlags -> Flag Bool) -> Flag Bool
forall {a}. (HaddockFlags -> Flag a) -> Flag a
combine HaddockFlags -> Flag Bool
haddockForeignLibs
          , haddockInternal :: Flag Bool
haddockInternal = (HaddockFlags -> Flag Bool) -> Flag Bool
forall {a}. (HaddockFlags -> Flag a) -> Flag a
combine HaddockFlags -> Flag Bool
haddockInternal
          , haddockCss :: Flag String
haddockCss = (HaddockFlags -> Flag String) -> Flag String
forall {a}. (HaddockFlags -> Flag a) -> Flag a
combine HaddockFlags -> Flag String
haddockCss
          , haddockLinkedSource :: Flag Bool
haddockLinkedSource = (HaddockFlags -> Flag Bool) -> Flag Bool
forall {a}. (HaddockFlags -> Flag a) -> Flag a
combine HaddockFlags -> Flag Bool
haddockLinkedSource
          , haddockQuickJump :: Flag Bool
haddockQuickJump = (HaddockFlags -> Flag Bool) -> Flag Bool
forall {a}. (HaddockFlags -> Flag a) -> Flag a
combine HaddockFlags -> Flag Bool
haddockQuickJump
          , haddockHscolourCss :: Flag String
haddockHscolourCss = (HaddockFlags -> Flag String) -> Flag String
forall {a}. (HaddockFlags -> Flag a) -> Flag a
combine HaddockFlags -> Flag String
haddockHscolourCss
          , haddockContents :: Flag PathTemplate
haddockContents = (HaddockFlags -> Flag PathTemplate) -> Flag PathTemplate
forall {a}. (HaddockFlags -> Flag a) -> Flag a
combine HaddockFlags -> Flag PathTemplate
haddockContents
          , haddockKeepTempFiles :: Flag Bool
haddockKeepTempFiles = (HaddockFlags -> Flag Bool) -> Flag Bool
forall {a}. (HaddockFlags -> Flag a) -> Flag a
combine HaddockFlags -> Flag Bool
haddockKeepTempFiles
          , haddockIndex :: Flag PathTemplate
haddockIndex = (HaddockFlags -> Flag PathTemplate) -> Flag PathTemplate
forall {a}. (HaddockFlags -> Flag a) -> Flag a
combine HaddockFlags -> Flag PathTemplate
haddockIndex
          , haddockBaseUrl :: Flag String
haddockBaseUrl = (HaddockFlags -> Flag String) -> Flag String
forall {a}. (HaddockFlags -> Flag a) -> Flag a
combine HaddockFlags -> Flag String
haddockBaseUrl
          , haddockResourcesDir :: Flag String
haddockResourcesDir = (HaddockFlags -> Flag String) -> Flag String
forall {a}. (HaddockFlags -> Flag a) -> Flag a
combine HaddockFlags -> Flag String
haddockResourcesDir
          , haddockOutputDir :: Flag String
haddockOutputDir = (HaddockFlags -> Flag String) -> Flag String
forall {a}. (HaddockFlags -> Flag a) -> Flag a
combine HaddockFlags -> Flag String
haddockOutputDir
          , haddockUseUnicode :: Flag Bool
haddockUseUnicode = (HaddockFlags -> Flag Bool) -> Flag Bool
forall {a}. (HaddockFlags -> Flag a) -> Flag a
combine HaddockFlags -> Flag Bool
haddockUseUnicode
          }
        where
          combine :: (HaddockFlags -> Flag a) -> Flag a
combine = (SavedConfig -> HaddockFlags) -> (HaddockFlags -> Flag a) -> Flag a
forall flags a.
(SavedConfig -> flags) -> (flags -> Flag a) -> Flag a
combine' SavedConfig -> HaddockFlags
savedHaddockFlags
          lastNonEmpty :: (HaddockFlags -> [a]) -> [a]
lastNonEmpty = (SavedConfig -> HaddockFlags) -> (HaddockFlags -> [a]) -> [a]
forall flags a. (SavedConfig -> flags) -> (flags -> [a]) -> [a]
lastNonEmpty' SavedConfig -> HaddockFlags
savedHaddockFlags

      combinedSavedTestFlags :: TestFlags
combinedSavedTestFlags =
        TestFlags
          { testCommonFlags :: CommonSetupFlags
testCommonFlags = (SavedConfig -> CommonSetupFlags) -> CommonSetupFlags
combinedSavedCommonFlags (TestFlags -> CommonSetupFlags
testCommonFlags (TestFlags -> CommonSetupFlags)
-> (SavedConfig -> TestFlags) -> SavedConfig -> CommonSetupFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> TestFlags
savedTestFlags)
          , testHumanLog :: Flag PathTemplate
testHumanLog = (TestFlags -> Flag PathTemplate) -> Flag PathTemplate
forall {a}. (TestFlags -> Flag a) -> Flag a
combine TestFlags -> Flag PathTemplate
testHumanLog
          , testMachineLog :: Flag PathTemplate
testMachineLog = (TestFlags -> Flag PathTemplate) -> Flag PathTemplate
forall {a}. (TestFlags -> Flag a) -> Flag a
combine TestFlags -> Flag PathTemplate
testMachineLog
          , testShowDetails :: Flag TestShowDetails
testShowDetails = (TestFlags -> Flag TestShowDetails) -> Flag TestShowDetails
forall {a}. (TestFlags -> Flag a) -> Flag a
combine TestFlags -> Flag TestShowDetails
testShowDetails
          , testKeepTix :: Flag Bool
testKeepTix = (TestFlags -> Flag Bool) -> Flag Bool
forall {a}. (TestFlags -> Flag a) -> Flag a
combine TestFlags -> Flag Bool
testKeepTix
          , testWrapper :: Flag String
testWrapper = (TestFlags -> Flag String) -> Flag String
forall {a}. (TestFlags -> Flag a) -> Flag a
combine TestFlags -> Flag String
testWrapper
          , testFailWhenNoTestSuites :: Flag Bool
testFailWhenNoTestSuites = (TestFlags -> Flag Bool) -> Flag Bool
forall {a}. (TestFlags -> Flag a) -> Flag a
combine TestFlags -> Flag Bool
testFailWhenNoTestSuites
          , testOptions :: [PathTemplate]
testOptions = (TestFlags -> [PathTemplate]) -> [PathTemplate]
forall {a}. (TestFlags -> [a]) -> [a]
lastNonEmpty TestFlags -> [PathTemplate]
testOptions
          }
        where
          combine :: (TestFlags -> Flag a) -> Flag a
combine = (SavedConfig -> TestFlags) -> (TestFlags -> Flag a) -> Flag a
forall flags a.
(SavedConfig -> flags) -> (flags -> Flag a) -> Flag a
combine' SavedConfig -> TestFlags
savedTestFlags
          lastNonEmpty :: (TestFlags -> [a]) -> [a]
lastNonEmpty = (SavedConfig -> TestFlags) -> (TestFlags -> [a]) -> [a]
forall flags a. (SavedConfig -> flags) -> (flags -> [a]) -> [a]
lastNonEmpty' SavedConfig -> TestFlags
savedTestFlags

      combinedSavedBenchmarkFlags :: BenchmarkFlags
combinedSavedBenchmarkFlags =
        BenchmarkFlags
          { benchmarkCommonFlags :: CommonSetupFlags
benchmarkCommonFlags = (SavedConfig -> CommonSetupFlags) -> CommonSetupFlags
combinedSavedCommonFlags (BenchmarkFlags -> CommonSetupFlags
benchmarkCommonFlags (BenchmarkFlags -> CommonSetupFlags)
-> (SavedConfig -> BenchmarkFlags)
-> SavedConfig
-> CommonSetupFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> BenchmarkFlags
savedBenchmarkFlags)
          , benchmarkOptions :: [PathTemplate]
benchmarkOptions = (BenchmarkFlags -> [PathTemplate]) -> [PathTemplate]
forall {a}. (BenchmarkFlags -> [a]) -> [a]
lastNonEmpty BenchmarkFlags -> [PathTemplate]
benchmarkOptions
          }
        where
          lastNonEmpty :: (BenchmarkFlags -> [a]) -> [a]
lastNonEmpty = (SavedConfig -> BenchmarkFlags) -> (BenchmarkFlags -> [a]) -> [a]
forall flags a. (SavedConfig -> flags) -> (flags -> [a]) -> [a]
lastNonEmpty' SavedConfig -> BenchmarkFlags
savedBenchmarkFlags

      combinedSavedReplMulti :: Flag Bool
combinedSavedReplMulti = (SavedConfig -> Flag Bool) -> (Flag Bool -> Flag Bool) -> Flag Bool
forall flags a.
(SavedConfig -> flags) -> (flags -> Flag a) -> Flag a
combine' SavedConfig -> Flag Bool
savedReplMulti Flag Bool -> Flag Bool
forall a. a -> a
id

      combinedSavedProjectFlags :: ProjectFlags
combinedSavedProjectFlags =
        ProjectFlags
          { flagProjectDir :: Flag String
flagProjectDir = (ProjectFlags -> Flag String) -> Flag String
forall {a}. (ProjectFlags -> Flag a) -> Flag a
combine ProjectFlags -> Flag String
flagProjectDir
          , flagProjectFile :: Flag String
flagProjectFile = (ProjectFlags -> Flag String) -> Flag String
forall {a}. (ProjectFlags -> Flag a) -> Flag a
combine ProjectFlags -> Flag String
flagProjectFile
          , flagIgnoreProject :: Flag Bool
flagIgnoreProject = (ProjectFlags -> Flag Bool) -> Flag Bool
forall {a}. (ProjectFlags -> Flag a) -> Flag a
combine ProjectFlags -> Flag Bool
flagIgnoreProject
          }
        where
          combine :: (ProjectFlags -> Flag a) -> Flag a
combine = (SavedConfig -> ProjectFlags) -> (ProjectFlags -> Flag a) -> Flag a
forall flags a.
(SavedConfig -> flags) -> (flags -> Flag a) -> Flag a
combine' SavedConfig -> ProjectFlags
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 :: IO SavedConfig
baseSavedConfig = do
  String
userPrefix <- IO String
defaultInstallPrefix
  String
cacheDir <- IO String
defaultCacheDir
  String
logsDir <- IO String
defaultLogsDir
  SavedConfig -> IO SavedConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    SavedConfig
forall a. Monoid a => a
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 :: IO SavedConfig
initialSavedConfig = do
  String
cacheDir <- IO String
defaultCacheDir
  String
logsDir <- IO String
defaultLogsDir
  String
installPath <- IO String
defaultInstallPath
  SavedConfig -> IO SavedConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    SavedConfig
forall a. Monoid a => a
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 -> IO ()
warnOnTwoConfigs Verbosity
verbosity = do
  String
defaultDir <- String -> IO String
getAppUserDataDirectory String
"cabal"
  String
xdgCfgDir <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgConfig String
"cabal"
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
defaultDir String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
xdgCfgDir) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Bool
dotCabalExists <- String -> IO Bool
doesDirectoryExist String
defaultDir
    let xdgCfg :: String
xdgCfg = String
xdgCfgDir String -> String -> String
</> String
"config"
    Bool
xdgCfgExists <- String -> IO Bool
doesFileExist String
xdgCfg
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
dotCabalExists Bool -> Bool -> Bool
&& Bool
xdgCfgExists) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"Both "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
defaultDir
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" and "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
xdgCfg
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" exist - ignoring the former.\n"
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"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 :: IO (Maybe String)
maybeGetCabalDir = do
  Maybe String
mDir <- String -> IO (Maybe String)
lookupEnv String
"CABAL_DIR"
  case Maybe String
mDir of
    Just String
dir -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
dir
    Maybe String
Nothing -> do
      String
defaultDir <- String -> IO String
getAppUserDataDirectory String
"cabal"
      Bool
dotCabalExists <- String -> IO Bool
doesDirectoryExist String
defaultDir
      String
xdgCfg <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgConfig (String
"cabal" String -> String -> String
</> String
"config")
      Bool
xdgCfgExists <- String -> IO Bool
doesFileExist String
xdgCfg
      if Bool
dotCabalExists Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
xdgCfgExists
        then Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
defaultDir
        else Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
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 :: XdgDirectory -> String -> IO String
getDefaultDir XdgDirectory
xdg String
subdir = do
  Maybe String
mDir <- IO (Maybe String)
maybeGetCabalDir
  case Maybe String
mDir of
    Just String
dir -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
dir String -> String -> String
</> String
subdir
    Maybe String
Nothing -> XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
xdg (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"cabal" String -> String -> String
</> String
subdir

-- | The default prefix used for installation.
defaultInstallPrefix :: IO FilePath
defaultInstallPrefix :: IO String
defaultInstallPrefix = do
  Maybe String
mDir <- IO (Maybe String)
maybeGetCabalDir
  case Maybe String
mDir of
    Just String
dir ->
      String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
dir
    Maybe String
Nothing -> do
      String
dir <- IO String
getHomeDirectory
      String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
dir String -> String -> String
</> String
".local"

defaultConfigFile :: IO FilePath
defaultConfigFile :: IO String
defaultConfigFile =
  XdgDirectory -> String -> IO String
getDefaultDir XdgDirectory
XdgConfig String
"config"

defaultCacheHome :: IO FilePath
defaultCacheHome :: IO String
defaultCacheHome =
  XdgDirectory -> String -> IO String
getDefaultDir XdgDirectory
XdgCache String
""

defaultCacheDir :: IO FilePath
defaultCacheDir :: IO String
defaultCacheDir =
  XdgDirectory -> String -> IO String
getDefaultDir XdgDirectory
XdgCache String
"packages"

defaultScriptBuildsDir :: IO FilePath
defaultScriptBuildsDir :: IO String
defaultScriptBuildsDir =
  XdgDirectory -> String -> IO String
getDefaultDir XdgDirectory
XdgCache String
"script-builds"

defaultStoreDir :: IO FilePath
defaultStoreDir :: IO String
defaultStoreDir =
  XdgDirectory -> String -> IO String
getDefaultDir XdgDirectory
XdgState String
"store"

defaultLogsDir :: IO FilePath
defaultLogsDir :: IO String
defaultLogsDir =
  XdgDirectory -> String -> IO String
getDefaultDir XdgDirectory
XdgCache String
"logs"

defaultReportsDir :: IO FilePath
defaultReportsDir :: IO String
defaultReportsDir =
  XdgDirectory -> String -> IO String
getDefaultDir XdgDirectory
XdgCache String
"reports"

defaultInstallPath :: IO FilePath
defaultInstallPath :: IO String
defaultInstallPath = do
  Maybe String
mDir <- IO (Maybe String)
maybeGetCabalDir
  case Maybe String
mDir of
    Just String
dir ->
      String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
dir String -> String -> String
</> String
"bin"
    Maybe String
Nothing -> do
      String
dir <- IO String
getHomeDirectory
      String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
dir String -> String -> String
</> String
".local" String -> String -> String
</> String
"bin"

defaultCompiler :: CompilerFlavor
defaultCompiler :: CompilerFlavor
defaultCompiler = CompilerFlavor -> Maybe CompilerFlavor -> CompilerFlavor
forall a. a -> Maybe a -> a
fromMaybe CompilerFlavor
GHC Maybe CompilerFlavor
defaultCompilerFlavor

defaultUserInstall :: Bool
defaultUserInstall :: Bool
defaultUserInstall = Bool
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
defaultRemoteRepo = RepoName
-> URI -> Maybe Bool -> [String] -> Int -> Bool -> RemoteRepo
RemoteRepo RepoName
name URI
uri Maybe Bool
forall a. Maybe a
Nothing [] Int
0 Bool
False
  where
    str :: String
str = String
"hackage.haskell.org"
    name :: RepoName
name = String -> RepoName
RepoName String
str
    uri :: URI
uri = String -> Maybe URIAuth -> String -> String -> String -> URI
URI String
"http:" (URIAuth -> Maybe URIAuth
forall a. a -> Maybe a
Just (String -> String -> String -> URIAuth
URIAuth String
"" String
str String
"")) String
"/" String
"" String
""

-- 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 :: RemoteRepo -> RemoteRepo
addInfoForKnownRepos RemoteRepo
repo
  | RemoteRepo -> RepoName
remoteRepoName RemoteRepo
repo RepoName -> RepoName -> Bool
forall a. Eq a => a -> a -> Bool
== RemoteRepo -> RepoName
remoteRepoName RemoteRepo
defaultRemoteRepo =
      RemoteRepo -> RemoteRepo
useSecure (RemoteRepo -> RemoteRepo)
-> (RemoteRepo -> RemoteRepo) -> RemoteRepo -> RemoteRepo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteRepo -> RemoteRepo
tryHttps (RemoteRepo -> RemoteRepo)
-> (RemoteRepo -> RemoteRepo) -> RemoteRepo -> RemoteRepo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteRepo -> RemoteRepo
fixOldURI (RemoteRepo -> RemoteRepo) -> RemoteRepo -> RemoteRepo
forall a b. (a -> b) -> a -> b
$ RemoteRepo
repo
  where
    fixOldURI :: RemoteRepo -> RemoteRepo
fixOldURI RemoteRepo
r
      | URI -> Bool
isOldHackageURI (RemoteRepo -> URI
remoteRepoURI RemoteRepo
r) =
          RemoteRepo
r{remoteRepoURI = remoteRepoURI defaultRemoteRepo}
      | Bool
otherwise = RemoteRepo
r

    tryHttps :: RemoteRepo -> RemoteRepo
tryHttps RemoteRepo
r = RemoteRepo
r{remoteRepoShouldTryHttps = True}

    useSecure :: RemoteRepo -> RemoteRepo
useSecure
      r :: RemoteRepo
r@RemoteRepo
        { remoteRepoSecure :: RemoteRepo -> Maybe Bool
remoteRepoSecure = Maybe Bool
secure
        , remoteRepoRootKeys :: RemoteRepo -> [String]
remoteRepoRootKeys = []
        , remoteRepoKeyThreshold :: RemoteRepo -> Int
remoteRepoKeyThreshold = Int
0
        }
        | Maybe Bool
secure Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False =
            RemoteRepo
r
              { -- Use hackage-security by default unless you opt-out with
                -- secure: False
                remoteRepoSecure = Just True
              , remoteRepoRootKeys = defaultHackageRemoteRepoKeys
              , remoteRepoKeyThreshold = defaultHackageRemoteRepoKeyThreshold
              }
    useSecure RemoteRepo
r = RemoteRepo
r
addInfoForKnownRepos RemoteRepo
other = RemoteRepo
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 :: [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=)
    String
"fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0"
  , -- Gershom Bazerman (bYoUXXQ9TtX10UriaMiQtTccuXPGnmldP68djzZ7cLo=)
    String
"1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42"
  , -- John Wiegley (zazm5w480r+zPO6Z0+8fjGuxZtb9pAuoVmQ+VkuCvgU=)
    String
"0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d"
  , -- Norman Ramsey (ZI8di3a9Un0s2RBrt5GwVRvfOXVuywADfXGPZfkiDb0=)
    String
"51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921"
  , -- Mathieu Boespflug (ydN1nGGQ79K1Q0nN+ul+Ln8MxikTB95w0YdGd3v3kmg=)
    String
"be75553f3c7ba1dbe298da81f1d1b05c9d39dd8ed2616c9bddf1525ca8c03e48"
  , -- Joachim Breitner (5iUgwqZCWrCJktqMx0bBMIuoIyT4A1RYGozzchRN9rA=)
    String
"d26e46f3b631aae1433b89379a6c68bd417eb5d1c408f0643dcc07757fece522"
  ]

-- | The required threshold of root key signatures for hackage.haskell.org
defaultHackageRemoteRepoKeyThreshold :: Int
defaultHackageRemoteRepoKeyThreshold :: Int
defaultHackageRemoteRepoKeyThreshold = Int
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 -> Flag String -> IO SavedConfig
loadConfig Verbosity
verbosity Flag String
configFileFlag = do
  Verbosity -> IO ()
warnOnTwoConfigs Verbosity
verbosity
  SavedConfig
config <- Verbosity -> Flag String -> IO SavedConfig
loadRawConfig Verbosity
verbosity Flag String
configFileFlag
  SavedConfig -> IO SavedConfig
extendToEffectiveConfig SavedConfig
config

extendToEffectiveConfig :: SavedConfig -> IO SavedConfig
extendToEffectiveConfig :: SavedConfig -> IO SavedConfig
extendToEffectiveConfig SavedConfig
config = do
  SavedConfig
base <- IO SavedConfig
baseSavedConfig
  let effective0 :: SavedConfig
effective0 = SavedConfig
base SavedConfig -> SavedConfig -> SavedConfig
forall a. Monoid a => a -> a -> a
`mappend` SavedConfig
config
      globalFlags0 :: GlobalFlags
globalFlags0 = SavedConfig -> GlobalFlags
savedGlobalFlags SavedConfig
effective0
      effective :: SavedConfig
effective =
        SavedConfig
effective0
          { savedGlobalFlags =
              globalFlags0
                { globalRemoteRepos =
                    overNubList
                      (map addInfoForKnownRepos)
                      (globalRemoteRepos globalFlags0)
                }
          }
  SavedConfig -> IO SavedConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SavedConfig
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 -> Flag String -> IO SavedConfig
loadRawConfig Verbosity
verbosity Flag String
configFileFlag = do
  (ConfigFileSource
source, String
configFile) <- Flag String -> IO (ConfigFileSource, String)
getConfigFilePathAndSource Flag String
configFileFlag
  Maybe (ParseResult SavedConfig)
minp <- SavedConfig -> String -> IO (Maybe (ParseResult SavedConfig))
readConfigFile SavedConfig
forall a. Monoid a => a
mempty String
configFile
  case Maybe (ParseResult SavedConfig)
minp of
    Maybe (ParseResult SavedConfig)
Nothing -> do
      Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"Config file path source is " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConfigFileSource -> String
sourceMsg ConfigFileSource
source String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
      -- 2021-10-07, issue #7705
      -- Only create default config file if name was not given explicitly
      -- via option --config-file or environment variable.
      case ConfigFileSource
source of
        ConfigFileSource
Default -> do
          Verbosity -> String -> IO ()
notice Verbosity
verbosity String
msgNotFound
          Verbosity -> [String] -> String -> IO SavedConfig
createDefaultConfigFile Verbosity
verbosity [] String
configFile
        ConfigFileSource
CommandlineOption -> IO SavedConfig
forall {a}. IO a
failNoConfigFile
        ConfigFileSource
EnvironmentVariable -> IO SavedConfig
forall {a}. IO a
failNoConfigFile
      where
        msgNotFound :: String
msgNotFound
          | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
configFile = String
"Config file name is empty"
          | Bool
otherwise = [String] -> String
unwords [String
"Config file not found:", String
configFile]
        failNoConfigFile :: IO a
failNoConfigFile =
          Verbosity -> CabalInstallException -> IO a
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO a) -> CabalInstallException -> IO a
forall a b. (a -> b) -> a -> b
$ String -> CabalInstallException
FailNoConfigFile String
msgNotFound
    Just (ParseOk [PWarning]
ws SavedConfig
conf) -> do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PWarning] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PWarning]
ws) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          [String] -> String
unlines ((PWarning -> String) -> [PWarning] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PWarning -> String
showPWarning String
configFile) [PWarning]
ws)
      SavedConfig -> IO SavedConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SavedConfig
conf
    Just (ParseFailed PError
err) -> do
      let (Maybe Int
line, String
msg) = PError -> (Maybe Int, String)
locatedErrorMsg PError
err
          errLineNo :: String
errLineNo = String -> (Int -> String) -> Maybe Int -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Int
n -> Char
':' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
n) Maybe Int
line
      Verbosity -> CabalInstallException -> IO SavedConfig
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO SavedConfig)
-> CabalInstallException -> IO SavedConfig
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> CabalInstallException
ParseFailedErr String
configFile String
msg String
errLineNo
  where
    sourceMsg :: ConfigFileSource -> String
sourceMsg ConfigFileSource
CommandlineOption = String
"commandline option"
    sourceMsg ConfigFileSource
EnvironmentVariable = String
"environment variable CABAL_CONFIG"
    sourceMsg ConfigFileSource
Default = String
"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 :: Flag String -> IO String
getConfigFilePath = ((ConfigFileSource, String) -> String)
-> IO (ConfigFileSource, String) -> IO String
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ConfigFileSource, String) -> String
forall a b. (a, b) -> b
snd (IO (ConfigFileSource, String) -> IO String)
-> (Flag String -> IO (ConfigFileSource, String))
-> Flag String
-> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag String -> IO (ConfigFileSource, String)
getConfigFilePathAndSource

getConfigFilePathAndSource :: Flag FilePath -> IO (ConfigFileSource, FilePath)
getConfigFilePathAndSource :: Flag String -> IO (ConfigFileSource, String)
getConfigFilePathAndSource Flag String
configFileFlag =
  [(ConfigFileSource, IO (Maybe String))]
-> IO (ConfigFileSource, String)
forall {m :: * -> *} {a} {a}.
Monad m =>
[(a, m (Maybe a))] -> m (a, a)
getSource [(ConfigFileSource, IO (Maybe String))]
sources
  where
    sources :: [(ConfigFileSource, IO (Maybe String))]
sources =
      [ (ConfigFileSource
CommandlineOption, Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> (Flag String -> Maybe String)
-> Flag String
-> IO (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe (Flag String -> IO (Maybe String))
-> Flag String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ Flag String
configFileFlag)
      , (ConfigFileSource
EnvironmentVariable, String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"CABAL_CONFIG" ([(String, String)] -> Maybe String)
-> IO [(String, String)] -> IO (Maybe String)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` IO [(String, String)]
getEnvironment)
      , (ConfigFileSource
Default, String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> IO String -> IO (Maybe String)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` IO String
defaultConfigFile)
      ]

    getSource :: [(a, m (Maybe a))] -> m (a, a)
getSource [] = String -> m (a, a)
forall a. HasCallStack => String -> a
error String
"no config file path candidate found."
    getSource ((a
source, m (Maybe a)
action) : [(a, m (Maybe a))]
xs) =
      m (Maybe a)
action m (Maybe a) -> (Maybe a -> m (a, a)) -> m (a, a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (a, a) -> (a -> m (a, a)) -> Maybe a -> m (a, a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([(a, m (Maybe a))] -> m (a, a)
getSource [(a, m (Maybe a))]
xs) ((a, a) -> m (a, a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, a) -> m (a, a)) -> (a -> (a, a)) -> a -> m (a, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) a
source)

readConfigFile
  :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig))
readConfigFile :: SavedConfig -> String -> IO (Maybe (ParseResult SavedConfig))
readConfigFile SavedConfig
initial String
file =
  IO (Maybe (ParseResult SavedConfig))
-> IO (Maybe (ParseResult SavedConfig))
forall {a}. IO (Maybe a) -> IO (Maybe a)
handleNotExists (IO (Maybe (ParseResult SavedConfig))
 -> IO (Maybe (ParseResult SavedConfig)))
-> IO (Maybe (ParseResult SavedConfig))
-> IO (Maybe (ParseResult SavedConfig))
forall a b. (a -> b) -> a -> b
$
    (ByteString -> Maybe (ParseResult SavedConfig))
-> IO ByteString -> IO (Maybe (ParseResult SavedConfig))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      (ParseResult SavedConfig -> Maybe (ParseResult SavedConfig)
forall a. a -> Maybe a
Just (ParseResult SavedConfig -> Maybe (ParseResult SavedConfig))
-> (ByteString -> ParseResult SavedConfig)
-> ByteString
-> Maybe (ParseResult SavedConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstraintSource
-> SavedConfig -> ByteString -> ParseResult SavedConfig
parseConfig (String -> ConstraintSource
ConstraintSourceMainConfig String
file) SavedConfig
initial)
      (String -> IO ByteString
BS.readFile String
file)
  where
    handleNotExists :: IO (Maybe a) -> IO (Maybe a)
handleNotExists IO (Maybe a)
action = IO (Maybe a) -> (IOException -> IO (Maybe a)) -> IO (Maybe a)
forall a. IO a -> (IOException -> IO a) -> IO a
catchIO IO (Maybe a)
action ((IOException -> IO (Maybe a)) -> IO (Maybe a))
-> (IOException -> IO (Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \IOException
ioe ->
      if IOException -> Bool
isDoesNotExistError IOException
ioe
        then Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
        else IOException -> IO (Maybe a)
forall a. IOException -> IO a
ioError IOException
ioe

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

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

-- | 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 :: IO SavedConfig
commentSavedConfig = do
  InstallDirTemplates
userInstallDirs <- CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates
defaultInstallDirs CompilerFlavor
defaultCompiler Bool
True Bool
True
  InstallDirTemplates
globalInstallDirs <- CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates
defaultInstallDirs CompilerFlavor
defaultCompiler Bool
False Bool
True
  let conf0 :: SavedConfig
conf0 =
        SavedConfig
forall a. Monoid a => a
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
          }
  SavedConfig
conf1 <- SavedConfig -> IO SavedConfig
extendToEffectiveConfig SavedConfig
conf0
  let globalFlagsConf1 :: GlobalFlags
globalFlagsConf1 = SavedConfig -> GlobalFlags
savedGlobalFlags SavedConfig
conf1
      conf2 :: SavedConfig
conf2 =
        SavedConfig
conf1
          { savedGlobalFlags =
              globalFlagsConf1
                { globalRemoteRepos =
                    overNubList
                      (map removeRootKeys)
                      (globalRemoteRepos globalFlagsConf1)
                }
          }
  SavedConfig -> IO SavedConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SavedConfig
conf2
  where
    -- Most people don't want to see default root keys, so don't print them.
    removeRootKeys :: RemoteRepo -> RemoteRepo
    removeRootKeys :: RemoteRepo -> RemoteRepo
removeRootKeys RemoteRepo
r = RemoteRepo
r{remoteRepoRootKeys = []}

-- | All config file fields.
configFieldDescriptions :: ConstraintSource -> [FieldDescr SavedConfig]
configFieldDescriptions :: ConstraintSource -> [FieldDescr SavedConfig]
configFieldDescriptions ConstraintSource
src =
  (FieldDescr GlobalFlags -> FieldDescr SavedConfig)
-> [OptionField GlobalFlags]
-> [String]
-> [FieldDescr GlobalFlags]
-> [FieldDescr SavedConfig]
forall {t :: * -> *} {t :: * -> *} {a} {a}.
(Foldable t, Foldable t) =>
(FieldDescr a -> a)
-> [OptionField a] -> t String -> t (FieldDescr a) -> [a]
toSavedConfig
    FieldDescr GlobalFlags -> FieldDescr SavedConfig
liftGlobalFlag
    (CommandUI GlobalFlags
-> ShowOrParseArgs -> [OptionField GlobalFlags]
forall flags.
CommandUI flags -> ShowOrParseArgs -> [OptionField flags]
commandOptions ([Command Any] -> CommandUI GlobalFlags
forall action. [Command action] -> CommandUI GlobalFlags
globalCommand []) ShowOrParseArgs
ParseArgs)
    [String
"version", String
"numeric-version", String
"config-file"]
    []
    [FieldDescr SavedConfig]
-> [FieldDescr SavedConfig] -> [FieldDescr SavedConfig]
forall a. [a] -> [a] -> [a]
++ (FieldDescr ConfigFlags -> FieldDescr SavedConfig)
-> [OptionField ConfigFlags]
-> [String]
-> [FieldDescr ConfigFlags]
-> [FieldDescr SavedConfig]
forall {t :: * -> *} {t :: * -> *} {a} {a}.
(Foldable t, Foldable t) =>
(FieldDescr a -> a)
-> [OptionField a] -> t String -> t (FieldDescr a) -> [a]
toSavedConfig
      FieldDescr ConfigFlags -> FieldDescr SavedConfig
liftConfigFlag
      (ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions ShowOrParseArgs
ParseArgs)
      ( [String
"builddir", String
"constraint", String
"dependency", String
"promised-dependency", String
"ipid"]
          [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (FieldDescr (InstallDirs (Flag PathTemplate)) -> String)
-> [FieldDescr (InstallDirs (Flag PathTemplate))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map FieldDescr (InstallDirs (Flag PathTemplate)) -> String
forall a. FieldDescr a -> String
fieldName [FieldDescr (InstallDirs (Flag PathTemplate))]
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.
      [ String
-> (Flag CompilerFlavor -> Doc)
-> ParsecParser (Flag CompilerFlavor)
-> (ConfigFlags -> Flag CompilerFlavor)
-> (Flag CompilerFlavor -> ConfigFlags -> ConfigFlags)
-> FieldDescr ConfigFlags
forall a b.
String
-> (a -> Doc)
-> ParsecParser a
-> (b -> a)
-> (a -> b -> b)
-> FieldDescr b
simpleFieldParsec
          String
"compiler"
          (Doc -> Flag Doc -> Doc
forall a. a -> Flag a -> a
fromFlagOrDefault Doc
Disp.empty (Flag Doc -> Doc)
-> (Flag CompilerFlavor -> Flag Doc) -> Flag CompilerFlavor -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CompilerFlavor -> Doc) -> Flag CompilerFlavor -> Flag Doc
forall a b. (a -> b) -> Flag a -> Flag b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CompilerFlavor -> Doc
forall a. Pretty a => a -> Doc
pretty)
          (CompilerFlavor -> Flag CompilerFlavor
forall a. a -> Flag a
Flag (CompilerFlavor -> Flag CompilerFlavor)
-> ParsecParser CompilerFlavor
-> ParsecParser (Flag CompilerFlavor)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecParser CompilerFlavor
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m CompilerFlavor
parsec ParsecParser (Flag CompilerFlavor)
-> ParsecParser (Flag CompilerFlavor)
-> ParsecParser (Flag CompilerFlavor)
forall a. ParsecParser a -> ParsecParser a -> ParsecParser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Flag CompilerFlavor -> ParsecParser (Flag CompilerFlavor)
forall a. a -> ParsecParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Flag CompilerFlavor
forall a. Flag a
NoFlag)
          ConfigFlags -> Flag CompilerFlavor
configHcFlavor
          (\Flag CompilerFlavor
v ConfigFlags
flags -> ConfigFlags
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.
        (ConfigFlags -> Flag OptimisationLevel)
-> (Flag OptimisationLevel -> ConfigFlags -> ConfigFlags)
-> FieldDescr (Flag OptimisationLevel)
-> FieldDescr ConfigFlags
forall b a.
(b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField
          ConfigFlags -> Flag OptimisationLevel
configOptimization
          ( \Flag OptimisationLevel
v ConfigFlags
flags ->
              ConfigFlags
flags{configOptimization = v}
          )
          (FieldDescr (Flag OptimisationLevel) -> FieldDescr ConfigFlags)
-> FieldDescr (Flag OptimisationLevel) -> FieldDescr ConfigFlags
forall a b. (a -> b) -> a -> b
$ let name :: String
name = String
"optimization"
             in String
-> (Flag OptimisationLevel -> Doc)
-> (Int
    -> String
    -> Flag OptimisationLevel
    -> ParseResult (Flag OptimisationLevel))
-> FieldDescr (Flag OptimisationLevel)
forall a.
String
-> (a -> Doc)
-> (Int -> String -> a -> ParseResult a)
-> FieldDescr a
FieldDescr
                  String
name
                  ( \Flag OptimisationLevel
f -> case Flag OptimisationLevel
f of
                      Flag OptimisationLevel
NoOptimisation -> String -> Doc
Disp.text String
"False"
                      Flag OptimisationLevel
NormalOptimisation -> String -> Doc
Disp.text String
"True"
                      Flag OptimisationLevel
MaximumOptimisation -> String -> Doc
Disp.text String
"2"
                      Flag OptimisationLevel
_ -> Doc
Disp.empty
                  )
                  ( \Int
line String
str Flag OptimisationLevel
_ -> case () of
                      ()
_
                        | String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"False" -> [PWarning]
-> Flag OptimisationLevel -> ParseResult (Flag OptimisationLevel)
forall a. [PWarning] -> a -> ParseResult a
ParseOk [] (OptimisationLevel -> Flag OptimisationLevel
forall a. a -> Flag a
Flag OptimisationLevel
NoOptimisation)
                        | String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"True" -> [PWarning]
-> Flag OptimisationLevel -> ParseResult (Flag OptimisationLevel)
forall a. [PWarning] -> a -> ParseResult a
ParseOk [] (OptimisationLevel -> Flag OptimisationLevel
forall a. a -> Flag a
Flag OptimisationLevel
NormalOptimisation)
                        | String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"0" -> [PWarning]
-> Flag OptimisationLevel -> ParseResult (Flag OptimisationLevel)
forall a. [PWarning] -> a -> ParseResult a
ParseOk [] (OptimisationLevel -> Flag OptimisationLevel
forall a. a -> Flag a
Flag OptimisationLevel
NoOptimisation)
                        | String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"1" -> [PWarning]
-> Flag OptimisationLevel -> ParseResult (Flag OptimisationLevel)
forall a. [PWarning] -> a -> ParseResult a
ParseOk [] (OptimisationLevel -> Flag OptimisationLevel
forall a. a -> Flag a
Flag OptimisationLevel
NormalOptimisation)
                        | String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"2" -> [PWarning]
-> Flag OptimisationLevel -> ParseResult (Flag OptimisationLevel)
forall a. [PWarning] -> a -> ParseResult a
ParseOk [] (OptimisationLevel -> Flag OptimisationLevel
forall a. a -> Flag a
Flag OptimisationLevel
MaximumOptimisation)
                        | String
lstr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"false" -> [PWarning]
-> Flag OptimisationLevel -> ParseResult (Flag OptimisationLevel)
forall a. [PWarning] -> a -> ParseResult a
ParseOk [PWarning
caseWarning] (OptimisationLevel -> Flag OptimisationLevel
forall a. a -> Flag a
Flag OptimisationLevel
NoOptimisation)
                        | String
lstr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"true" ->
                            [PWarning]
-> Flag OptimisationLevel -> ParseResult (Flag OptimisationLevel)
forall a. [PWarning] -> a -> ParseResult a
ParseOk
                              [PWarning
caseWarning]
                              (OptimisationLevel -> Flag OptimisationLevel
forall a. a -> Flag a
Flag OptimisationLevel
NormalOptimisation)
                        | Bool
otherwise -> PError -> ParseResult (Flag OptimisationLevel)
forall a. PError -> ParseResult a
ParseFailed (String -> Int -> PError
NoParse String
name Int
line)
                        where
                          lstr :: String
lstr = String -> String
lowercase String
str
                          caseWarning :: PWarning
caseWarning =
                            String -> PWarning
PWarning (String -> PWarning) -> String -> PWarning
forall a b. (a -> b) -> a -> b
$
                              String
"The '"
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' field is case sensitive, use 'True' or 'False'."
                  )
      , (ConfigFlags -> Flag DebugInfoLevel)
-> (Flag DebugInfoLevel -> ConfigFlags -> ConfigFlags)
-> FieldDescr (Flag DebugInfoLevel)
-> FieldDescr ConfigFlags
forall b a.
(b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField ConfigFlags -> Flag DebugInfoLevel
configDebugInfo (\Flag DebugInfoLevel
v ConfigFlags
flags -> ConfigFlags
flags{configDebugInfo = v}) (FieldDescr (Flag DebugInfoLevel) -> FieldDescr ConfigFlags)
-> FieldDescr (Flag DebugInfoLevel) -> FieldDescr ConfigFlags
forall a b. (a -> b) -> a -> b
$
          let name :: String
name = String
"debug-info"
           in String
-> (Flag DebugInfoLevel -> Doc)
-> (Int
    -> String
    -> Flag DebugInfoLevel
    -> ParseResult (Flag DebugInfoLevel))
-> FieldDescr (Flag DebugInfoLevel)
forall a.
String
-> (a -> Doc)
-> (Int -> String -> a -> ParseResult a)
-> FieldDescr a
FieldDescr
                String
name
                ( \Flag DebugInfoLevel
f -> case Flag DebugInfoLevel
f of
                    Flag DebugInfoLevel
NoDebugInfo -> String -> Doc
Disp.text String
"False"
                    Flag DebugInfoLevel
MinimalDebugInfo -> String -> Doc
Disp.text String
"1"
                    Flag DebugInfoLevel
NormalDebugInfo -> String -> Doc
Disp.text String
"True"
                    Flag DebugInfoLevel
MaximalDebugInfo -> String -> Doc
Disp.text String
"3"
                    Flag DebugInfoLevel
_ -> Doc
Disp.empty
                )
                ( \Int
line String
str Flag DebugInfoLevel
_ -> case () of
                    ()
_
                      | String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"False" -> [PWarning]
-> Flag DebugInfoLevel -> ParseResult (Flag DebugInfoLevel)
forall a. [PWarning] -> a -> ParseResult a
ParseOk [] (DebugInfoLevel -> Flag DebugInfoLevel
forall a. a -> Flag a
Flag DebugInfoLevel
NoDebugInfo)
                      | String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"True" -> [PWarning]
-> Flag DebugInfoLevel -> ParseResult (Flag DebugInfoLevel)
forall a. [PWarning] -> a -> ParseResult a
ParseOk [] (DebugInfoLevel -> Flag DebugInfoLevel
forall a. a -> Flag a
Flag DebugInfoLevel
NormalDebugInfo)
                      | String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"0" -> [PWarning]
-> Flag DebugInfoLevel -> ParseResult (Flag DebugInfoLevel)
forall a. [PWarning] -> a -> ParseResult a
ParseOk [] (DebugInfoLevel -> Flag DebugInfoLevel
forall a. a -> Flag a
Flag DebugInfoLevel
NoDebugInfo)
                      | String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"1" -> [PWarning]
-> Flag DebugInfoLevel -> ParseResult (Flag DebugInfoLevel)
forall a. [PWarning] -> a -> ParseResult a
ParseOk [] (DebugInfoLevel -> Flag DebugInfoLevel
forall a. a -> Flag a
Flag DebugInfoLevel
MinimalDebugInfo)
                      | String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"2" -> [PWarning]
-> Flag DebugInfoLevel -> ParseResult (Flag DebugInfoLevel)
forall a. [PWarning] -> a -> ParseResult a
ParseOk [] (DebugInfoLevel -> Flag DebugInfoLevel
forall a. a -> Flag a
Flag DebugInfoLevel
NormalDebugInfo)
                      | String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"3" -> [PWarning]
-> Flag DebugInfoLevel -> ParseResult (Flag DebugInfoLevel)
forall a. [PWarning] -> a -> ParseResult a
ParseOk [] (DebugInfoLevel -> Flag DebugInfoLevel
forall a. a -> Flag a
Flag DebugInfoLevel
MaximalDebugInfo)
                      | String
lstr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"false" -> [PWarning]
-> Flag DebugInfoLevel -> ParseResult (Flag DebugInfoLevel)
forall a. [PWarning] -> a -> ParseResult a
ParseOk [PWarning
caseWarning] (DebugInfoLevel -> Flag DebugInfoLevel
forall a. a -> Flag a
Flag DebugInfoLevel
NoDebugInfo)
                      | String
lstr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"true" -> [PWarning]
-> Flag DebugInfoLevel -> ParseResult (Flag DebugInfoLevel)
forall a. [PWarning] -> a -> ParseResult a
ParseOk [PWarning
caseWarning] (DebugInfoLevel -> Flag DebugInfoLevel
forall a. a -> Flag a
Flag DebugInfoLevel
NormalDebugInfo)
                      | Bool
otherwise -> PError -> ParseResult (Flag DebugInfoLevel)
forall a. PError -> ParseResult a
ParseFailed (String -> Int -> PError
NoParse String
name Int
line)
                      where
                        lstr :: String
lstr = String -> String
lowercase String
str
                        caseWarning :: PWarning
caseWarning =
                          String -> PWarning
PWarning (String -> PWarning) -> String -> PWarning
forall a b. (a -> b) -> a -> b
$
                            String
"The '"
                              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
                              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' field is case sensitive, use 'True' or 'False'."
                )
      ]
    [FieldDescr SavedConfig]
-> [FieldDescr SavedConfig] -> [FieldDescr SavedConfig]
forall a. [a] -> [a] -> [a]
++ (FieldDescr ConfigExFlags -> FieldDescr SavedConfig)
-> [OptionField ConfigExFlags]
-> [String]
-> [FieldDescr ConfigExFlags]
-> [FieldDescr SavedConfig]
forall {t :: * -> *} {t :: * -> *} {a} {a}.
(Foldable t, Foldable t) =>
(FieldDescr a -> a)
-> [OptionField a] -> t String -> t (FieldDescr a) -> [a]
toSavedConfig
      FieldDescr ConfigExFlags -> FieldDescr SavedConfig
liftConfigExFlag
      (ShowOrParseArgs -> ConstraintSource -> [OptionField ConfigExFlags]
configureExOptions ShowOrParseArgs
ParseArgs ConstraintSource
src)
      []
      [ let pkgs :: ParsecParser (Maybe AllowOlder)
pkgs =
              (AllowOlder -> Maybe AllowOlder
forall a. a -> Maybe a
Just (AllowOlder -> Maybe AllowOlder)
-> ([RelaxedDep] -> AllowOlder) -> [RelaxedDep] -> Maybe AllowOlder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelaxDeps -> AllowOlder
AllowOlder (RelaxDeps -> AllowOlder)
-> ([RelaxedDep] -> RelaxDeps) -> [RelaxedDep] -> AllowOlder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RelaxedDep] -> RelaxDeps
RelaxDepsSome)
                ([RelaxedDep] -> Maybe AllowOlder)
-> ParsecParser [RelaxedDep] -> ParsecParser (Maybe AllowOlder)
forall a b. (a -> b) -> ParsecParser a -> ParsecParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ParsecParser RelaxedDep -> ParsecParser [RelaxedDep]
forall (m :: * -> *) a. CabalParsing m => m a -> m [a]
parsecOptCommaList ParsecParser RelaxedDep
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m RelaxedDep
parsec
            parseAllowOlder :: ParsecParser (Maybe AllowOlder)
parseAllowOlder =
              ( (AllowOlder -> Maybe AllowOlder
forall a. a -> Maybe a
Just (AllowOlder -> Maybe AllowOlder)
-> (Bool -> AllowOlder) -> Bool -> Maybe AllowOlder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelaxDeps -> AllowOlder
AllowOlder (RelaxDeps -> AllowOlder)
-> (Bool -> RelaxDeps) -> Bool -> AllowOlder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> RelaxDeps
toRelaxDeps)
                  (Bool -> Maybe AllowOlder)
-> ParsecParser Bool -> ParsecParser (Maybe AllowOlder)
forall a b. (a -> b) -> ParsecParser a -> ParsecParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ParsecParser Bool
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m Bool
parsec
              )
                ParsecParser (Maybe AllowOlder)
-> ParsecParser (Maybe AllowOlder)
-> ParsecParser (Maybe AllowOlder)
forall a. ParsecParser a -> ParsecParser a -> ParsecParser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecParser (Maybe AllowOlder)
pkgs
         in String
-> (Maybe AllowOlder -> Doc)
-> ParsecParser (Maybe AllowOlder)
-> (ConfigExFlags -> Maybe AllowOlder)
-> (Maybe AllowOlder -> ConfigExFlags -> ConfigExFlags)
-> FieldDescr ConfigExFlags
forall a b.
String
-> (a -> Doc)
-> ParsecParser a
-> (b -> a)
-> (a -> b -> b)
-> FieldDescr b
simpleFieldParsec
              String
"allow-older"
              (Maybe RelaxDeps -> Doc
showRelaxDeps (Maybe RelaxDeps -> Doc)
-> (Maybe AllowOlder -> Maybe RelaxDeps) -> Maybe AllowOlder -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AllowOlder -> RelaxDeps) -> Maybe AllowOlder -> Maybe RelaxDeps
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AllowOlder -> RelaxDeps
unAllowOlder)
              ParsecParser (Maybe AllowOlder)
parseAllowOlder
              ConfigExFlags -> Maybe AllowOlder
configAllowOlder
              (\Maybe AllowOlder
v ConfigExFlags
flags -> ConfigExFlags
flags{configAllowOlder = v})
      , let pkgs :: ParsecParser (Maybe AllowNewer)
pkgs =
              (AllowNewer -> Maybe AllowNewer
forall a. a -> Maybe a
Just (AllowNewer -> Maybe AllowNewer)
-> ([RelaxedDep] -> AllowNewer) -> [RelaxedDep] -> Maybe AllowNewer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelaxDeps -> AllowNewer
AllowNewer (RelaxDeps -> AllowNewer)
-> ([RelaxedDep] -> RelaxDeps) -> [RelaxedDep] -> AllowNewer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RelaxedDep] -> RelaxDeps
RelaxDepsSome)
                ([RelaxedDep] -> Maybe AllowNewer)
-> ParsecParser [RelaxedDep] -> ParsecParser (Maybe AllowNewer)
forall a b. (a -> b) -> ParsecParser a -> ParsecParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ParsecParser RelaxedDep -> ParsecParser [RelaxedDep]
forall (m :: * -> *) a. CabalParsing m => m a -> m [a]
parsecOptCommaList ParsecParser RelaxedDep
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m RelaxedDep
parsec
            parseAllowNewer :: ParsecParser (Maybe AllowNewer)
parseAllowNewer =
              ( (AllowNewer -> Maybe AllowNewer
forall a. a -> Maybe a
Just (AllowNewer -> Maybe AllowNewer)
-> (Bool -> AllowNewer) -> Bool -> Maybe AllowNewer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelaxDeps -> AllowNewer
AllowNewer (RelaxDeps -> AllowNewer)
-> (Bool -> RelaxDeps) -> Bool -> AllowNewer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> RelaxDeps
toRelaxDeps)
                  (Bool -> Maybe AllowNewer)
-> ParsecParser Bool -> ParsecParser (Maybe AllowNewer)
forall a b. (a -> b) -> ParsecParser a -> ParsecParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ParsecParser Bool
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m Bool
parsec
              )
                ParsecParser (Maybe AllowNewer)
-> ParsecParser (Maybe AllowNewer)
-> ParsecParser (Maybe AllowNewer)
forall a. ParsecParser a -> ParsecParser a -> ParsecParser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecParser (Maybe AllowNewer)
pkgs
         in String
-> (Maybe AllowNewer -> Doc)
-> ParsecParser (Maybe AllowNewer)
-> (ConfigExFlags -> Maybe AllowNewer)
-> (Maybe AllowNewer -> ConfigExFlags -> ConfigExFlags)
-> FieldDescr ConfigExFlags
forall a b.
String
-> (a -> Doc)
-> ParsecParser a
-> (b -> a)
-> (a -> b -> b)
-> FieldDescr b
simpleFieldParsec
              String
"allow-newer"
              (Maybe RelaxDeps -> Doc
showRelaxDeps (Maybe RelaxDeps -> Doc)
-> (Maybe AllowNewer -> Maybe RelaxDeps) -> Maybe AllowNewer -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AllowNewer -> RelaxDeps) -> Maybe AllowNewer -> Maybe RelaxDeps
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AllowNewer -> RelaxDeps
unAllowNewer)
              ParsecParser (Maybe AllowNewer)
parseAllowNewer
              ConfigExFlags -> Maybe AllowNewer
configAllowNewer
              (\Maybe AllowNewer
v ConfigExFlags
flags -> ConfigExFlags
flags{configAllowNewer = v})
      ]
    [FieldDescr SavedConfig]
-> [FieldDescr SavedConfig] -> [FieldDescr SavedConfig]
forall a. [a] -> [a] -> [a]
++ (FieldDescr InstallFlags -> FieldDescr SavedConfig)
-> [OptionField InstallFlags]
-> [String]
-> [FieldDescr InstallFlags]
-> [FieldDescr SavedConfig]
forall {t :: * -> *} {t :: * -> *} {a} {a}.
(Foldable t, Foldable t) =>
(FieldDescr a -> a)
-> [OptionField a] -> t String -> t (FieldDescr a) -> [a]
toSavedConfig
      FieldDescr InstallFlags -> FieldDescr SavedConfig
liftInstallFlag
      (ShowOrParseArgs -> [OptionField InstallFlags]
installOptions ShowOrParseArgs
ParseArgs)
      [String
"dry-run", String
"only", String
"only-dependencies", String
"dependencies-only"]
      []
    [FieldDescr SavedConfig]
-> [FieldDescr SavedConfig] -> [FieldDescr SavedConfig]
forall a. [a] -> [a] -> [a]
++ (FieldDescr ClientInstallFlags -> FieldDescr SavedConfig)
-> [OptionField ClientInstallFlags]
-> [String]
-> [FieldDescr ClientInstallFlags]
-> [FieldDescr SavedConfig]
forall {t :: * -> *} {t :: * -> *} {a} {a}.
(Foldable t, Foldable t) =>
(FieldDescr a -> a)
-> [OptionField a] -> t String -> t (FieldDescr a) -> [a]
toSavedConfig
      FieldDescr ClientInstallFlags -> FieldDescr SavedConfig
liftClientInstallFlag
      (ShowOrParseArgs -> [OptionField ClientInstallFlags]
clientInstallOptions ShowOrParseArgs
ParseArgs)
      []
      []
    [FieldDescr SavedConfig]
-> [FieldDescr SavedConfig] -> [FieldDescr SavedConfig]
forall a. [a] -> [a] -> [a]
++ (FieldDescr UploadFlags -> FieldDescr SavedConfig)
-> [OptionField UploadFlags]
-> [String]
-> [FieldDescr UploadFlags]
-> [FieldDescr SavedConfig]
forall {t :: * -> *} {t :: * -> *} {a} {a}.
(Foldable t, Foldable t) =>
(FieldDescr a -> a)
-> [OptionField a] -> t String -> t (FieldDescr a) -> [a]
toSavedConfig
      FieldDescr UploadFlags -> FieldDescr SavedConfig
liftUploadFlag
      (CommandUI UploadFlags
-> ShowOrParseArgs -> [OptionField UploadFlags]
forall flags.
CommandUI flags -> ShowOrParseArgs -> [OptionField flags]
commandOptions CommandUI UploadFlags
uploadCommand ShowOrParseArgs
ParseArgs)
      [String
"verbose", String
"check", String
"documentation", String
"publish"]
      []
    [FieldDescr SavedConfig]
-> [FieldDescr SavedConfig] -> [FieldDescr SavedConfig]
forall a. [a] -> [a] -> [a]
++ (FieldDescr ReportFlags -> FieldDescr SavedConfig)
-> [OptionField ReportFlags]
-> [String]
-> [FieldDescr ReportFlags]
-> [FieldDescr SavedConfig]
forall {t :: * -> *} {t :: * -> *} {a} {a}.
(Foldable t, Foldable t) =>
(FieldDescr a -> a)
-> [OptionField a] -> t String -> t (FieldDescr a) -> [a]
toSavedConfig
      FieldDescr ReportFlags -> FieldDescr SavedConfig
liftReportFlag
      (CommandUI ReportFlags
-> ShowOrParseArgs -> [OptionField ReportFlags]
forall flags.
CommandUI flags -> ShowOrParseArgs -> [OptionField flags]
commandOptions CommandUI ReportFlags
reportCommand ShowOrParseArgs
ParseArgs)
      [String
"verbose", String
"token", String
"username", String
"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.

    [FieldDescr SavedConfig]
-> [FieldDescr SavedConfig] -> [FieldDescr SavedConfig]
forall a. [a] -> [a] -> [a]
++ (FieldDescr (Flag Bool) -> FieldDescr SavedConfig)
-> [OptionField (Flag Bool)]
-> [String]
-> [FieldDescr (Flag Bool)]
-> [FieldDescr SavedConfig]
forall {t :: * -> *} {t :: * -> *} {a} {a}.
(Foldable t, Foldable t) =>
(FieldDescr a -> a)
-> [OptionField a] -> t String -> t (FieldDescr a) -> [a]
toSavedConfig
      FieldDescr (Flag Bool) -> FieldDescr SavedConfig
liftReplFlag
      [OptionField (Flag Bool)
multiReplOption]
      []
      []
    [FieldDescr SavedConfig]
-> [FieldDescr SavedConfig] -> [FieldDescr SavedConfig]
forall a. [a] -> [a] -> [a]
++ [ OptionField SavedConfig -> FieldDescr SavedConfig
forall a. OptionField a -> FieldDescr a
viewAsFieldDescr (OptionField SavedConfig -> FieldDescr SavedConfig)
-> OptionField SavedConfig -> FieldDescr SavedConfig
forall a b. (a -> b) -> a -> b
$
          (SavedConfig -> Flag (SymbolicPath Pkg ('Dir Dist)))
-> (Flag (SymbolicPath Pkg ('Dir Dist))
    -> SavedConfig -> SavedConfig)
-> ShowOrParseArgs
-> OptionField SavedConfig
forall flags.
(flags -> Flag (SymbolicPath Pkg ('Dir Dist)))
-> (Flag (SymbolicPath Pkg ('Dir Dist)) -> flags -> flags)
-> ShowOrParseArgs
-> OptionField flags
optionDistPref
            (CommonSetupFlags -> Flag (SymbolicPath Pkg ('Dir Dist))
setupDistPref (CommonSetupFlags -> Flag (SymbolicPath Pkg ('Dir Dist)))
-> (SavedConfig -> CommonSetupFlags)
-> SavedConfig
-> Flag (SymbolicPath Pkg ('Dir Dist))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigFlags -> CommonSetupFlags
configCommonFlags (ConfigFlags -> CommonSetupFlags)
-> (SavedConfig -> ConfigFlags) -> SavedConfig -> CommonSetupFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> ConfigFlags
savedConfigureFlags)
            ( \Flag (SymbolicPath Pkg ('Dir Dist))
distPref ->
                (CommonSetupFlags -> CommonSetupFlags)
-> SavedConfig -> SavedConfig
updSavedCommonSetupFlags (\CommonSetupFlags
common -> CommonSetupFlags
common{setupDistPref = distPref})
            )
            ShowOrParseArgs
ParseArgs
       ]
  where
    toSavedConfig :: (FieldDescr a -> a)
-> [OptionField a] -> t String -> t (FieldDescr a) -> [a]
toSavedConfig FieldDescr a -> a
lift [OptionField a]
options t String
exclusions t (FieldDescr a)
replacements =
      [ FieldDescr a -> a
lift (FieldDescr a -> Maybe (FieldDescr a) -> FieldDescr a
forall a. a -> Maybe a -> a
fromMaybe FieldDescr a
field Maybe (FieldDescr a)
replacement)
      | OptionField a
opt <- [OptionField a]
options
      , let field :: FieldDescr a
field = OptionField a -> FieldDescr a
forall a. OptionField a -> FieldDescr a
viewAsFieldDescr OptionField a
opt
            name :: String
name = FieldDescr a -> String
forall a. FieldDescr a -> String
fieldName FieldDescr a
field
            replacement :: Maybe (FieldDescr a)
replacement = (FieldDescr a -> Bool) -> t (FieldDescr a) -> Maybe (FieldDescr a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
name) (String -> Bool)
-> (FieldDescr a -> String) -> FieldDescr a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDescr a -> String
forall a. FieldDescr a -> String
fieldName) t (FieldDescr a)
replacements
      , String
name String -> t String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` t String
exclusions
      ]

    showRelaxDeps :: Maybe RelaxDeps -> Doc
showRelaxDeps Maybe RelaxDeps
Nothing = Doc
forall a. Monoid a => a
mempty
    showRelaxDeps (Just RelaxDeps
rd)
      | RelaxDeps -> Bool
isRelaxDeps RelaxDeps
rd = String -> Doc
Disp.text String
"True"
      | Bool
otherwise = String -> Doc
Disp.text String
"False"

    toRelaxDeps :: Bool -> RelaxDeps
toRelaxDeps Bool
True = RelaxDeps
RelaxDepsAll
    toRelaxDeps Bool
False = RelaxDeps
forall a. Monoid a => a
mempty

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

-- TODO: next step, make the deprecated fields elicit a warning.
--
deprecatedFieldDescriptions :: [FieldDescr SavedConfig]
deprecatedFieldDescriptions :: [FieldDescr SavedConfig]
deprecatedFieldDescriptions =
  [ FieldDescr GlobalFlags -> FieldDescr SavedConfig
liftGlobalFlag (FieldDescr GlobalFlags -> FieldDescr SavedConfig)
-> FieldDescr GlobalFlags -> FieldDescr SavedConfig
forall a b. (a -> b) -> a -> b
$
      String
-> (RemoteRepo -> Doc)
-> ParsecParser RemoteRepo
-> (GlobalFlags -> [RemoteRepo])
-> ([RemoteRepo] -> GlobalFlags -> GlobalFlags)
-> FieldDescr GlobalFlags
forall a b.
String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
listFieldParsec
        String
"repos"
        RemoteRepo -> Doc
forall a. Pretty a => a -> Doc
pretty
        ParsecParser RemoteRepo
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m RemoteRepo
parsec
        (NubList RemoteRepo -> [RemoteRepo]
forall a. NubList a -> [a]
fromNubList (NubList RemoteRepo -> [RemoteRepo])
-> (GlobalFlags -> NubList RemoteRepo)
-> GlobalFlags
-> [RemoteRepo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalFlags -> NubList RemoteRepo
globalRemoteRepos)
        (\[RemoteRepo]
rs GlobalFlags
cfg -> GlobalFlags
cfg{globalRemoteRepos = toNubList rs})
  , FieldDescr GlobalFlags -> FieldDescr SavedConfig
liftGlobalFlag (FieldDescr GlobalFlags -> FieldDescr SavedConfig)
-> FieldDescr GlobalFlags -> FieldDescr SavedConfig
forall a b. (a -> b) -> a -> b
$
      String
-> (Flag String -> Doc)
-> ParsecParser (Flag String)
-> (GlobalFlags -> Flag String)
-> (Flag String -> GlobalFlags -> GlobalFlags)
-> FieldDescr GlobalFlags
forall a b.
String
-> (a -> Doc)
-> ParsecParser a
-> (b -> a)
-> (a -> b -> b)
-> FieldDescr b
simpleFieldParsec
        String
"cachedir"
        (String -> Doc
Disp.text (String -> Doc) -> (Flag String -> String) -> Flag String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Flag String -> String
forall a. a -> Flag a -> a
fromFlagOrDefault String
"")
        (ParsecParser String -> ParsecParser (Flag String)
forall a. ParsecParser a -> ParsecParser (Flag a)
optionalFlag ParsecParser String
forall (m :: * -> *). CabalParsing m => m String
parsecFilePath)
        GlobalFlags -> Flag String
globalCacheDir
        (\Flag String
d GlobalFlags
cfg -> GlobalFlags
cfg{globalCacheDir = d})
  , FieldDescr UploadFlags -> FieldDescr SavedConfig
liftUploadFlag (FieldDescr UploadFlags -> FieldDescr SavedConfig)
-> FieldDescr UploadFlags -> FieldDescr SavedConfig
forall a b. (a -> b) -> a -> b
$
      String
-> (Flag Token -> Doc)
-> ParsecParser (Flag Token)
-> (UploadFlags -> Flag Token)
-> (Flag Token -> UploadFlags -> UploadFlags)
-> FieldDescr UploadFlags
forall a b.
String
-> (a -> Doc)
-> ParsecParser a
-> (b -> a)
-> (a -> b -> b)
-> FieldDescr b
simpleFieldParsec
        String
"hackage-token"
        (String -> Doc
Disp.text (String -> Doc) -> (Flag Token -> String) -> Flag Token -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Flag String -> String
forall a. a -> Flag a -> a
fromFlagOrDefault String
"" (Flag String -> String)
-> (Flag Token -> Flag String) -> Flag Token -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Token -> String) -> Flag Token -> Flag String
forall a b. (a -> b) -> Flag a -> Flag b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Token -> String
unToken)
        (ParsecParser Token -> ParsecParser (Flag Token)
forall a. ParsecParser a -> ParsecParser (Flag a)
optionalFlag ((String -> Token) -> ParsecParser String -> ParsecParser Token
forall a b. (a -> b) -> ParsecParser a -> ParsecParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Token
Token ParsecParser String
forall (m :: * -> *). CabalParsing m => m String
parsecToken))
        UploadFlags -> Flag Token
uploadToken
        (\Flag Token
d UploadFlags
cfg -> UploadFlags
cfg{uploadToken = d})
  , FieldDescr UploadFlags -> FieldDescr SavedConfig
liftUploadFlag (FieldDescr UploadFlags -> FieldDescr SavedConfig)
-> FieldDescr UploadFlags -> FieldDescr SavedConfig
forall a b. (a -> b) -> a -> b
$
      String
-> (Flag Username -> Doc)
-> ParsecParser (Flag Username)
-> (UploadFlags -> Flag Username)
-> (Flag Username -> UploadFlags -> UploadFlags)
-> FieldDescr UploadFlags
forall a b.
String
-> (a -> Doc)
-> ParsecParser a
-> (b -> a)
-> (a -> b -> b)
-> FieldDescr b
simpleFieldParsec
        String
"hackage-username"
        (String -> Doc
Disp.text (String -> Doc)
-> (Flag Username -> String) -> Flag Username -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Flag String -> String
forall a. a -> Flag a -> a
fromFlagOrDefault String
"" (Flag String -> String)
-> (Flag Username -> Flag String) -> Flag Username -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Username -> String) -> Flag Username -> Flag String
forall a b. (a -> b) -> Flag a -> Flag b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Username -> String
unUsername)
        (ParsecParser Username -> ParsecParser (Flag Username)
forall a. ParsecParser a -> ParsecParser (Flag a)
optionalFlag ((String -> Username)
-> ParsecParser String -> ParsecParser Username
forall a b. (a -> b) -> ParsecParser a -> ParsecParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Username
Username ParsecParser String
forall (m :: * -> *). CabalParsing m => m String
parsecToken))
        UploadFlags -> Flag Username
uploadUsername
        (\Flag Username
d UploadFlags
cfg -> UploadFlags
cfg{uploadUsername = d})
  , FieldDescr UploadFlags -> FieldDescr SavedConfig
liftUploadFlag (FieldDescr UploadFlags -> FieldDescr SavedConfig)
-> FieldDescr UploadFlags -> FieldDescr SavedConfig
forall a b. (a -> b) -> a -> b
$
      String
-> (Flag Password -> Doc)
-> ParsecParser (Flag Password)
-> (UploadFlags -> Flag Password)
-> (Flag Password -> UploadFlags -> UploadFlags)
-> FieldDescr UploadFlags
forall a b.
String
-> (a -> Doc)
-> ParsecParser a
-> (b -> a)
-> (a -> b -> b)
-> FieldDescr b
simpleFieldParsec
        String
"hackage-password"
        (String -> Doc
Disp.text (String -> Doc)
-> (Flag Password -> String) -> Flag Password -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Flag String -> String
forall a. a -> Flag a -> a
fromFlagOrDefault String
"" (Flag String -> String)
-> (Flag Password -> Flag String) -> Flag Password -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Password -> String) -> Flag Password -> Flag String
forall a b. (a -> b) -> Flag a -> Flag b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Password -> String
unPassword)
        (ParsecParser Password -> ParsecParser (Flag Password)
forall a. ParsecParser a -> ParsecParser (Flag a)
optionalFlag ((String -> Password)
-> ParsecParser String -> ParsecParser Password
forall a b. (a -> b) -> ParsecParser a -> ParsecParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Password
Password ParsecParser String
forall (m :: * -> *). CabalParsing m => m String
parsecToken))
        UploadFlags -> Flag Password
uploadPassword
        (\Flag Password
d UploadFlags
cfg -> UploadFlags
cfg{uploadPassword = d})
  , FieldDescr UploadFlags -> FieldDescr SavedConfig
liftUploadFlag (FieldDescr UploadFlags -> FieldDescr SavedConfig)
-> FieldDescr UploadFlags -> FieldDescr SavedConfig
forall a b. (a -> b) -> a -> b
$
      String
-> (String -> Doc)
-> ReadP [String] String
-> (UploadFlags -> [String])
-> ([String] -> UploadFlags -> UploadFlags)
-> FieldDescr UploadFlags
forall a b.
String
-> (a -> Doc)
-> ReadP [a] a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
spaceListField
        String
"hackage-password-command"
        String -> Doc
Disp.text
        ReadP [String] String
forall r. ReadP r String
parseTokenQ
        ([String] -> Flag [String] -> [String]
forall a. a -> Flag a -> a
fromFlagOrDefault [] (Flag [String] -> [String])
-> (UploadFlags -> Flag [String]) -> UploadFlags -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UploadFlags -> Flag [String]
uploadPasswordCmd)
        (\[String]
d UploadFlags
cfg -> UploadFlags
cfg{uploadPasswordCmd = Flag d})
  ]
    [FieldDescr SavedConfig]
-> [FieldDescr SavedConfig] -> [FieldDescr SavedConfig]
forall a. [a] -> [a] -> [a]
++ (FieldDescr (InstallDirs (Flag PathTemplate))
 -> FieldDescr SavedConfig)
-> [FieldDescr (InstallDirs (Flag PathTemplate))]
-> [FieldDescr SavedConfig]
forall a b. (a -> b) -> [a] -> [b]
map
      ((String -> String)
-> FieldDescr SavedConfig -> FieldDescr SavedConfig
forall a. (String -> String) -> FieldDescr a -> FieldDescr a
modifyFieldName (String
"user-" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (FieldDescr SavedConfig -> FieldDescr SavedConfig)
-> (FieldDescr (InstallDirs (Flag PathTemplate))
    -> FieldDescr SavedConfig)
-> FieldDescr (InstallDirs (Flag PathTemplate))
-> FieldDescr SavedConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDescr (InstallDirs (Flag PathTemplate))
-> FieldDescr SavedConfig
liftUserInstallDirs)
      [FieldDescr (InstallDirs (Flag PathTemplate))]
installDirsFields
    [FieldDescr SavedConfig]
-> [FieldDescr SavedConfig] -> [FieldDescr SavedConfig]
forall a. [a] -> [a] -> [a]
++ (FieldDescr (InstallDirs (Flag PathTemplate))
 -> FieldDescr SavedConfig)
-> [FieldDescr (InstallDirs (Flag PathTemplate))]
-> [FieldDescr SavedConfig]
forall a b. (a -> b) -> [a] -> [b]
map
      ((String -> String)
-> FieldDescr SavedConfig -> FieldDescr SavedConfig
forall a. (String -> String) -> FieldDescr a -> FieldDescr a
modifyFieldName (String
"global-" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (FieldDescr SavedConfig -> FieldDescr SavedConfig)
-> (FieldDescr (InstallDirs (Flag PathTemplate))
    -> FieldDescr SavedConfig)
-> FieldDescr (InstallDirs (Flag PathTemplate))
-> FieldDescr SavedConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDescr (InstallDirs (Flag PathTemplate))
-> FieldDescr SavedConfig
liftGlobalInstallDirs)
      [FieldDescr (InstallDirs (Flag PathTemplate))]
installDirsFields
  where
    optionalFlag :: ParsecParser a -> ParsecParser (Flag a)
    optionalFlag :: forall a. ParsecParser a -> ParsecParser (Flag a)
optionalFlag ParsecParser a
p = a -> Flag a
forall a. a -> Flag a
toFlag (a -> Flag a) -> ParsecParser a -> ParsecParser (Flag a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecParser a
p ParsecParser (Flag a)
-> ParsecParser (Flag a) -> ParsecParser (Flag a)
forall a. ParsecParser a -> ParsecParser a -> ParsecParser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Flag a -> ParsecParser (Flag a)
forall a. a -> ParsecParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Flag a
forall a. Monoid a => a
mempty

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

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

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

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

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

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

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

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

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

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

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

parseConfig
  :: ConstraintSource
  -> SavedConfig
  -> BS.ByteString
  -> ParseResult SavedConfig
parseConfig :: ConstraintSource
-> SavedConfig -> ByteString -> ParseResult SavedConfig
parseConfig ConstraintSource
src SavedConfig
initial = \ByteString
str -> do
  [Field]
fields <- ByteString -> ParseResult [Field]
readFields ByteString
str
  let ([Field]
knownSections, [Field]
others) = (Field -> Bool) -> [Field] -> ([Field], [Field])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Field -> Bool
isKnownSection [Field]
fields
  SavedConfig
config <- [Field] -> ParseResult SavedConfig
parse [Field]
others
  let init0 :: InitFlags
init0 = SavedConfig -> InitFlags
savedInitFlags SavedConfig
config
      user0 :: InstallDirs (Flag PathTemplate)
user0 = SavedConfig -> InstallDirs (Flag PathTemplate)
savedUserInstallDirs SavedConfig
config
      global0 :: InstallDirs (Flag PathTemplate)
global0 = SavedConfig -> InstallDirs (Flag PathTemplate)
savedGlobalInstallDirs SavedConfig
config
  ([RemoteRepo]
remoteRepoSections0, [LocalRepo]
localRepoSections0, HaddockFlags
haddockFlags, InitFlags
initFlags, InstallDirs (Flag PathTemplate)
user, InstallDirs (Flag PathTemplate)
global, [(String, String)]
paths, [(String, [String])]
args) <-
    (([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
  InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
  [(String, String)], [(String, [String])])
 -> Field
 -> ParseResult
      ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
       InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
       [(String, String)], [(String, [String])]))
-> ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
    InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
    [(String, String)], [(String, [String])])
-> [Field]
-> ParseResult
     ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
      InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
      [(String, String)], [(String, [String])])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
      ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
-> Field
-> ParseResult
     ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
      InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
      [(String, String)], [(String, [String])])
parseSections
      ([], [], SavedConfig -> HaddockFlags
savedHaddockFlags SavedConfig
config, InitFlags
init0, InstallDirs (Flag PathTemplate)
user0, InstallDirs (Flag PathTemplate)
global0, [], [])
      [Field]
knownSections

  let remoteRepoSections :: [RemoteRepo]
remoteRepoSections =
        [RemoteRepo] -> [RemoteRepo]
forall a. [a] -> [a]
reverse
          ([RemoteRepo] -> [RemoteRepo])
-> ([RemoteRepo] -> [RemoteRepo]) -> [RemoteRepo] -> [RemoteRepo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RemoteRepo -> RemoteRepo -> Bool) -> [RemoteRepo] -> [RemoteRepo]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (RepoName -> RepoName -> Bool
forall a. Eq a => a -> a -> Bool
(==) (RepoName -> RepoName -> Bool)
-> (RemoteRepo -> RepoName) -> RemoteRepo -> RemoteRepo -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` RemoteRepo -> RepoName
remoteRepoName)
          ([RemoteRepo] -> [RemoteRepo]) -> [RemoteRepo] -> [RemoteRepo]
forall a b. (a -> b) -> a -> b
$ [RemoteRepo]
remoteRepoSections0

  let localRepoSections :: [LocalRepo]
localRepoSections =
        [LocalRepo] -> [LocalRepo]
forall a. [a] -> [a]
reverse
          ([LocalRepo] -> [LocalRepo])
-> ([LocalRepo] -> [LocalRepo]) -> [LocalRepo] -> [LocalRepo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LocalRepo -> LocalRepo -> Bool) -> [LocalRepo] -> [LocalRepo]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (RepoName -> RepoName -> Bool
forall a. Eq a => a -> a -> Bool
(==) (RepoName -> RepoName -> Bool)
-> (LocalRepo -> RepoName) -> LocalRepo -> LocalRepo -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` LocalRepo -> RepoName
localRepoName)
          ([LocalRepo] -> [LocalRepo]) -> [LocalRepo] -> [LocalRepo]
forall a b. (a -> b) -> a -> b
$ [LocalRepo]
localRepoSections0

  SavedConfig -> ParseResult SavedConfig
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return (SavedConfig -> ParseResult SavedConfig)
-> (SavedConfig -> SavedConfig)
-> SavedConfig
-> ParseResult SavedConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> SavedConfig
fixConfigMultilines (SavedConfig -> ParseResult SavedConfig)
-> SavedConfig -> ParseResult SavedConfig
forall a b. (a -> b) -> a -> b
$
    SavedConfig
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 :: Field -> Bool
isKnownSection (ParseUtils.Section Int
_ String
"repository" String
_ [Field]
_) = Bool
True
    isKnownSection (ParseUtils.F Int
_ String
"remote-repo" String
_) = Bool
True
    isKnownSection (ParseUtils.Section Int
_ String
"haddock" String
_ [Field]
_) = Bool
True
    isKnownSection (ParseUtils.Section Int
_ String
"init" String
_ [Field]
_) = Bool
True
    isKnownSection (ParseUtils.Section Int
_ String
"install-dirs" String
_ [Field]
_) = Bool
True
    isKnownSection (ParseUtils.Section Int
_ String
"program-locations" String
_ [Field]
_) = Bool
True
    isKnownSection (ParseUtils.Section Int
_ String
"program-default-options" String
_ [Field]
_) = Bool
True
    isKnownSection Field
_ = Bool
False

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

    splitMultiSymPath :: [SymbolicPathX allowAbsolute from to]
-> [SymbolicPathX allowAbs from to]
splitMultiSymPath =
      (String -> SymbolicPathX allowAbs from to)
-> [String] -> [SymbolicPathX allowAbs from to]
forall a b. (a -> b) -> [a] -> [b]
map String -> SymbolicPathX allowAbs from to
forall (allowAbs :: AllowAbsolute) from (to :: FileOrDir).
String -> SymbolicPathX allowAbs from to
unsafeMakeSymbolicPath ([String] -> [SymbolicPathX allowAbs from to])
-> ([SymbolicPathX allowAbsolute from to] -> [String])
-> [SymbolicPathX allowAbsolute from to]
-> [SymbolicPathX allowAbs from to]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
splitMultiPath ([String] -> [String])
-> ([SymbolicPathX allowAbsolute from to] -> [String])
-> [SymbolicPathX allowAbsolute from to]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SymbolicPathX allowAbsolute from to -> String)
-> [SymbolicPathX allowAbsolute from to] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPathX allowAbsolute from to -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
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 :: SavedConfig -> SavedConfig
fixConfigMultilines SavedConfig
conf =
      SavedConfig
conf
        { savedConfigureFlags =
            let scf = SavedConfig -> ConfigFlags
savedConfigureFlags SavedConfig
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 = SavedConfig -> GlobalFlags
savedGlobalFlags SavedConfig
conf
             in sgf
                  { globalProgPathExtra =
                      toNubList $
                        splitMultiPath
                          (fromNubList $ globalProgPathExtra sgf)
                  }
        }

    parse :: [Field] -> ParseResult SavedConfig
parse =
      [FieldDescr SavedConfig]
-> SavedConfig -> [Field] -> ParseResult SavedConfig
forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields
        ( ConstraintSource -> [FieldDescr SavedConfig]
configFieldDescriptions ConstraintSource
src
            [FieldDescr SavedConfig]
-> [FieldDescr SavedConfig] -> [FieldDescr SavedConfig]
forall a. [a] -> [a] -> [a]
++ [FieldDescr SavedConfig]
deprecatedFieldDescriptions
        )
        SavedConfig
initial

    parseSections :: ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
-> Field
-> ParseResult
     ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
      InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
      [(String, String)], [(String, [String])])
parseSections
      ([RemoteRepo]
rs, [LocalRepo]
ls, HaddockFlags
h, InitFlags
i, InstallDirs (Flag PathTemplate)
u, InstallDirs (Flag PathTemplate)
g, [(String, String)]
p, [(String, [String])]
a)
      (ParseUtils.Section Int
lineno String
"repository" String
name [Field]
fs) = do
        RepoName
name' <-
          ParseResult RepoName
-> (RepoName -> ParseResult RepoName)
-> Maybe RepoName
-> ParseResult RepoName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PError -> ParseResult RepoName
forall a. PError -> ParseResult a
ParseFailed (PError -> ParseResult RepoName) -> PError -> ParseResult RepoName
forall a b. (a -> b) -> a -> b
$ String -> Int -> PError
NoParse String
"repository name" Int
lineno) RepoName -> ParseResult RepoName
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe RepoName -> ParseResult RepoName)
-> Maybe RepoName -> ParseResult RepoName
forall a b. (a -> b) -> a -> b
$
            String -> Maybe RepoName
forall a. Parsec a => String -> Maybe a
simpleParsec String
name
        RemoteRepo
r' <- [FieldDescr RemoteRepo]
-> RemoteRepo -> [Field] -> ParseResult RemoteRepo
forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields [FieldDescr RemoteRepo]
remoteRepoFields (RepoName -> RemoteRepo
emptyRemoteRepo RepoName
name') [Field]
fs
        Either LocalRepo RemoteRepo
r'' <- Int
-> String
-> RemoteRepo
-> ParseResult (Either LocalRepo RemoteRepo)
postProcessRepo Int
lineno String
name RemoteRepo
r'
        case Either LocalRepo RemoteRepo
r'' of
          Left LocalRepo
local -> ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
-> ParseResult
     ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
      InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
      [(String, String)], [(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return ([RemoteRepo]
rs, LocalRepo
local LocalRepo -> [LocalRepo] -> [LocalRepo]
forall a. a -> [a] -> [a]
: [LocalRepo]
ls, HaddockFlags
h, InitFlags
i, InstallDirs (Flag PathTemplate)
u, InstallDirs (Flag PathTemplate)
g, [(String, String)]
p, [(String, [String])]
a)
          Right RemoteRepo
remote -> ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
-> ParseResult
     ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
      InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
      [(String, String)], [(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return (RemoteRepo
remote RemoteRepo -> [RemoteRepo] -> [RemoteRepo]
forall a. a -> [a] -> [a]
: [RemoteRepo]
rs, [LocalRepo]
ls, HaddockFlags
h, InitFlags
i, InstallDirs (Flag PathTemplate)
u, InstallDirs (Flag PathTemplate)
g, [(String, String)]
p, [(String, [String])]
a)
    parseSections
      ([RemoteRepo]
rs, [LocalRepo]
ls, HaddockFlags
h, InitFlags
i, InstallDirs (Flag PathTemplate)
u, InstallDirs (Flag PathTemplate)
g, [(String, String)]
p, [(String, [String])]
a)
      (ParseUtils.F Int
lno String
"remote-repo" String
raw) = do
        let mr' :: Maybe RemoteRepo
mr' = String -> Maybe RemoteRepo
forall a. Parsec a => String -> Maybe a
simpleParsec String
raw
        RemoteRepo
r' <- ParseResult RemoteRepo
-> (RemoteRepo -> ParseResult RemoteRepo)
-> Maybe RemoteRepo
-> ParseResult RemoteRepo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PError -> ParseResult RemoteRepo
forall a. PError -> ParseResult a
ParseFailed (PError -> ParseResult RemoteRepo)
-> PError -> ParseResult RemoteRepo
forall a b. (a -> b) -> a -> b
$ String -> Int -> PError
NoParse String
"remote-repo" Int
lno) RemoteRepo -> ParseResult RemoteRepo
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RemoteRepo
mr'
        ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
-> ParseResult
     ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
      InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
      [(String, String)], [(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return (RemoteRepo
r' RemoteRepo -> [RemoteRepo] -> [RemoteRepo]
forall a. a -> [a] -> [a]
: [RemoteRepo]
rs, [LocalRepo]
ls, HaddockFlags
h, InitFlags
i, InstallDirs (Flag PathTemplate)
u, InstallDirs (Flag PathTemplate)
g, [(String, String)]
p, [(String, [String])]
a)
    parseSections
      accum :: ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
accum@([RemoteRepo]
rs, [LocalRepo]
ls, HaddockFlags
h, InitFlags
i, InstallDirs (Flag PathTemplate)
u, InstallDirs (Flag PathTemplate)
g, [(String, String)]
p, [(String, [String])]
a)
      (ParseUtils.Section Int
_ String
"haddock" String
name [Field]
fs)
        | String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" = do
            HaddockFlags
h' <- [FieldDescr HaddockFlags]
-> HaddockFlags -> [Field] -> ParseResult HaddockFlags
forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields [FieldDescr HaddockFlags]
haddockFlagsFields HaddockFlags
h [Field]
fs
            ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
-> ParseResult
     ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
      InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
      [(String, String)], [(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return ([RemoteRepo]
rs, [LocalRepo]
ls, HaddockFlags
h', InitFlags
i, InstallDirs (Flag PathTemplate)
u, InstallDirs (Flag PathTemplate)
g, [(String, String)]
p, [(String, [String])]
a)
        | Bool
otherwise = do
            String -> ParseResult ()
warning String
"The 'haddock' section should be unnamed"
            ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
-> ParseResult
     ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
      InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
      [(String, String)], [(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
accum
    parseSections
      accum :: ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
accum@([RemoteRepo]
rs, [LocalRepo]
ls, HaddockFlags
h, InitFlags
i, InstallDirs (Flag PathTemplate)
u, InstallDirs (Flag PathTemplate)
g, [(String, String)]
p, [(String, [String])]
a)
      (ParseUtils.Section Int
_ String
"init" String
name [Field]
fs)
        | String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" = do
            InitFlags
i' <- [FieldDescr InitFlags]
-> InitFlags -> [Field] -> ParseResult InitFlags
forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields [FieldDescr InitFlags]
initFlagsFields InitFlags
i [Field]
fs
            ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
-> ParseResult
     ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
      InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
      [(String, String)], [(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return ([RemoteRepo]
rs, [LocalRepo]
ls, HaddockFlags
h, InitFlags
i', InstallDirs (Flag PathTemplate)
u, InstallDirs (Flag PathTemplate)
g, [(String, String)]
p, [(String, [String])]
a)
        | Bool
otherwise = do
            String -> ParseResult ()
warning String
"The 'init' section should be unnamed"
            ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
-> ParseResult
     ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
      InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
      [(String, String)], [(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
accum
    parseSections
      accum :: ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
accum@([RemoteRepo]
rs, [LocalRepo]
ls, HaddockFlags
h, InitFlags
i, InstallDirs (Flag PathTemplate)
u, InstallDirs (Flag PathTemplate)
g, [(String, String)]
p, [(String, [String])]
a)
      (ParseUtils.Section Int
_ String
"install-dirs" String
name [Field]
fs)
        | String
name' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"user" = do
            InstallDirs (Flag PathTemplate)
u' <- [FieldDescr (InstallDirs (Flag PathTemplate))]
-> InstallDirs (Flag PathTemplate)
-> [Field]
-> ParseResult (InstallDirs (Flag PathTemplate))
forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields [FieldDescr (InstallDirs (Flag PathTemplate))]
installDirsFields InstallDirs (Flag PathTemplate)
u [Field]
fs
            ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
-> ParseResult
     ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
      InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
      [(String, String)], [(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return ([RemoteRepo]
rs, [LocalRepo]
ls, HaddockFlags
h, InitFlags
i, InstallDirs (Flag PathTemplate)
u', InstallDirs (Flag PathTemplate)
g, [(String, String)]
p, [(String, [String])]
a)
        | String
name' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"global" = do
            InstallDirs (Flag PathTemplate)
g' <- [FieldDescr (InstallDirs (Flag PathTemplate))]
-> InstallDirs (Flag PathTemplate)
-> [Field]
-> ParseResult (InstallDirs (Flag PathTemplate))
forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields [FieldDescr (InstallDirs (Flag PathTemplate))]
installDirsFields InstallDirs (Flag PathTemplate)
g [Field]
fs
            ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
-> ParseResult
     ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
      InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
      [(String, String)], [(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return ([RemoteRepo]
rs, [LocalRepo]
ls, HaddockFlags
h, InitFlags
i, InstallDirs (Flag PathTemplate)
u, InstallDirs (Flag PathTemplate)
g', [(String, String)]
p, [(String, [String])]
a)
        | Bool
otherwise = do
            String -> ParseResult ()
warning String
"The 'install-paths' section should be for 'user' or 'global'"
            ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
-> ParseResult
     ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
      InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
      [(String, String)], [(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
accum
        where
          name' :: String
name' = String -> String
lowercase String
name
    parseSections
      accum :: ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
accum@([RemoteRepo]
rs, [LocalRepo]
ls, HaddockFlags
h, InitFlags
i, InstallDirs (Flag PathTemplate)
u, InstallDirs (Flag PathTemplate)
g, [(String, String)]
p, [(String, [String])]
a)
      (ParseUtils.Section Int
_ String
"program-locations" String
name [Field]
fs)
        | String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" = do
            [(String, String)]
p' <- [FieldDescr [(String, String)]]
-> [(String, String)] -> [Field] -> ParseResult [(String, String)]
forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields [FieldDescr [(String, String)]]
withProgramsFields [(String, String)]
p [Field]
fs
            ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
-> ParseResult
     ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
      InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
      [(String, String)], [(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return ([RemoteRepo]
rs, [LocalRepo]
ls, HaddockFlags
h, InitFlags
i, InstallDirs (Flag PathTemplate)
u, InstallDirs (Flag PathTemplate)
g, [(String, String)]
p', [(String, [String])]
a)
        | Bool
otherwise = do
            String -> ParseResult ()
warning String
"The 'program-locations' section should be unnamed"
            ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
-> ParseResult
     ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
      InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
      [(String, String)], [(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
accum
    parseSections
      accum :: ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
accum@([RemoteRepo]
rs, [LocalRepo]
ls, HaddockFlags
h, InitFlags
i, InstallDirs (Flag PathTemplate)
u, InstallDirs (Flag PathTemplate)
g, [(String, String)]
p, [(String, [String])]
a)
      (ParseUtils.Section Int
_ String
"program-default-options" String
name [Field]
fs)
        | String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" = do
            [(String, [String])]
a' <- [FieldDescr [(String, [String])]]
-> [(String, [String])]
-> [Field]
-> ParseResult [(String, [String])]
forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields [FieldDescr [(String, [String])]]
withProgramOptionsFields [(String, [String])]
a [Field]
fs
            ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
-> ParseResult
     ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
      InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
      [(String, String)], [(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return ([RemoteRepo]
rs, [LocalRepo]
ls, HaddockFlags
h, InitFlags
i, InstallDirs (Flag PathTemplate)
u, InstallDirs (Flag PathTemplate)
g, [(String, String)]
p, [(String, [String])]
a')
        | Bool
otherwise = do
            String -> ParseResult ()
warning String
"The 'program-default-options' section should be unnamed"
            ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
-> ParseResult
     ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
      InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
      [(String, String)], [(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
accum
    parseSections ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
accum Field
f = do
      String -> ParseResult ()
warning (String -> ParseResult ()) -> String -> ParseResult ()
forall a b. (a -> b) -> a -> b
$ String
"Unrecognized stanza on line " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Field -> Int
lineNo Field
f)
      ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
-> ParseResult
     ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
      InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
      [(String, String)], [(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return ([RemoteRepo], [LocalRepo], HaddockFlags, InitFlags,
 InstallDirs (Flag PathTemplate), InstallDirs (Flag PathTemplate),
 [(String, String)], [(String, [String])])
accum

postProcessRepo :: Int -> String -> RemoteRepo -> ParseResult (Either LocalRepo RemoteRepo)
postProcessRepo :: Int
-> String
-> RemoteRepo
-> ParseResult (Either LocalRepo RemoteRepo)
postProcessRepo Int
lineno String
reponameStr RemoteRepo
repo0 = do
  Bool -> ParseResult () -> ParseResult ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
reponameStr) (ParseResult () -> ParseResult ())
-> ParseResult () -> ParseResult ()
forall a b. (a -> b) -> a -> b
$
    Int -> String -> ParseResult ()
forall a. Int -> String -> ParseResult a
syntaxError Int
lineno (String -> ParseResult ()) -> String -> ParseResult ()
forall a b. (a -> b) -> a -> b
$
      String
"a 'repository' section requires the "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"repository name as an argument"

  RepoName
reponame <-
    ParseResult RepoName
-> (RepoName -> ParseResult RepoName)
-> Maybe RepoName
-> ParseResult RepoName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ParseResult RepoName
forall a. String -> ParseResult a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParseResult RepoName) -> String -> ParseResult RepoName
forall a b. (a -> b) -> a -> b
$ String
"Invalid repository name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
reponameStr) RepoName -> ParseResult RepoName
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe RepoName -> ParseResult RepoName)
-> Maybe RepoName -> ParseResult RepoName
forall a b. (a -> b) -> a -> b
$
      String -> Maybe RepoName
forall a. Parsec a => String -> Maybe a
simpleParsec String
reponameStr

  case URI -> String
uriScheme (RemoteRepo -> URI
remoteRepoURI RemoteRepo
repo0) of
    -- TODO: check that there are no authority, query or fragment
    -- Note: the trailing colon is important
    String
"file+noindex:" -> do
      let uri :: URI
uri = RemoteRepo -> URI
remoteRepoURI RemoteRepo
repo0
      Either LocalRepo RemoteRepo
-> ParseResult (Either LocalRepo RemoteRepo)
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either LocalRepo RemoteRepo
 -> ParseResult (Either LocalRepo RemoteRepo))
-> Either LocalRepo RemoteRepo
-> ParseResult (Either LocalRepo RemoteRepo)
forall a b. (a -> b) -> a -> b
$
        LocalRepo -> Either LocalRepo RemoteRepo
forall a b. a -> Either a b
Left (LocalRepo -> Either LocalRepo RemoteRepo)
-> LocalRepo -> Either LocalRepo RemoteRepo
forall a b. (a -> b) -> a -> b
$
          RepoName -> String -> Bool -> LocalRepo
LocalRepo
            RepoName
reponame
            (String -> String
normalise (URI -> String
uriPath URI
uri))
            (URI -> String
uriFragment URI
uri String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"#shared-cache")
    String
_ -> do
      let repo :: RemoteRepo
repo = RemoteRepo
repo0{remoteRepoName = reponame}

      Bool -> ParseResult () -> ParseResult ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RemoteRepo -> Int
remoteRepoKeyThreshold RemoteRepo
repo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (RemoteRepo -> [String]
remoteRepoRootKeys RemoteRepo
repo)) (ParseResult () -> ParseResult ())
-> ParseResult () -> ParseResult ()
forall a b. (a -> b) -> a -> b
$
        String -> ParseResult ()
warning (String -> ParseResult ()) -> String -> ParseResult ()
forall a b. (a -> b) -> a -> b
$
          String
"'key-threshold' for repository "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ RepoName -> String
forall a. Show a => a -> String
show (RemoteRepo -> RepoName
remoteRepoName RemoteRepo
repo)
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" higher than number of keys"

      Bool -> ParseResult () -> ParseResult ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (RemoteRepo -> [String]
remoteRepoRootKeys RemoteRepo
repo)) Bool -> Bool -> Bool
&& RemoteRepo -> Maybe Bool
remoteRepoSecure RemoteRepo
repo Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) (ParseResult () -> ParseResult ())
-> ParseResult () -> ParseResult ()
forall a b. (a -> b) -> a -> b
$
        String -> ParseResult ()
warning (String -> ParseResult ()) -> String -> ParseResult ()
forall a b. (a -> b) -> a -> b
$
          String
"'root-keys' for repository "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ RepoName -> String
forall a. Show a => a -> String
show (RemoteRepo -> RepoName
remoteRepoName RemoteRepo
repo)
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" non-empty, but 'secure' not set to True."

      Either LocalRepo RemoteRepo
-> ParseResult (Either LocalRepo RemoteRepo)
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either LocalRepo RemoteRepo
 -> ParseResult (Either LocalRepo RemoteRepo))
-> Either LocalRepo RemoteRepo
-> ParseResult (Either LocalRepo RemoteRepo)
forall a b. (a -> b) -> a -> b
$ RemoteRepo -> Either LocalRepo RemoteRepo
forall a b. b -> Either a b
Right RemoteRepo
repo

showConfig :: SavedConfig -> String
showConfig :: SavedConfig -> String
showConfig = SavedConfig -> SavedConfig -> String
showConfigWithComments SavedConfig
forall a. Monoid a => a
mempty

showConfigWithComments :: SavedConfig -> SavedConfig -> String
showConfigWithComments :: SavedConfig -> SavedConfig -> String
showConfigWithComments SavedConfig
comment SavedConfig
vals =
  Doc -> String
Disp.render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$
    case ((RemoteRepo, RemoteRepo) -> Doc)
-> [(RemoteRepo, RemoteRepo)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      ((RemoteRepo -> RemoteRepo -> Doc)
-> (RemoteRepo, RemoteRepo) -> Doc
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry RemoteRepo -> RemoteRepo -> Doc
ppRemoteRepoSection)
      ([RemoteRepo] -> [RemoteRepo] -> [(RemoteRepo, RemoteRepo)]
forall a b. [a] -> [b] -> [(a, b)]
zip (SavedConfig -> [RemoteRepo]
getRemoteRepos SavedConfig
comment) (SavedConfig -> [RemoteRepo]
getRemoteRepos SavedConfig
vals)) of
      [] -> String -> Doc
Disp.text String
""
      (Doc
x : [Doc]
xs) -> (Doc -> Doc -> Doc) -> Doc -> [Doc] -> Doc
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Doc
r Doc
r' -> Doc
r Doc -> Doc -> Doc
$+$ String -> Doc
Disp.text String
"" Doc -> Doc -> Doc
$+$ Doc
r') Doc
x [Doc]
xs
      Doc -> Doc -> Doc
$+$ String -> Doc
Disp.text String
""
      Doc -> Doc -> Doc
$+$ [FieldDescr SavedConfig] -> Maybe SavedConfig -> SavedConfig -> Doc
forall a. [FieldDescr a] -> Maybe a -> a -> Doc
ppFields
        ([FieldDescr SavedConfig] -> [FieldDescr SavedConfig]
forall {a}. [FieldDescr a] -> [FieldDescr a]
skipSomeFields (ConstraintSource -> [FieldDescr SavedConfig]
configFieldDescriptions ConstraintSource
ConstraintSourceUnknown))
        Maybe SavedConfig
mcomment
        SavedConfig
vals
      Doc -> Doc -> Doc
$+$ String -> Doc
Disp.text String
""
      Doc -> Doc -> Doc
$+$ String
-> String
-> [FieldDescr HaddockFlags]
-> Maybe HaddockFlags
-> HaddockFlags
-> Doc
forall a. String -> String -> [FieldDescr a] -> Maybe a -> a -> Doc
ppSection
        String
"haddock"
        String
""
        [FieldDescr HaddockFlags]
haddockFlagsFields
        ((SavedConfig -> HaddockFlags)
-> Maybe SavedConfig -> Maybe HaddockFlags
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SavedConfig -> HaddockFlags
savedHaddockFlags Maybe SavedConfig
mcomment)
        (SavedConfig -> HaddockFlags
savedHaddockFlags SavedConfig
vals)
      Doc -> Doc -> Doc
$+$ String -> Doc
Disp.text String
""
      Doc -> Doc -> Doc
$+$ String
-> String
-> [FieldDescr InitFlags]
-> Maybe InitFlags
-> InitFlags
-> Doc
forall a. String -> String -> [FieldDescr a] -> Maybe a -> a -> Doc
ppSection
        String
"init"
        String
""
        [FieldDescr InitFlags]
initFlagsFields
        ((SavedConfig -> InitFlags) -> Maybe SavedConfig -> Maybe InitFlags
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SavedConfig -> InitFlags
savedInitFlags Maybe SavedConfig
mcomment)
        (SavedConfig -> InitFlags
savedInitFlags SavedConfig
vals)
      Doc -> Doc -> Doc
$+$ String -> Doc
Disp.text String
""
      Doc -> Doc -> Doc
$+$ String -> (SavedConfig -> InstallDirs (Flag PathTemplate)) -> Doc
installDirsSection String
"user" SavedConfig -> InstallDirs (Flag PathTemplate)
savedUserInstallDirs
      Doc -> Doc -> Doc
$+$ String -> Doc
Disp.text String
""
      Doc -> Doc -> Doc
$+$ String -> (SavedConfig -> InstallDirs (Flag PathTemplate)) -> Doc
installDirsSection String
"global" SavedConfig -> InstallDirs (Flag PathTemplate)
savedGlobalInstallDirs
      Doc -> Doc -> Doc
$+$ String -> Doc
Disp.text String
""
      Doc -> Doc -> Doc
$+$ String
-> [FieldDescr [(String, String)]]
-> (ConfigFlags -> [(String, String)])
-> Doc
forall {a}. String -> [FieldDescr a] -> (ConfigFlags -> a) -> Doc
configFlagsSection
        String
"program-locations"
        [FieldDescr [(String, String)]]
withProgramsFields
        ConfigFlags -> [(String, String)]
configProgramPaths
      Doc -> Doc -> Doc
$+$ String -> Doc
Disp.text String
""
      Doc -> Doc -> Doc
$+$ String
-> [FieldDescr [(String, [String])]]
-> (ConfigFlags -> [(String, [String])])
-> Doc
forall {a}. String -> [FieldDescr a] -> (ConfigFlags -> a) -> Doc
configFlagsSection
        String
"program-default-options"
        [FieldDescr [(String, [String])]]
withProgramOptionsFields
        ConfigFlags -> [(String, [String])]
configProgramArgs
  where
    getRemoteRepos :: SavedConfig -> [RemoteRepo]
getRemoteRepos = NubList RemoteRepo -> [RemoteRepo]
forall a. NubList a -> [a]
fromNubList (NubList RemoteRepo -> [RemoteRepo])
-> (SavedConfig -> NubList RemoteRepo)
-> SavedConfig
-> [RemoteRepo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalFlags -> NubList RemoteRepo
globalRemoteRepos (GlobalFlags -> NubList RemoteRepo)
-> (SavedConfig -> GlobalFlags)
-> SavedConfig
-> NubList RemoteRepo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> GlobalFlags
savedGlobalFlags
    mcomment :: Maybe SavedConfig
mcomment = SavedConfig -> Maybe SavedConfig
forall a. a -> Maybe a
Just SavedConfig
comment
    installDirsSection :: String -> (SavedConfig -> InstallDirs (Flag PathTemplate)) -> Doc
installDirsSection String
name SavedConfig -> InstallDirs (Flag PathTemplate)
field =
      String
-> String
-> [FieldDescr (InstallDirs (Flag PathTemplate))]
-> Maybe (InstallDirs (Flag PathTemplate))
-> InstallDirs (Flag PathTemplate)
-> Doc
forall a. String -> String -> [FieldDescr a] -> Maybe a -> a -> Doc
ppSection
        String
"install-dirs"
        String
name
        [FieldDescr (InstallDirs (Flag PathTemplate))]
installDirsFields
        ((SavedConfig -> InstallDirs (Flag PathTemplate))
-> Maybe SavedConfig -> Maybe (InstallDirs (Flag PathTemplate))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SavedConfig -> InstallDirs (Flag PathTemplate)
field Maybe SavedConfig
mcomment)
        (SavedConfig -> InstallDirs (Flag PathTemplate)
field SavedConfig
vals)
    configFlagsSection :: String -> [FieldDescr a] -> (ConfigFlags -> a) -> Doc
configFlagsSection String
name [FieldDescr a]
fields ConfigFlags -> a
field =
      String -> String -> [FieldDescr a] -> Maybe a -> a -> Doc
forall a. String -> String -> [FieldDescr a] -> Maybe a -> a -> Doc
ppSection
        String
name
        String
""
        [FieldDescr a]
fields
        ((SavedConfig -> a) -> Maybe SavedConfig -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ConfigFlags -> a
field (ConfigFlags -> a)
-> (SavedConfig -> ConfigFlags) -> SavedConfig -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> ConfigFlags
savedConfigureFlags) Maybe SavedConfig
mcomment)
        ((ConfigFlags -> a
field (ConfigFlags -> a)
-> (SavedConfig -> ConfigFlags) -> SavedConfig -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> ConfigFlags
savedConfigureFlags) SavedConfig
vals)

    -- skip fields based on field name.  currently only skips "remote-repo",
    -- because that is rendered as a section.  (see 'ppRemoteRepoSection'.)
    skipSomeFields :: [FieldDescr a] -> [FieldDescr a]
skipSomeFields = (FieldDescr a -> Bool) -> [FieldDescr a] -> [FieldDescr a]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"remote-repo") (String -> Bool)
-> (FieldDescr a -> String) -> FieldDescr a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDescr a -> String
forall a. FieldDescr a -> String
fieldName)

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

ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc
ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc
ppRemoteRepoSection RemoteRepo
def RemoteRepo
vals =
  String
-> String
-> [FieldDescr RemoteRepo]
-> Maybe RemoteRepo
-> RemoteRepo
-> Doc
forall a. String -> String -> [FieldDescr a] -> Maybe a -> a -> Doc
ppSection
    String
"repository"
    (RepoName -> String
unRepoName (RemoteRepo -> RepoName
remoteRepoName RemoteRepo
vals))
    [FieldDescr RemoteRepo]
remoteRepoFields
    (RemoteRepo -> Maybe RemoteRepo
forall a. a -> Maybe a
Just RemoteRepo
def)
    RemoteRepo
vals

remoteRepoFields :: [FieldDescr RemoteRepo]
remoteRepoFields :: [FieldDescr RemoteRepo]
remoteRepoFields =
  [ String
-> (URI -> Doc)
-> ReadP URI URI
-> (RemoteRepo -> URI)
-> (URI -> RemoteRepo -> RemoteRepo)
-> FieldDescr RemoteRepo
forall a b.
String
-> (a -> Doc)
-> ReadP a a
-> (b -> a)
-> (a -> b -> b)
-> FieldDescr b
simpleField
      String
"url"
      (String -> Doc
text (String -> Doc) -> (URI -> String) -> URI -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> String
forall a. Show a => a -> String
show)
      (ReadP URI String
forall r. ReadP r String
parseTokenQ ReadP URI String -> (String -> ReadP URI URI) -> ReadP URI URI
forall a b.
Parser URI Char a -> (a -> Parser URI Char b) -> Parser URI Char b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> ReadP URI URI
forall {m :: * -> *}. MonadFail m => String -> m URI
parseURI')
      RemoteRepo -> URI
remoteRepoURI
      (\URI
x RemoteRepo
repo -> RemoteRepo
repo{remoteRepoURI = x})
  , String
-> (Maybe Bool -> Doc)
-> ParsecParser (Maybe Bool)
-> (RemoteRepo -> Maybe Bool)
-> (Maybe Bool -> RemoteRepo -> RemoteRepo)
-> FieldDescr RemoteRepo
forall a b.
String
-> (a -> Doc)
-> ParsecParser a
-> (b -> a)
-> (a -> b -> b)
-> FieldDescr b
simpleFieldParsec
      String
"secure"
      Maybe Bool -> Doc
showSecure
      (Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool)
-> ParsecParser Bool -> ParsecParser (Maybe Bool)
forall a b. (a -> b) -> ParsecParser a -> ParsecParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ParsecParser Bool
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m Bool
parsec)
      RemoteRepo -> Maybe Bool
remoteRepoSecure
      (\Maybe Bool
x RemoteRepo
repo -> RemoteRepo
repo{remoteRepoSecure = x})
  , String
-> (String -> Doc)
-> ReadP [String] String
-> (RemoteRepo -> [String])
-> ([String] -> RemoteRepo -> RemoteRepo)
-> FieldDescr RemoteRepo
forall a b.
String
-> (a -> Doc)
-> ReadP [a] a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
listField
      String
"root-keys"
      String -> Doc
text
      ReadP [String] String
forall r. ReadP r String
parseTokenQ
      RemoteRepo -> [String]
remoteRepoRootKeys
      (\[String]
x RemoteRepo
repo -> RemoteRepo
repo{remoteRepoRootKeys = x})
  , String
-> (Int -> Doc)
-> ParsecParser Int
-> (RemoteRepo -> Int)
-> (Int -> RemoteRepo -> RemoteRepo)
-> FieldDescr RemoteRepo
forall a b.
String
-> (a -> Doc)
-> ParsecParser a
-> (b -> a)
-> (a -> b -> b)
-> FieldDescr b
simpleFieldParsec
      String
"key-threshold"
      Int -> Doc
forall {a}. (Eq a, Num a, Show a) => a -> Doc
showThreshold
      ParsecParser Int
forall (m :: * -> *) a. (CharParsing m, Integral a) => m a
P.integral
      RemoteRepo -> Int
remoteRepoKeyThreshold
      (\Int
x RemoteRepo
repo -> RemoteRepo
repo{remoteRepoKeyThreshold = x})
  ]
  where
    parseURI' :: String -> m URI
parseURI' String
uriString =
      case String -> Maybe URI
parseURI String
uriString of
        Maybe URI
Nothing -> String -> m URI
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m URI) -> String -> m URI
forall a b. (a -> b) -> a -> b
$ String
"remote-repo: no parse on " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
uriString
        Just URI
uri -> URI -> m URI
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return URI
uri

    showSecure :: Maybe Bool -> Doc
showSecure Maybe Bool
Nothing = Doc
forall a. Monoid a => a
mempty -- default 'secure' setting
    showSecure (Just Bool
True) = String -> Doc
text String
"True" -- user explicitly enabled it
    showSecure (Just Bool
False) = String -> Doc
text String
"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 :: a -> Doc
showThreshold a
0 = Doc
forall a. Monoid a => a
mempty
    showThreshold a
t = String -> Doc
text (a -> String
forall a. Show a => a -> String
show a
t)

-- | Fields for the 'haddock' section.
haddockFlagsFields :: [FieldDescr HaddockFlags]
haddockFlagsFields :: [FieldDescr HaddockFlags]
haddockFlagsFields =
  [ FieldDescr HaddockFlags
field
  | OptionField HaddockFlags
opt <- ShowOrParseArgs -> [OptionField HaddockFlags]
haddockOptions ShowOrParseArgs
ParseArgs
  , let field :: FieldDescr HaddockFlags
field = OptionField HaddockFlags -> FieldDescr HaddockFlags
forall a. OptionField a -> FieldDescr a
viewAsFieldDescr OptionField HaddockFlags
opt
        name :: String
name = FieldDescr HaddockFlags -> String
forall a. FieldDescr a -> String
fieldName FieldDescr HaddockFlags
field
  , String
name String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
exclusions
  ]
  where
    exclusions :: [String]
exclusions = [String
"verbose", String
"builddir", String
"for-hackage"]

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

-- | Fields for the 'program-locations' section.
withProgramsFields :: [FieldDescr [(String, FilePath)]]
withProgramsFields :: [FieldDescr [(String, String)]]
withProgramsFields =
  (OptionField [(String, String)] -> FieldDescr [(String, String)])
-> [OptionField [(String, String)]]
-> [FieldDescr [(String, String)]]
forall a b. (a -> b) -> [a] -> [b]
map OptionField [(String, String)] -> FieldDescr [(String, String)]
forall a. OptionField a -> FieldDescr a
viewAsFieldDescr ([OptionField [(String, String)]]
 -> [FieldDescr [(String, String)]])
-> [OptionField [(String, String)]]
-> [FieldDescr [(String, String)]]
forall a b. (a -> b) -> a -> b
$
    (String -> String)
-> ProgramDb
-> ShowOrParseArgs
-> ([(String, String)] -> [(String, String)])
-> ([(String, String)] -> [(String, String)] -> [(String, String)])
-> [OptionField [(String, String)]]
forall flags.
(String -> String)
-> ProgramDb
-> ShowOrParseArgs
-> (flags -> [(String, String)])
-> ([(String, String)] -> flags -> flags)
-> [OptionField flags]
programDbPaths'
      (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-location")
      ProgramDb
defaultProgramDb
      ShowOrParseArgs
ParseArgs
      [(String, String)] -> [(String, String)]
forall a. a -> a
id
      [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
(++)

-- | Fields for the 'program-default-options' section.
withProgramOptionsFields :: [FieldDescr [(String, [String])]]
withProgramOptionsFields :: [FieldDescr [(String, [String])]]
withProgramOptionsFields =
  (OptionField [(String, [String])]
 -> FieldDescr [(String, [String])])
-> [OptionField [(String, [String])]]
-> [FieldDescr [(String, [String])]]
forall a b. (a -> b) -> [a] -> [b]
map OptionField [(String, [String])] -> FieldDescr [(String, [String])]
forall a. OptionField a -> FieldDescr a
viewAsFieldDescr ([OptionField [(String, [String])]]
 -> [FieldDescr [(String, [String])]])
-> [OptionField [(String, [String])]]
-> [FieldDescr [(String, [String])]]
forall a b. (a -> b) -> a -> b
$
    ProgramDb
-> ShowOrParseArgs
-> ([(String, [String])] -> [(String, [String])])
-> ([(String, [String])]
    -> [(String, [String])] -> [(String, [String])])
-> [OptionField [(String, [String])]]
forall flags.
ProgramDb
-> ShowOrParseArgs
-> (flags -> [(String, [String])])
-> ([(String, [String])] -> flags -> flags)
-> [OptionField flags]
programDbOptions ProgramDb
defaultProgramDb ShowOrParseArgs
ParseArgs [(String, [String])] -> [(String, [String])]
forall a. a -> a
id [(String, [String])]
-> [(String, [String])] -> [(String, [String])]
forall a. [a] -> [a] -> [a]
(++)

parseExtraLines :: Verbosity -> [String] -> IO SavedConfig
parseExtraLines :: Verbosity -> [String] -> IO SavedConfig
parseExtraLines Verbosity
verbosity [String]
extraLines =
  case ConstraintSource
-> SavedConfig -> ByteString -> ParseResult SavedConfig
parseConfig
    (String -> ConstraintSource
ConstraintSourceMainConfig String
"additional lines")
    SavedConfig
forall a. Monoid a => a
mempty
    (String -> ByteString
toUTF8BS ([String] -> String
unlines [String]
extraLines)) of
    ParseFailed PError
err ->
      let (Maybe Int
line, String
msg) = PError -> (Maybe Int, String)
locatedErrorMsg PError
err
          errLineNo :: String
errLineNo = String -> (Int -> String) -> Maybe Int -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Int
n -> Char
':' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
n) Maybe Int
line
       in Verbosity -> CabalInstallException -> IO SavedConfig
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO SavedConfig)
-> CabalInstallException -> IO SavedConfig
forall a b. (a -> b) -> a -> b
$ String -> String -> CabalInstallException
ParseExtraLinesFailedErr String
msg String
errLineNo
    ParseOk [] SavedConfig
r -> SavedConfig -> IO SavedConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SavedConfig
r
    ParseOk [PWarning]
ws SavedConfig
_ ->
      Verbosity -> CabalInstallException -> IO SavedConfig
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO SavedConfig)
-> CabalInstallException -> IO SavedConfig
forall a b. (a -> b) -> a -> b
$ [PWarning] -> CabalInstallException
ParseExtraLinesOkError [PWarning]
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 -> [String] -> IO [String]
userConfigDiff Verbosity
verbosity GlobalFlags
globalFlags [String]
extraLines = do
  SavedConfig
userConfig <- Verbosity -> Flag String -> IO SavedConfig
loadRawConfig Verbosity
normal (GlobalFlags -> Flag String
globalConfigFile GlobalFlags
globalFlags)
  SavedConfig
extraConfig <- Verbosity -> [String] -> IO SavedConfig
parseExtraLines Verbosity
verbosity [String]
extraLines
  SavedConfig
testConfig <- IO SavedConfig
initialSavedConfig
  [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$
    [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String])
-> (Map String (Maybe String, Maybe String) -> [String])
-> Map String (Maybe String, Maybe String)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String] -> (String, (Maybe String, Maybe String)) -> [String])
-> [String] -> [(String, (Maybe String, Maybe String))] -> [String]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [String] -> (String, (Maybe String, Maybe String)) -> [String]
createDiff [] ([(String, (Maybe String, Maybe String))] -> [String])
-> (Map String (Maybe String, Maybe String)
    -> [(String, (Maybe String, Maybe String))])
-> Map String (Maybe String, Maybe String)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String (Maybe String, Maybe String)
-> [(String, (Maybe String, Maybe String))]
forall k a. Map k a -> [(k, a)]
M.toList (Map String (Maybe String, Maybe String) -> [String])
-> Map String (Maybe String, Maybe String) -> [String]
forall a b. (a -> b) -> a -> b
$
      ((Maybe String, Maybe String)
 -> (Maybe String, Maybe String) -> (Maybe String, Maybe String))
-> Map String (Maybe String, Maybe String)
-> Map String (Maybe String, Maybe String)
-> Map String (Maybe String, Maybe String)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith
        (Maybe String, Maybe String)
-> (Maybe String, Maybe String) -> (Maybe String, Maybe String)
forall {a} {a}.
(Show a, Show a) =>
(Maybe a, Maybe a) -> (Maybe a, Maybe a) -> (Maybe a, Maybe a)
combine
        ([(String, (Maybe String, Maybe String))]
-> Map String (Maybe String, Maybe String)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(String, (Maybe String, Maybe String))]
 -> Map String (Maybe String, Maybe String))
-> ([(String, String)] -> [(String, (Maybe String, Maybe String))])
-> [(String, String)]
-> Map String (Maybe String, Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> (String, (Maybe String, Maybe String)))
-> [(String, String)] -> [(String, (Maybe String, Maybe String))]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> (String, (Maybe String, Maybe String))
forall {a} {a} {a}. (a, a) -> (a, (Maybe a, Maybe a))
justFst ([(String, String)] -> Map String (Maybe String, Maybe String))
-> [(String, String)] -> Map String (Maybe String, Maybe String)
forall a b. (a -> b) -> a -> b
$ SavedConfig -> [(String, String)]
filterShow SavedConfig
testConfig)
        ([(String, (Maybe String, Maybe String))]
-> Map String (Maybe String, Maybe String)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(String, (Maybe String, Maybe String))]
 -> Map String (Maybe String, Maybe String))
-> ([(String, String)] -> [(String, (Maybe String, Maybe String))])
-> [(String, String)]
-> Map String (Maybe String, Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> (String, (Maybe String, Maybe String)))
-> [(String, String)] -> [(String, (Maybe String, Maybe String))]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> (String, (Maybe String, Maybe String))
forall {a} {a} {a}. (a, a) -> (a, (Maybe a, Maybe a))
justSnd ([(String, String)] -> Map String (Maybe String, Maybe String))
-> [(String, String)] -> Map String (Maybe String, Maybe String)
forall a b. (a -> b) -> a -> b
$ SavedConfig -> [(String, String)]
filterShow (SavedConfig
userConfig SavedConfig -> SavedConfig -> SavedConfig
forall a. Monoid a => a -> a -> a
`mappend` SavedConfig
extraConfig))
  where
    justFst :: (a, a) -> (a, (Maybe a, Maybe a))
justFst (a
a, a
b) = (a
a, (a -> Maybe a
forall a. a -> Maybe a
Just a
b, Maybe a
forall a. Maybe a
Nothing))
    justSnd :: (a, a) -> (a, (Maybe a, Maybe a))
justSnd (a
a, a
b) = (a
a, (Maybe a
forall a. Maybe a
Nothing, a -> Maybe a
forall a. a -> Maybe a
Just a
b))

    combine :: (Maybe a, Maybe a) -> (Maybe a, Maybe a) -> (Maybe a, Maybe a)
combine (Maybe a
Nothing, Just a
b) (Just a
a, Maybe a
Nothing) = (a -> Maybe a
forall a. a -> Maybe a
Just a
a, a -> Maybe a
forall a. a -> Maybe a
Just a
b)
    combine (Just a
a, Maybe a
Nothing) (Maybe a
Nothing, Just a
b) = (a -> Maybe a
forall a. a -> Maybe a
Just a
a, a -> Maybe a
forall a. a -> Maybe a
Just a
b)
    combine (Maybe a, Maybe a)
x (Maybe a, Maybe a)
y =
      String -> (Maybe a, Maybe a)
forall a. HasCallStack => String -> a
error (String -> (Maybe a, Maybe a)) -> String -> (Maybe a, Maybe a)
forall a b. (a -> b) -> a -> b
$
        String
"Can't happen : userConfigDiff "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Maybe a, Maybe a) -> String
forall a. Show a => a -> String
show (Maybe a, Maybe a)
x
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Maybe a, Maybe a) -> String
forall a. Show a => a -> String
show (Maybe a, Maybe a)
y

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

    filterShow :: SavedConfig -> [(String, String)]
    filterShow :: SavedConfig -> [(String, String)]
filterShow SavedConfig
cfg =
      (String -> (String, String)) -> [String] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map String -> (String, String)
keyValueSplit
        ([String] -> [(String, String)])
-> (String -> [String]) -> String -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\String
s -> Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s) Bool -> Bool -> Bool
&& Char
':' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
s)
        ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
nonComment
        ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
        (String -> [(String, String)]) -> String -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ SavedConfig -> String
showConfig SavedConfig
cfg

    nonComment :: String -> String
nonComment [] = []
    nonComment (Char
'-' : Char
'-' : String
_) = []
    nonComment (Char
x : String
xs) = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
nonComment String
xs

    topAndTail :: String -> String
topAndTail = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace

    keyValueSplit :: String -> (String, String)
keyValueSplit String
s =
      let (String
left, String
right) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') String
s
       in (String -> String
topAndTail String
left, String -> String
topAndTail (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 String
right))

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