cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs

   1 {-# LANGUAGE RecordWildCards, NamedFieldPuns, DeriveGeneric, ConstraintKinds, FlexibleInstances #-}
   2
   3 -- | Project configuration, implementation in terms of legacy types.
   4 --
   5 module Distribution.Client.ProjectConfig.Legacy (
   6
   7    -- Project config skeletons
   8     ProjectConfigSkeleton,
   9     parseProjectSkeleton,
  10     instantiateProjectConfigSkeletonFetchingCompiler,
  11     instantiateProjectConfigSkeletonWithCompiler,
  12     singletonProjectConfigSkeleton,
  13     projectSkeletonImports,
  14
  15     -- * Project config in terms of legacy types
  16     LegacyProjectConfig,
  17     parseLegacyProjectConfig,
  18     showLegacyProjectConfig,
  19
  20     -- * Conversion to and from legacy config types
  21     commandLineFlagsToProjectConfig,
  22     convertLegacyProjectConfig,
  23     convertLegacyGlobalConfig,
  24     convertToLegacyProjectConfig,
  25
  26     -- * Internals, just for tests
  27     parsePackageLocationTokenQ,
  28     renderPackageLocationToken
  29   ) where
  30
  31 import Distribution.Client.Compat.Prelude
  32
  33 import Distribution.Types.Flag (parsecFlagAssignment, FlagName)
  34
  35 import Distribution.Client.ProjectConfig.Types
  36 import Distribution.Client.Types.RepoName (RepoName (..), unRepoName)
  37 import Distribution.Client.Types.Repo (RemoteRepo(..), LocalRepo (..), emptyRemoteRepo)
  38 import Distribution.Client.Types.AllowNewer (AllowNewer(..), AllowOlder(..))
  39 import Distribution.Client.Types.SourceRepo (sourceRepositoryPackageGrammar, SourceRepoList)
  40
  41 import Distribution.Client.Config
  42          ( SavedConfig(..), remoteRepoFields, postProcessRepo )
  43
  44 import Distribution.Client.CmdInstall.ClientInstallFlags
  45          ( ClientInstallFlags(..), defaultClientInstallFlags
  46          , clientInstallOptions )
  47
  48 import Distribution.Compat.Lens (view, toListOf)
  49
  50 import Distribution.Solver.Types.ConstraintSource
  51
  52 import Distribution.FieldGrammar
  53 import Distribution.Package
  54 import Distribution.Types.SourceRepo (RepoType)
  55 import Distribution.Types.CondTree
  56          ( CondTree (..), CondBranch (..), mapTreeConds, traverseCondTreeC, traverseCondTreeV, ignoreConditions )
  57 import Distribution.PackageDescription
  58          ( dispFlagAssignment, Condition (..), ConfVar (..), FlagAssignment )
  59 import Distribution.PackageDescription.Configuration (simplifyWithSysParams)
  60 import Distribution.Simple.Compiler
  61          ( OptimisationLevel(..), DebugInfoLevel(..), CompilerInfo(..) )
  62 import Distribution.Simple.InstallDirs ( CopyDest (NoCopyDest) )
  63 import Distribution.Simple.Setup
  64          ( Flag(..), toFlag, fromFlagOrDefault
  65          , ConfigFlags(..), configureOptions
  66          , HaddockFlags(..), haddockOptions, defaultHaddockFlags
  67          , TestFlags(..), testOptions', defaultTestFlags
  68          , BenchmarkFlags(..), benchmarkOptions', defaultBenchmarkFlags
  69          , programDbPaths', splitArgs, DumpBuildInfo (NoDumpBuildInfo, DumpBuildInfo)
  70          , readPackageDb, showPackageDb
  71          )
  72 import Distribution.Client.NixStyleOptions (NixStyleFlags (..))
  73 import Distribution.Client.ProjectFlags (ProjectFlags (..), projectFlagsOptions, defaultProjectFlags)
  74 import Distribution.Client.Setup
  75          ( GlobalFlags(..), globalCommand
  76          , ConfigExFlags(..), configureExOptions, defaultConfigExFlags
  77          , InstallFlags(..), installOptions, defaultInstallFlags )
  78 import Distribution.Simple.Program
  79          ( programName, knownPrograms )
  80 import Distribution.Simple.Program.Db
  81          ( ProgramDb, defaultProgramDb )
  82 import Distribution.Simple.Utils
  83          ( lowercase )
  84 import Distribution.Utils.NubList
  85          ( toNubList, fromNubList, overNubList )
  86 import Distribution.Simple.LocalBuildInfo
  87          ( toPathTemplate, fromPathTemplate )
  88
  89 import qualified Distribution.Deprecated.ReadP as Parse
  90 import Distribution.Deprecated.ReadP
  91          ( ReadP, (+++) )
  92 import qualified Text.PrettyPrint as Disp
  93 import Text.PrettyPrint
  94          ( Doc, ($+$) )
  95 import qualified Distribution.Deprecated.ParseUtils as ParseUtils
  96 import Distribution.Deprecated.ParseUtils
  97          ( ParseResult(..), PError(..), syntaxError, PWarning(..)
  98          , commaNewLineListFieldParsec, newLineListField, parseTokenQ
  99          , parseHaskellString, showToken
 100          , simpleFieldParsec, parseFail
 101          )
 102 import Distribution.Client.ParseUtils
 103 import Distribution.Simple.Command
 104          ( CommandUI(commandOptions), ShowOrParseArgs(..)
 105          , OptionField, option, reqArg' )
 106 import Distribution.Types.PackageVersionConstraint
 107          ( PackageVersionConstraint )
 108 import Distribution.Parsec (ParsecParser, parsecToken)
 109 import Distribution.System (OS, Arch)
 110
 111 import qualified Data.Map as Map
 112 import qualified Data.Set as Set
 113 import qualified Data.ByteString.Char8 as BS
 114
 115 import Network.URI (URI (..), parseURI)
 116
 117 import Distribution.Fields.ConfVar (parseConditionConfVarFromClause)
 118
 119 import Distribution.Client.HttpUtils
 120 import System.FilePath ((</>), isPathSeparator, makeValid)
 121 import System.Directory (createDirectoryIfMissing)
 122
 123
 124
 125
 126 ------------------------------------------------------------------
 127 -- Handle extended project config files with conditionals and imports.
 128 --
 129
 130 -- | ProjectConfigSkeleton is a tree of conditional blocks and imports wrapping a config. It can be finalized by providing the conditional resolution info
 131 -- and then resolving and downloading the imports
 132 type ProjectConfigSkeleton = CondTree ConfVar [ProjectConfigImport] ProjectConfig
 133 type ProjectConfigImport = String
 134
 135
 136 singletonProjectConfigSkeleton :: ProjectConfig -> ProjectConfigSkeleton
 137 singletonProjectConfigSkeleton x = CondNode x mempty mempty
 138
 139 instantiateProjectConfigSkeletonFetchingCompiler :: Monad m =>  m (OS, Arch, CompilerInfo) -> FlagAssignment -> ProjectConfigSkeleton -> m ProjectConfig
 140 instantiateProjectConfigSkeletonFetchingCompiler fetch flags skel
 141    | null (toListOf traverseCondTreeV skel) = pure $ fst (ignoreConditions skel)
 142    | otherwise = do
 143        (os, arch, impl) <- fetch
 144        pure $ instantiateProjectConfigSkeletonWithCompiler os arch impl flags skel
 145
 146
 147 instantiateProjectConfigSkeletonWithCompiler :: OS -> Arch -> CompilerInfo -> FlagAssignment -> ProjectConfigSkeleton -> ProjectConfig
 148 instantiateProjectConfigSkeletonWithCompiler os arch impl _flags skel = go $ mapTreeConds (fst . simplifyWithSysParams os arch impl) skel
 149     where
 150         go :: CondTree
 151                FlagName
 152                [ProjectConfigImport]
 153                ProjectConfig
 154              -> ProjectConfig
 155         go (CondNode l _imps ts) =
 156            let branches = concatMap processBranch ts
 157            in l <> mconcat branches
 158         processBranch (CondBranch cnd t mf) = case cnd of
 159            (Lit True) ->  [go t]
 160            (Lit False) -> maybe ([]) ((:[]) . go) mf
 161            _ -> error $ "unable to process condition: " ++ show cnd -- TODO it would be nice if there were a pretty printer
 162
 163 projectSkeletonImports :: ProjectConfigSkeleton -> [ProjectConfigImport]
 164 projectSkeletonImports = view traverseCondTreeC
 165
 166 parseProjectSkeleton :: FilePath -> HttpTransport -> Verbosity -> [ProjectConfigImport] -> FilePath -> BS.ByteString -> IO (ParseResult ProjectConfigSkeleton)
 167 parseProjectSkeleton cacheDir httpTransport verbosity seenImports source bs = (sanityWalkPCS False =<<) <$> liftPR (go []) (ParseUtils.readFields bs)
 168   where
 169     go :: [ParseUtils.Field] -> [ParseUtils.Field] -> IO (ParseResult ProjectConfigSkeleton)
 170     go acc (x:xs) = case x of
 171          (ParseUtils.F l "import" importLoc) ->
 172             if importLoc `elem` seenImports
 173               then pure . parseFail $ ParseUtils.FromString ("cyclical import of " ++ importLoc) (Just l)
 174               else do
 175                 let fs = fmap (\z -> CondNode z [importLoc] mempty) $ fieldsToConfig (reverse acc)
 176                 res <- parseProjectSkeleton cacheDir httpTransport verbosity (importLoc : seenImports) importLoc =<< fetchImportConfig importLoc
 177                 rest <- go [] xs
 178                 pure . fmap mconcat . sequence $ [fs, res, rest]
 179          (ParseUtils.Section l "if" p xs') -> do
 180                 subpcs <- go [] xs'
 181                 let fs = fmap singletonProjectConfigSkeleton $ fieldsToConfig (reverse acc)
 182                 (elseClauses, rest) <- parseElseClauses xs
 183                 let condNode =  (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e]) <$>
 184                       -- we rewrap as as a section so the readFields lexer of the conditional parser doesn't get confused
 185                       adaptParseError l (parseConditionConfVarFromClause . BS.pack $ "if(" <> p <> ")") <*>
 186                       subpcs <*>
 187                       elseClauses
 188                 pure . fmap mconcat . sequence $ [fs, condNode, rest]
 189          _ -> go (x:acc) xs
 190     go acc [] = pure . fmap singletonProjectConfigSkeleton . fieldsToConfig $ reverse acc
 191
 192     parseElseClauses :: [ParseUtils.Field] -> IO (ParseResult (Maybe ProjectConfigSkeleton), ParseResult ProjectConfigSkeleton)
 193     parseElseClauses x = case x of
 194          (ParseUtils.Section _l "else" _p xs':xs) -> do
 195                subpcs <- go [] xs'
 196                rest <- go [] xs
 197                pure (Just <$> subpcs, rest)
 198          (ParseUtils.Section l "elif" p xs':xs) -> do
 199                subpcs <- go [] xs'
 200                (elseClauses, rest) <- parseElseClauses xs
 201                let condNode = (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e]) <$>
 202                                   adaptParseError l (parseConditionConfVarFromClause . BS.pack $ "else("<> p <> ")") <*>
 203                                   subpcs <*>
 204                                   elseClauses
 205                pure (Just <$> condNode, rest)
 206          _ -> (\r -> (pure Nothing,r)) <$> go [] x
 207
 208     fieldsToConfig xs = fmap (addProvenance . convertLegacyProjectConfig) $ parseLegacyProjectConfigFields source xs
 209     addProvenance x = x {projectConfigProvenance = Set.singleton (Explicit source)}
 210
 211     adaptParseError _ (Right x) = pure x
 212     adaptParseError l (Left e) = parseFail $ ParseUtils.FromString (show e) (Just l)
 213
 214     liftPR :: (a -> IO (ParseResult b)) -> ParseResult a -> IO (ParseResult b)
 215     liftPR f (ParseOk ws x) = addWarnings <$> f x
 216        where addWarnings (ParseOk ws' x') = ParseOk (ws' ++ ws) x'
 217              addWarnings x' = x'
 218     liftPR _ (ParseFailed e) = pure $ ParseFailed e
 219
 220     fetchImportConfig :: ProjectConfigImport -> IO BS.ByteString
 221     fetchImportConfig pci = case parseURI pci of
 222          Just uri -> do
 223             let fp = cacheDir </> map (\x -> if isPathSeparator x then '_' else x) (makeValid $ show uri)
 224             createDirectoryIfMissing True cacheDir
 225             _ <- downloadURI httpTransport verbosity uri fp
 226             BS.readFile fp
 227          Nothing -> BS.readFile pci
 228
 229     modifiesCompiler :: ProjectConfig -> Bool
 230     modifiesCompiler pc = isSet projectConfigHcFlavor || isSet projectConfigHcPath || isSet projectConfigHcPkg
 231       where
 232          isSet f = f (projectConfigShared pc) /= NoFlag
 233
 234     sanityWalkPCS :: Bool -> ProjectConfigSkeleton -> ParseResult ProjectConfigSkeleton
 235     sanityWalkPCS underConditional t@(CondNode d _c comps)
 236            | underConditional && modifiesCompiler d = parseFail $ ParseUtils.FromString "Cannot set compiler in a conditional clause of a cabal project file" Nothing
 237            | otherwise = mapM_ sanityWalkBranch comps >> pure t
 238
 239     sanityWalkBranch:: CondBranch ConfVar [ProjectConfigImport] ProjectConfig -> ParseResult ()
 240     sanityWalkBranch (CondBranch _c t f) = traverse (sanityWalkPCS True) f >> sanityWalkPCS True t >> pure ()
 241
 242 ------------------------------------------------------------------
 243 -- Representing the project config file in terms of legacy types
 244 --
 245
 246 -- | We already have parsers\/pretty-printers for almost all the fields in the
 247 -- project config file, but they're in terms of the types used for the command
 248 -- line flags for Setup.hs or cabal commands. We don't want to redefine them
 249 -- all, at least not yet so for the moment we use the parsers at the old types
 250 -- and use conversion functions.
 251 --
 252 -- Ultimately if\/when this project-based approach becomes the default then we
 253 -- can redefine the parsers directly for the new types.
 254 --
 255 data LegacyProjectConfig = LegacyProjectConfig {
 256        legacyPackages          :: [String],
 257        legacyPackagesOptional  :: [String],
 258        legacyPackagesRepo      :: [SourceRepoList],
 259        legacyPackagesNamed     :: [PackageVersionConstraint],
 260
 261        legacySharedConfig      :: LegacySharedConfig,
 262        legacyAllConfig         :: LegacyPackageConfig,
 263        legacyLocalConfig       :: LegacyPackageConfig,
 264        legacySpecificConfig    :: MapMappend PackageName LegacyPackageConfig
 265      } deriving (Show, Generic)
 266
 267 instance Monoid LegacyProjectConfig where
 268   mempty  = gmempty
 269   mappend = (<>)
 270
 271 instance Semigroup LegacyProjectConfig where
 272   (<>) = gmappend
 273
 274 data LegacyPackageConfig = LegacyPackageConfig {
 275        legacyConfigureFlags    :: ConfigFlags,
 276        legacyInstallPkgFlags   :: InstallFlags,
 277        legacyHaddockFlags      :: HaddockFlags,
 278        legacyTestFlags         :: TestFlags,
 279        legacyBenchmarkFlags    :: BenchmarkFlags
 280      } deriving (Show, Generic)
 281
 282 instance Monoid LegacyPackageConfig where
 283   mempty  = gmempty
 284   mappend = (<>)
 285
 286 instance Semigroup LegacyPackageConfig where
 287   (<>) = gmappend
 288
 289 data LegacySharedConfig = LegacySharedConfig {
 290        legacyGlobalFlags       :: GlobalFlags,
 291        legacyConfigureShFlags  :: ConfigFlags,
 292        legacyConfigureExFlags  :: ConfigExFlags,
 293        legacyInstallFlags      :: InstallFlags,
 294        legacyClientInstallFlags:: ClientInstallFlags,
 295        legacyProjectFlags      :: ProjectFlags
 296      } deriving (Show, Generic)
 297
 298 instance Monoid LegacySharedConfig where
 299   mempty  = gmempty
 300   mappend = (<>)
 301
 302 instance Semigroup LegacySharedConfig where
 303   (<>) = gmappend
 304
 305
 306 ------------------------------------------------------------------
 307 -- Converting from and to the legacy types
 308 --
 309
 310 -- | Convert configuration from the @cabal configure@ or @cabal build@ command
 311 -- line into a 'ProjectConfig' value that can combined with configuration from
 312 -- other sources.
 313 --
 314 -- At the moment this uses the legacy command line flag types. See
 315 -- 'LegacyProjectConfig' for an explanation.
 316 --
 317 commandLineFlagsToProjectConfig :: GlobalFlags
 318                                 -> NixStyleFlags a
 319                                 -> ClientInstallFlags
 320                                 -> ProjectConfig
 321 commandLineFlagsToProjectConfig globalFlags NixStyleFlags {..} clientInstallFlags =
 322     mempty {
 323       projectConfigBuildOnly     = convertLegacyBuildOnlyFlags
 324                                      globalFlags configFlags
 325                                      installFlags clientInstallFlags
 326                                      haddockFlags testFlags benchmarkFlags,
 327       projectConfigShared        = convertLegacyAllPackageFlags
 328                                      globalFlags configFlags
 329                                      configExFlags installFlags projectFlags,
 330       projectConfigLocalPackages = localConfig,
 331       projectConfigAllPackages   = allConfig
 332     }
 333   where (localConfig, allConfig) = splitConfig
 334                                  (convertLegacyPerPackageFlags
 335                                     configFlags installFlags
 336                                     haddockFlags testFlags benchmarkFlags)
 337         -- split the package config (from command line arguments) into
 338         -- those applied to all packages and those to local only.
 339         --
 340         -- for now we will just copy over the ProgramPaths/Extra into
 341         -- the AllPackages.  The LocalPackages do not inherit them from
 342         -- AllPackages, and as such need to retain them.
 343         --
 344         -- The general decision rule for what to put into allConfig
 345         -- into localConfig is the following:
 346         --
 347         -- - anything that is host/toolchain/env specific should be applied
 348         --   to all packages, as packagesets have to be host/toolchain/env
 349         --   consistent.
 350         -- - anything else should be in the local config and could potentially
 351         --   be lifted into all-packages vial the `package *` cabal.project
 352         --   section.
 353         --
 354         splitConfig :: PackageConfig -> (PackageConfig, PackageConfig)
 355         splitConfig pc = (pc
 356                          , mempty { packageConfigProgramPaths = packageConfigProgramPaths pc
 357                                   , packageConfigProgramPathExtra = packageConfigProgramPathExtra pc
 358
 359                                   -- Some flags to haddock should be passed to dependencies
 360                                   , packageConfigDocumentation = packageConfigDocumentation pc
 361                                   , packageConfigHaddockHoogle = packageConfigHaddockHoogle pc
 362                                   , packageConfigHaddockHtml = packageConfigHaddockHtml pc
 363                                   , packageConfigHaddockInternal = packageConfigHaddockInternal pc
 364                                   , packageConfigHaddockQuickJump = packageConfigHaddockQuickJump pc
 365                                   , packageConfigHaddockLinkedSource = packageConfigHaddockLinkedSource pc
 366                                   })
 367
 368 -- | Convert from the types currently used for the user-wide Cabal config
 369 -- file into the 'ProjectConfig' type.
 370 --
 371 -- Only a subset of the 'ProjectConfig' can be represented in the user-wide
 372 -- config. In particular it does not include packages that are in the project,
 373 -- and it also doesn't support package-specific configuration (only
 374 -- configuration that applies to all packages).
 375 --
 376 convertLegacyGlobalConfig :: SavedConfig -> ProjectConfig
 377 convertLegacyGlobalConfig
 378     SavedConfig {
 379       savedGlobalFlags       = globalFlags,
 380       savedInstallFlags      = installFlags,
 381       savedClientInstallFlags= clientInstallFlags,
 382       savedConfigureFlags    = configFlags,
 383       savedConfigureExFlags  = configExFlags,
 384       savedUserInstallDirs   = _,
 385       savedGlobalInstallDirs = _,
 386       savedUploadFlags       = _,
 387       savedReportFlags       = _,
 388       savedHaddockFlags      = haddockFlags,
 389       savedTestFlags         = testFlags,
 390       savedBenchmarkFlags    = benchmarkFlags,
 391       savedProjectFlags      = projectFlags
 392     } =
 393     mempty {
 394       projectConfigBuildOnly   = configBuildOnly,
 395       projectConfigShared      = configShared,
 396       projectConfigAllPackages = configAllPackages
 397     }
 398   where
 399     --TODO: [code cleanup] eliminate use of default*Flags here and specify the
 400     -- defaults in the various resolve functions in terms of the new types.
 401     configExFlags'      = defaultConfigExFlags      <> configExFlags
 402     installFlags'       = defaultInstallFlags       <> installFlags
 403     clientInstallFlags' = defaultClientInstallFlags <> clientInstallFlags
 404     haddockFlags'       = defaultHaddockFlags       <> haddockFlags
 405     testFlags'          = defaultTestFlags          <> testFlags
 406     benchmarkFlags'     = defaultBenchmarkFlags     <> benchmarkFlags
 407     projectFlags'       = defaultProjectFlags       <> projectFlags
 408
 409     configAllPackages   = convertLegacyPerPackageFlags
 410                             configFlags installFlags'
 411                             haddockFlags' testFlags' benchmarkFlags'
 412     configShared        = convertLegacyAllPackageFlags
 413                             globalFlags configFlags
 414                             configExFlags' installFlags' projectFlags'
 415     configBuildOnly     = convertLegacyBuildOnlyFlags
 416                             globalFlags configFlags
 417                             installFlags' clientInstallFlags'
 418                             haddockFlags' testFlags' benchmarkFlags'
 419
 420
 421 -- | Convert the project config from the legacy types to the 'ProjectConfig'
 422 -- and associated types. See 'LegacyProjectConfig' for an explanation of the
 423 -- approach.
 424 --
 425 convertLegacyProjectConfig :: LegacyProjectConfig -> ProjectConfig
 426 convertLegacyProjectConfig
 427   LegacyProjectConfig {
 428     legacyPackages,
 429     legacyPackagesOptional,
 430     legacyPackagesRepo,
 431     legacyPackagesNamed,
 432     legacySharedConfig = LegacySharedConfig globalFlags configShFlags
 433                                             configExFlags installSharedFlags
 434                                             clientInstallFlags projectFlags,
 435     legacyAllConfig,
 436     legacyLocalConfig  = LegacyPackageConfig configFlags installPerPkgFlags
 437                                              haddockFlags testFlags benchmarkFlags,
 438     legacySpecificConfig
 439   } =
 440
 441     ProjectConfig {
 442       projectPackages              = legacyPackages,
 443       projectPackagesOptional      = legacyPackagesOptional,
 444       projectPackagesRepo          = legacyPackagesRepo,
 445       projectPackagesNamed         = legacyPackagesNamed,
 446
 447       projectConfigBuildOnly       = configBuildOnly,
 448       projectConfigShared          = configPackagesShared,
 449       projectConfigProvenance      = mempty,
 450       projectConfigAllPackages     = configAllPackages,
 451       projectConfigLocalPackages   = configLocalPackages,
 452       projectConfigSpecificPackage = fmap perPackage legacySpecificConfig
 453     }
 454   where
 455     configAllPackages   = convertLegacyPerPackageFlags g i h t b
 456                             where LegacyPackageConfig g i h t b = legacyAllConfig
 457     configLocalPackages = convertLegacyPerPackageFlags
 458                             configFlags installPerPkgFlags haddockFlags
 459                             testFlags benchmarkFlags
 460     configPackagesShared= convertLegacyAllPackageFlags
 461                             globalFlags (configFlags <> configShFlags)
 462                             configExFlags installSharedFlags projectFlags
 463     configBuildOnly     = convertLegacyBuildOnlyFlags
 464                             globalFlags configShFlags
 465                             installSharedFlags clientInstallFlags
 466                             haddockFlags testFlags benchmarkFlags
 467
 468     perPackage (LegacyPackageConfig perPkgConfigFlags perPkgInstallFlags
 469                                     perPkgHaddockFlags perPkgTestFlags
 470                                     perPkgBenchmarkFlags) =
 471       convertLegacyPerPackageFlags
 472         perPkgConfigFlags perPkgInstallFlags perPkgHaddockFlags
 473                           perPkgTestFlags perPkgBenchmarkFlags
 474
 475
 476 -- | Helper used by other conversion functions that returns the
 477 -- 'ProjectConfigShared' subset of the 'ProjectConfig'.
 478 --
 479 convertLegacyAllPackageFlags
 480     :: GlobalFlags
 481     -> ConfigFlags
 482     -> ConfigExFlags
 483     -> InstallFlags
 484     -> ProjectFlags
 485     -> ProjectConfigShared
 486 convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags projectFlags =
 487     ProjectConfigShared{..}
 488   where
 489     GlobalFlags {
 490       globalConfigFile        = projectConfigConfigFile,
 491       globalRemoteRepos       = projectConfigRemoteRepos,
 492       globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos,
 493       globalActiveRepos       = projectConfigActiveRepos,
 494       globalProgPathExtra     = projectConfigProgPathExtra,
 495       globalStoreDir          = projectConfigStoreDir
 496     } = globalFlags
 497
 498     ConfigFlags {
 499       configDistPref            = projectConfigDistDir,
 500       configHcFlavor            = projectConfigHcFlavor,
 501       configHcPath              = projectConfigHcPath,
 502       configHcPkg               = projectConfigHcPkg,
 503     --configProgramPathExtra    = projectConfigProgPathExtra DELETE ME
 504     --configInstallDirs         = projectConfigInstallDirs,
 505     --configUserInstall         = projectConfigUserInstall,
 506       configPackageDBs          = projectConfigPackageDBs
 507     } = configFlags
 508
 509     ConfigExFlags {
 510       configCabalVersion        = projectConfigCabalVersion,
 511       configExConstraints       = projectConfigConstraints,
 512       configPreferences         = projectConfigPreferences,
 513       configSolver              = projectConfigSolver,
 514       configAllowOlder          = projectConfigAllowOlder,
 515       configAllowNewer          = projectConfigAllowNewer,
 516       configWriteGhcEnvironmentFilesPolicy
 517                                 = projectConfigWriteGhcEnvironmentFilesPolicy
 518     } = configExFlags
 519
 520     InstallFlags {
 521       installHaddockIndex       = projectConfigHaddockIndex,
 522     --installReinstall          = projectConfigReinstall,
 523     --installAvoidReinstalls    = projectConfigAvoidReinstalls,
 524     --installOverrideReinstall  = projectConfigOverrideReinstall,
 525       installIndexState         = projectConfigIndexState,
 526       installMaxBackjumps       = projectConfigMaxBackjumps,
 527     --installUpgradeDeps        = projectConfigUpgradeDeps,
 528       installReorderGoals       = projectConfigReorderGoals,
 529       installCountConflicts     = projectConfigCountConflicts,
 530       installFineGrainedConflicts = projectConfigFineGrainedConflicts,
 531       installMinimizeConflictSet = projectConfigMinimizeConflictSet,
 532       installPerComponent       = projectConfigPerComponent,
 533       installIndependentGoals   = projectConfigIndependentGoals,
 534       installPreferOldest       = projectConfigPreferOldest,
 535     --installShadowPkgs         = projectConfigShadowPkgs,
 536       installStrongFlags        = projectConfigStrongFlags,
 537       installAllowBootLibInstalls = projectConfigAllowBootLibInstalls,
 538       installOnlyConstrained    = projectConfigOnlyConstrained
 539     } = installFlags
 540
 541     ProjectFlags
 542         { flagProjectFileName = projectConfigProjectFile
 543         , flagIgnoreProject   = projectConfigIgnoreProject
 544         } = projectFlags
 545
 546 -- | Helper used by other conversion functions that returns the
 547 -- 'PackageConfig' subset of the 'ProjectConfig'.
 548 --
 549 convertLegacyPerPackageFlags :: ConfigFlags -> InstallFlags -> HaddockFlags
 550                              -> TestFlags -> BenchmarkFlags -> PackageConfig
 551 convertLegacyPerPackageFlags configFlags installFlags
 552                              haddockFlags testFlags benchmarkFlags =
 553     PackageConfig{..}
 554   where
 555     ConfigFlags {
 556       configProgramPaths,
 557       configProgramArgs,
 558       configProgramPathExtra    = packageConfigProgramPathExtra,
 559       configVanillaLib          = packageConfigVanillaLib,
 560       configProfLib             = packageConfigProfLib,
 561       configSharedLib           = packageConfigSharedLib,
 562       configStaticLib           = packageConfigStaticLib,
 563       configDynExe              = packageConfigDynExe,
 564       configFullyStaticExe      = packageConfigFullyStaticExe,
 565       configProfExe             = packageConfigProfExe,
 566       configProf                = packageConfigProf,
 567       configProfDetail          = packageConfigProfDetail,
 568       configProfLibDetail       = packageConfigProfLibDetail,
 569       configConfigureArgs       = packageConfigConfigureArgs,
 570       configOptimization        = packageConfigOptimization,
 571       configProgPrefix          = packageConfigProgPrefix,
 572       configProgSuffix          = packageConfigProgSuffix,
 573       configGHCiLib             = packageConfigGHCiLib,
 574       configSplitSections       = packageConfigSplitSections,
 575       configSplitObjs           = packageConfigSplitObjs,
 576       configStripExes           = packageConfigStripExes,
 577       configStripLibs           = packageConfigStripLibs,
 578       configExtraLibDirs        = packageConfigExtraLibDirs,
 579       configExtraLibDirsStatic  = packageConfigExtraLibDirsStatic,
 580       configExtraFrameworkDirs  = packageConfigExtraFrameworkDirs,
 581       configExtraIncludeDirs    = packageConfigExtraIncludeDirs,
 582       configConfigurationsFlags = packageConfigFlagAssignment,
 583       configTests               = packageConfigTests,
 584       configBenchmarks          = packageConfigBenchmarks,
 585       configCoverage            = coverage,
 586       configLibCoverage         = libcoverage, --deprecated
 587       configDebugInfo           = packageConfigDebugInfo,
 588       configDumpBuildInfo       = packageConfigDumpBuildInfo,
 589       configRelocatable         = packageConfigRelocatable
 590     } = configFlags
 591     packageConfigProgramPaths   = MapLast    (Map.fromList configProgramPaths)
 592     packageConfigProgramArgs    = MapMappend (Map.fromListWith (++) configProgramArgs)
 593
 594     packageConfigCoverage       = coverage <> libcoverage
 595     --TODO: defer this merging to the resolve phase
 596
 597     InstallFlags {
 598       installDocumentation      = packageConfigDocumentation,
 599       installRunTests           = packageConfigRunTests
 600     } = installFlags
 601
 602     HaddockFlags {
 603       haddockHoogle             = packageConfigHaddockHoogle,
 604       haddockHtml               = packageConfigHaddockHtml,
 605       haddockHtmlLocation       = packageConfigHaddockHtmlLocation,
 606       haddockForeignLibs        = packageConfigHaddockForeignLibs,
 607       haddockForHackage         = packageConfigHaddockForHackage,
 608       haddockExecutables        = packageConfigHaddockExecutables,
 609       haddockTestSuites         = packageConfigHaddockTestSuites,
 610       haddockBenchmarks         = packageConfigHaddockBenchmarks,
 611       haddockInternal           = packageConfigHaddockInternal,
 612       haddockCss                = packageConfigHaddockCss,
 613       haddockLinkedSource       = packageConfigHaddockLinkedSource,
 614       haddockQuickJump          = packageConfigHaddockQuickJump,
 615       haddockHscolourCss        = packageConfigHaddockHscolourCss,
 616       haddockContents           = packageConfigHaddockContents,
 617       haddockIndex              = packageConfigHaddockIndex,
 618       haddockBaseUrl            = packageConfigHaddockBaseUrl,
 619       haddockLib                = packageConfigHaddockLib
 620     } = haddockFlags
 621
 622     TestFlags {
 623       testHumanLog              = packageConfigTestHumanLog,
 624       testMachineLog            = packageConfigTestMachineLog,
 625       testShowDetails           = packageConfigTestShowDetails,
 626       testKeepTix               = packageConfigTestKeepTix,
 627       testWrapper               = packageConfigTestWrapper,
 628       testFailWhenNoTestSuites  = packageConfigTestFailWhenNoTestSuites,
 629       testOptions               = packageConfigTestTestOptions
 630     } = testFlags
 631
 632     BenchmarkFlags {
 633       benchmarkOptions          = packageConfigBenchmarkOptions
 634     } = benchmarkFlags
 635
 636
 637 -- | Helper used by other conversion functions that returns the
 638 -- 'ProjectConfigBuildOnly' subset of the 'ProjectConfig'.
 639 --
 640 convertLegacyBuildOnlyFlags :: GlobalFlags -> ConfigFlags
 641                             -> InstallFlags -> ClientInstallFlags
 642                             -> HaddockFlags -> TestFlags
 643                             -> BenchmarkFlags
 644                             -> ProjectConfigBuildOnly
 645 convertLegacyBuildOnlyFlags globalFlags configFlags
 646                               installFlags clientInstallFlags
 647                               haddockFlags _ _ =
 648     ProjectConfigBuildOnly{..}
 649   where
 650     projectConfigClientInstallFlags = clientInstallFlags
 651     GlobalFlags {
 652       globalCacheDir          = projectConfigCacheDir,
 653       globalLogsDir           = projectConfigLogsDir,
 654       globalHttpTransport     = projectConfigHttpTransport,
 655       globalIgnoreExpiry      = projectConfigIgnoreExpiry
 656     } = globalFlags
 657
 658     ConfigFlags {
 659       configVerbosity           = projectConfigVerbosity
 660     } = configFlags
 661
 662     InstallFlags {
 663       installDryRun             = projectConfigDryRun,
 664       installOnlyDownload       = projectConfigOnlyDownload,
 665       installOnly               = _,
 666       installOnlyDeps           = projectConfigOnlyDeps,
 667       installRootCmd            = _,
 668       installSummaryFile        = projectConfigSummaryFile,
 669       installLogFile            = projectConfigLogFile,
 670       installBuildReports       = projectConfigBuildReports,
 671       installReportPlanningFailure = projectConfigReportPlanningFailure,
 672       installSymlinkBinDir      = projectConfigSymlinkBinDir,
 673       installNumJobs            = projectConfigNumJobs,
 674       installKeepGoing          = projectConfigKeepGoing,
 675       installOfflineMode        = projectConfigOfflineMode
 676     } = installFlags
 677
 678     HaddockFlags {
 679       haddockKeepTempFiles      = projectConfigKeepTempFiles --TODO: this ought to live elsewhere
 680     } = haddockFlags
 681
 682
 683 convertToLegacyProjectConfig :: ProjectConfig -> LegacyProjectConfig
 684 convertToLegacyProjectConfig
 685     projectConfig@ProjectConfig {
 686       projectPackages,
 687       projectPackagesOptional,
 688       projectPackagesRepo,
 689       projectPackagesNamed,
 690       projectConfigAllPackages,
 691       projectConfigLocalPackages,
 692       projectConfigSpecificPackage
 693     } =
 694     LegacyProjectConfig {
 695       legacyPackages         = projectPackages,
 696       legacyPackagesOptional = projectPackagesOptional,
 697       legacyPackagesRepo     = projectPackagesRepo,
 698       legacyPackagesNamed    = projectPackagesNamed,
 699       legacySharedConfig     = convertToLegacySharedConfig projectConfig,
 700       legacyAllConfig        = convertToLegacyPerPackageConfig
 701                                  projectConfigAllPackages,
 702       legacyLocalConfig      = convertToLegacyAllPackageConfig projectConfig
 703                             <> convertToLegacyPerPackageConfig
 704                                  projectConfigLocalPackages,
 705       legacySpecificConfig   = fmap convertToLegacyPerPackageConfig
 706                                     projectConfigSpecificPackage
 707     }
 708
 709 convertToLegacySharedConfig :: ProjectConfig -> LegacySharedConfig
 710 convertToLegacySharedConfig
 711     ProjectConfig {
 712       projectConfigBuildOnly     = ProjectConfigBuildOnly {..},
 713       projectConfigShared        = ProjectConfigShared {..},
 714       projectConfigAllPackages   = PackageConfig {
 715         packageConfigDocumentation
 716       }
 717     } =
 718
 719     LegacySharedConfig
 720       { legacyGlobalFlags        = globalFlags
 721       , legacyConfigureShFlags   = configFlags
 722       , legacyConfigureExFlags   = configExFlags
 723       , legacyInstallFlags       = installFlags
 724       , legacyClientInstallFlags = projectConfigClientInstallFlags
 725       , legacyProjectFlags       = projectFlags
 726       }
 727   where
 728     globalFlags = GlobalFlags {
 729       globalVersion           = mempty,
 730       globalNumericVersion    = mempty,
 731       globalConfigFile        = projectConfigConfigFile,
 732       globalConstraintsFile   = mempty,
 733       globalRemoteRepos       = projectConfigRemoteRepos,
 734       globalCacheDir          = projectConfigCacheDir,
 735       globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos,
 736       globalActiveRepos       = projectConfigActiveRepos,
 737       globalLogsDir           = projectConfigLogsDir,
 738       globalIgnoreExpiry      = projectConfigIgnoreExpiry,
 739       globalHttpTransport     = projectConfigHttpTransport,
 740       globalNix               = mempty,
 741       globalStoreDir          = projectConfigStoreDir,
 742       globalProgPathExtra     = projectConfigProgPathExtra
 743     }
 744
 745     configFlags = mempty {
 746       configVerbosity     = projectConfigVerbosity,
 747       configDistPref      = projectConfigDistDir,
 748       configPackageDBs    = projectConfigPackageDBs
 749     }
 750
 751     configExFlags = ConfigExFlags {
 752       configCabalVersion  = projectConfigCabalVersion,
 753       configAppend        = mempty,
 754       configBackup        = mempty,
 755       configExConstraints = projectConfigConstraints,
 756       configPreferences   = projectConfigPreferences,
 757       configSolver        = projectConfigSolver,
 758       configAllowOlder    = projectConfigAllowOlder,
 759       configAllowNewer    = projectConfigAllowNewer,
 760       configWriteGhcEnvironmentFilesPolicy
 761                           = projectConfigWriteGhcEnvironmentFilesPolicy
 762     }
 763
 764     installFlags = InstallFlags {
 765       installDocumentation     = packageConfigDocumentation,
 766       installHaddockIndex      = projectConfigHaddockIndex,
 767       installDest              = Flag NoCopyDest,
 768       installDryRun            = projectConfigDryRun,
 769       installOnlyDownload      = projectConfigOnlyDownload,
 770       installReinstall         = mempty, --projectConfigReinstall,
 771       installAvoidReinstalls   = mempty, --projectConfigAvoidReinstalls,
 772       installOverrideReinstall = mempty, --projectConfigOverrideReinstall,
 773       installMaxBackjumps      = projectConfigMaxBackjumps,
 774       installUpgradeDeps       = mempty, --projectConfigUpgradeDeps,
 775       installReorderGoals      = projectConfigReorderGoals,
 776       installCountConflicts    = projectConfigCountConflicts,
 777       installFineGrainedConflicts = projectConfigFineGrainedConflicts,
 778       installMinimizeConflictSet = projectConfigMinimizeConflictSet,
 779       installIndependentGoals  = projectConfigIndependentGoals,
 780       installPreferOldest      = projectConfigPreferOldest,
 781       installShadowPkgs        = mempty, --projectConfigShadowPkgs,
 782       installStrongFlags       = projectConfigStrongFlags,
 783       installAllowBootLibInstalls = projectConfigAllowBootLibInstalls,
 784       installOnlyConstrained   = projectConfigOnlyConstrained,
 785       installOnly              = mempty,
 786       installOnlyDeps          = projectConfigOnlyDeps,
 787       installIndexState        = projectConfigIndexState,
 788       installRootCmd           = mempty, --no longer supported
 789       installSummaryFile       = projectConfigSummaryFile,
 790       installLogFile           = projectConfigLogFile,
 791       installBuildReports      = projectConfigBuildReports,
 792       installReportPlanningFailure = projectConfigReportPlanningFailure,
 793       installSymlinkBinDir     = projectConfigSymlinkBinDir,
 794       installPerComponent      = projectConfigPerComponent,
 795       installNumJobs           = projectConfigNumJobs,
 796       installKeepGoing         = projectConfigKeepGoing,
 797       installRunTests          = mempty,
 798       installOfflineMode       = projectConfigOfflineMode
 799     }
 800
 801     projectFlags = ProjectFlags
 802         { flagProjectFileName = projectConfigProjectFile
 803         , flagIgnoreProject   = projectConfigIgnoreProject
 804         }
 805
 806
 807 convertToLegacyAllPackageConfig :: ProjectConfig -> LegacyPackageConfig
 808 convertToLegacyAllPackageConfig
 809     ProjectConfig {
 810       projectConfigBuildOnly = ProjectConfigBuildOnly {..},
 811       projectConfigShared    = ProjectConfigShared {..}
 812     } =
 813
 814     LegacyPackageConfig {
 815       legacyConfigureFlags = configFlags,
 816       legacyInstallPkgFlags= mempty,
 817       legacyHaddockFlags   = haddockFlags,
 818       legacyTestFlags      = mempty,
 819       legacyBenchmarkFlags = mempty
 820     }
 821   where
 822     configFlags = ConfigFlags {
 823       configArgs                = mempty,
 824       configPrograms_           = mempty,
 825       configProgramPaths        = mempty,
 826       configProgramArgs         = mempty,
 827       configProgramPathExtra    = mempty,
 828       configHcFlavor            = projectConfigHcFlavor,
 829       configHcPath              = projectConfigHcPath,
 830       configHcPkg               = projectConfigHcPkg,
 831       configInstantiateWith     = mempty,
 832       configVanillaLib          = mempty,
 833       configProfLib             = mempty,
 834       configSharedLib           = mempty,
 835       configStaticLib           = mempty,
 836       configDynExe              = mempty,
 837       configFullyStaticExe      = mempty,
 838       configProfExe             = mempty,
 839       configProf                = mempty,
 840       configProfDetail          = mempty,
 841       configProfLibDetail       = mempty,
 842       configConfigureArgs       = mempty,
 843       configOptimization        = mempty,
 844       configProgPrefix          = mempty,
 845       configProgSuffix          = mempty,
 846       configInstallDirs         = mempty,
 847       configScratchDir          = mempty,
 848       configDistPref            = mempty,
 849       configCabalFilePath       = mempty,
 850       configVerbosity           = mempty,
 851       configUserInstall         = mempty, --projectConfigUserInstall,
 852       configPackageDBs          = mempty,
 853       configGHCiLib             = mempty,
 854       configSplitSections       = mempty,
 855       configSplitObjs           = mempty,
 856       configStripExes           = mempty,
 857       configStripLibs           = mempty,
 858       configExtraLibDirs        = mempty,
 859       configExtraLibDirsStatic  = mempty,
 860       configExtraFrameworkDirs  = mempty,
 861       configConstraints         = mempty,
 862       configDependencies        = mempty,
 863       configExtraIncludeDirs    = mempty,
 864       configDeterministic       = mempty,
 865       configIPID                = mempty,
 866       configCID                 = mempty,
 867       configConfigurationsFlags = mempty,
 868       configTests               = mempty,
 869       configCoverage            = mempty, --TODO: don't merge
 870       configLibCoverage         = mempty, --TODO: don't merge
 871       configExactConfiguration  = mempty,
 872       configBenchmarks          = mempty,
 873       configFlagError           = mempty,                --TODO: ???
 874       configRelocatable         = mempty,
 875       configDebugInfo           = mempty,
 876       configUseResponseFiles    = mempty,
 877       configDumpBuildInfo       = mempty,
 878       configAllowDependingOnPrivateLibs = mempty
 879     }
 880
 881     haddockFlags = mempty {
 882       haddockKeepTempFiles = projectConfigKeepTempFiles
 883     }
 884
 885
 886 convertToLegacyPerPackageConfig :: PackageConfig -> LegacyPackageConfig
 887 convertToLegacyPerPackageConfig PackageConfig {..} =
 888     LegacyPackageConfig {
 889       legacyConfigureFlags  = configFlags,
 890       legacyInstallPkgFlags = installFlags,
 891       legacyHaddockFlags    = haddockFlags,
 892       legacyTestFlags       = testFlags,
 893       legacyBenchmarkFlags  = benchmarkFlags
 894     }
 895   where
 896     configFlags = ConfigFlags {
 897       configArgs                = mempty,
 898       configPrograms_           = configPrograms_ mempty,
 899       configProgramPaths        = Map.toList (getMapLast packageConfigProgramPaths),
 900       configProgramArgs         = Map.toList (getMapMappend packageConfigProgramArgs),
 901       configProgramPathExtra    = packageConfigProgramPathExtra,
 902       configHcFlavor            = mempty,
 903       configHcPath              = mempty,
 904       configHcPkg               = mempty,
 905       configInstantiateWith     = mempty,
 906       configVanillaLib          = packageConfigVanillaLib,
 907       configProfLib             = packageConfigProfLib,
 908       configSharedLib           = packageConfigSharedLib,
 909       configStaticLib           = packageConfigStaticLib,
 910       configDynExe              = packageConfigDynExe,
 911       configFullyStaticExe      = packageConfigFullyStaticExe,
 912       configProfExe             = packageConfigProfExe,
 913       configProf                = packageConfigProf,
 914       configProfDetail          = packageConfigProfDetail,
 915       configProfLibDetail       = packageConfigProfLibDetail,
 916       configConfigureArgs       = packageConfigConfigureArgs,
 917       configOptimization        = packageConfigOptimization,
 918       configProgPrefix          = packageConfigProgPrefix,
 919       configProgSuffix          = packageConfigProgSuffix,
 920       configInstallDirs         = mempty,
 921       configScratchDir          = mempty,
 922       configDistPref            = mempty,
 923       configCabalFilePath       = mempty,
 924       configVerbosity           = mempty,
 925       configUserInstall         = mempty,
 926       configPackageDBs          = mempty,
 927       configGHCiLib             = packageConfigGHCiLib,
 928       configSplitSections       = packageConfigSplitSections,
 929       configSplitObjs           = packageConfigSplitObjs,
 930       configStripExes           = packageConfigStripExes,
 931       configStripLibs           = packageConfigStripLibs,
 932       configExtraLibDirs        = packageConfigExtraLibDirs,
 933       configExtraLibDirsStatic  = packageConfigExtraLibDirsStatic,
 934       configExtraFrameworkDirs  = packageConfigExtraFrameworkDirs,
 935       configConstraints         = mempty,
 936       configDependencies        = mempty,
 937       configExtraIncludeDirs    = packageConfigExtraIncludeDirs,
 938       configIPID                = mempty,
 939       configCID                 = mempty,
 940       configDeterministic       = mempty,
 941       configConfigurationsFlags = packageConfigFlagAssignment,
 942       configTests               = packageConfigTests,
 943       configCoverage            = packageConfigCoverage, --TODO: don't merge
 944       configLibCoverage         = packageConfigCoverage, --TODO: don't merge
 945       configExactConfiguration  = mempty,
 946       configBenchmarks          = packageConfigBenchmarks,
 947       configFlagError           = mempty,                --TODO: ???
 948       configRelocatable         = packageConfigRelocatable,
 949       configDebugInfo           = packageConfigDebugInfo,
 950       configUseResponseFiles    = mempty,
 951       configDumpBuildInfo       = packageConfigDumpBuildInfo,
 952       configAllowDependingOnPrivateLibs = mempty
 953     }
 954
 955     installFlags = mempty {
 956       installDocumentation      = packageConfigDocumentation,
 957       installRunTests           = packageConfigRunTests
 958     }
 959
 960     haddockFlags = HaddockFlags {
 961       haddockProgramPaths  = mempty,
 962       haddockProgramArgs   = mempty,
 963       haddockHoogle        = packageConfigHaddockHoogle,
 964       haddockHtml          = packageConfigHaddockHtml,
 965       haddockHtmlLocation  = packageConfigHaddockHtmlLocation,
 966       haddockForHackage    = packageConfigHaddockForHackage,
 967       haddockForeignLibs   = packageConfigHaddockForeignLibs,
 968       haddockExecutables   = packageConfigHaddockExecutables,
 969       haddockTestSuites    = packageConfigHaddockTestSuites,
 970       haddockBenchmarks    = packageConfigHaddockBenchmarks,
 971       haddockInternal      = packageConfigHaddockInternal,
 972       haddockCss           = packageConfigHaddockCss,
 973       haddockLinkedSource  = packageConfigHaddockLinkedSource,
 974       haddockQuickJump     = packageConfigHaddockQuickJump,
 975       haddockHscolourCss   = packageConfigHaddockHscolourCss,
 976       haddockContents      = packageConfigHaddockContents,
 977       haddockDistPref      = mempty,
 978       haddockKeepTempFiles = mempty,
 979       haddockVerbosity     = mempty,
 980       haddockCabalFilePath = mempty,
 981       haddockIndex         = packageConfigHaddockIndex,
 982       haddockBaseUrl       = packageConfigHaddockBaseUrl,
 983       haddockLib           = packageConfigHaddockLib,
 984       haddockArgs          = mempty
 985     }
 986
 987     testFlags = TestFlags {
 988       testDistPref    = mempty,
 989       testVerbosity   = mempty,
 990       testHumanLog    = packageConfigTestHumanLog,
 991       testMachineLog  = packageConfigTestMachineLog,
 992       testShowDetails = packageConfigTestShowDetails,
 993       testKeepTix     = packageConfigTestKeepTix,
 994       testWrapper     = packageConfigTestWrapper,
 995       testFailWhenNoTestSuites = packageConfigTestFailWhenNoTestSuites,
 996       testOptions     = packageConfigTestTestOptions
 997     }
 998
 999     benchmarkFlags = BenchmarkFlags {
1000       benchmarkDistPref  = mempty,
1001       benchmarkVerbosity = mempty,
1002       benchmarkOptions   = packageConfigBenchmarkOptions
1003     }
1004
1005 ------------------------------------------------
1006 -- Parsing and showing the project config file
1007 --
1008
1009 parseLegacyProjectConfigFields :: FilePath -> [ParseUtils.Field] -> ParseResult LegacyProjectConfig
1010 parseLegacyProjectConfigFields source =
1011     parseFieldsAndSections (legacyProjectConfigFieldDescrs constraintSrc)
1012                 legacyPackageConfigSectionDescrs
1013                 legacyPackageConfigFGSectionDescrs
1014                 mempty
1015   where
1016     constraintSrc = ConstraintSourceProjectConfig source
1017
1018 parseLegacyProjectConfig :: FilePath -> BS.ByteString -> ParseResult LegacyProjectConfig
1019 parseLegacyProjectConfig source bs = parseLegacyProjectConfigFields source =<< ParseUtils.readFields bs
1020
1021 showLegacyProjectConfig :: LegacyProjectConfig -> String
1022 showLegacyProjectConfig config =
1023     Disp.render $
1024     showConfig  (legacyProjectConfigFieldDescrs constraintSrc)
1025                 legacyPackageConfigSectionDescrs
1026                 legacyPackageConfigFGSectionDescrs
1027                 config
1028   $+$
1029     Disp.text ""
1030   where
1031     -- Note: ConstraintSource is unused when pretty-printing. We fake
1032     -- it here to avoid having to pass it on call-sites. It's not great
1033     -- but requires re-work of how we annotate provenance.
1034     constraintSrc = ConstraintSourceProjectConfig "unused"
1035
1036
1037 legacyProjectConfigFieldDescrs :: ConstraintSource -> [FieldDescr LegacyProjectConfig]
1038 legacyProjectConfigFieldDescrs constraintSrc =
1039
1040     [ newLineListField "packages"
1041         (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ
1042         legacyPackages
1043         (\v flags -> flags { legacyPackages = v })
1044     , newLineListField "optional-packages"
1045         (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ
1046         legacyPackagesOptional
1047         (\v flags -> flags { legacyPackagesOptional = v })
1048     , commaNewLineListFieldParsec "extra-packages"
1049         pretty parsec
1050         legacyPackagesNamed
1051         (\v flags -> flags { legacyPackagesNamed = v })
1052     ]
1053
1054  ++ map (liftField
1055            legacySharedConfig
1056            (\flags conf -> conf { legacySharedConfig = flags }))
1057         (legacySharedConfigFieldDescrs constraintSrc)
1058
1059  ++ map (liftField
1060            legacyLocalConfig
1061            (\flags conf -> conf { legacyLocalConfig = flags }))
1062         legacyPackageConfigFieldDescrs
1063
1064 -- | This is a bit tricky since it has to cover globs which have embedded @,@
1065 -- chars. But we don't just want to parse strictly as a glob since we want to
1066 -- allow http urls which don't parse as globs, and possibly some
1067 -- system-dependent file paths. So we parse fairly liberally as a token, but
1068 -- we allow @,@ inside matched @{}@ braces.
1069 --
1070 parsePackageLocationTokenQ :: ReadP r String
1071 parsePackageLocationTokenQ = parseHaskellString
1072                    Parse.<++ parsePackageLocationToken
1073   where
1074     parsePackageLocationToken :: ReadP r String
1075     parsePackageLocationToken = fmap fst (Parse.gather outerTerm)
1076       where
1077         outerTerm   = alternateEither1 outerToken (braces innerTerm)
1078         innerTerm   = alternateEither  innerToken (braces innerTerm)
1079         outerToken  = Parse.munch1 outerChar >> return ()
1080         innerToken  = Parse.munch1 innerChar >> return ()
1081         outerChar c = not (isSpace c || c == '{' || c == '}' || c == ',')
1082         innerChar c = not (isSpace c || c == '{' || c == '}')
1083         braces      = Parse.between (Parse.char '{') (Parse.char '}')
1084
1085     alternateEither, alternateEither1,
1086       alternatePQs, alternate1PQs, alternateQsP, alternate1QsP
1087       :: ReadP r () -> ReadP r () -> ReadP r ()
1088
1089     alternateEither1 p q = alternate1PQs p q +++ alternate1QsP q p
1090     alternateEither  p q = alternateEither1 p q +++ return ()
1091     alternate1PQs    p q = p >> alternateQsP q p
1092     alternatePQs     p q = alternate1PQs p q +++ return ()
1093     alternate1QsP    q p = Parse.many1 q >> alternatePQs p q
1094     alternateQsP     q p = alternate1QsP q p +++ return ()
1095
1096 renderPackageLocationToken :: String -> String
1097 renderPackageLocationToken s | needsQuoting = show s
1098                              | otherwise    = s
1099   where
1100     needsQuoting  = not (ok 0 s)
1101                  || s == "." -- . on its own on a line has special meaning
1102                  || take 2 s == "--" -- on its own line is comment syntax
1103                  --TODO: [code cleanup] these "." and "--" escaping issues
1104                  -- ought to be dealt with systematically in ParseUtils.
1105     ok :: Int -> String -> Bool
1106     ok n []       = n == 0
1107     ok _ ('"':_)  = False
1108     ok n ('{':cs) = ok (n+1) cs
1109     ok n ('}':cs) = ok (n-1) cs
1110     ok n (',':cs) = (n > 0) && ok n cs
1111     ok _ (c:_)
1112       | isSpace c = False
1113     ok n (_  :cs) = ok n cs
1114
1115
1116 legacySharedConfigFieldDescrs :: ConstraintSource -> [FieldDescr LegacySharedConfig]
1117 legacySharedConfigFieldDescrs constraintSrc = concat
1118   [ liftFields
1119       legacyGlobalFlags
1120       (\flags conf -> conf { legacyGlobalFlags = flags })
1121   . addFields
1122       [ newLineListField "extra-prog-path-shared-only"
1123           showTokenQ parseTokenQ
1124           (fromNubList . globalProgPathExtra)
1125           (\v conf -> conf { globalProgPathExtra = toNubList v })
1126       ]
1127   . filterFields
1128       [ "remote-repo-cache"
1129       , "logs-dir", "store-dir", "ignore-expiry", "http-transport"
1130       , "active-repositories"
1131       ]
1132   . commandOptionsToFields
1133   $ commandOptions (globalCommand []) ParseArgs
1134
1135   , liftFields
1136       legacyConfigureShFlags
1137       (\flags conf -> conf { legacyConfigureShFlags = flags })
1138   . addFields
1139       [ commaNewLineListFieldParsec "package-dbs"
1140         (Disp.text . showPackageDb) (fmap readPackageDb parsecToken)
1141         configPackageDBs (\v conf -> conf { configPackageDBs = v })
1142       ]
1143   . filterFields ["verbose", "builddir" ]
1144   . commandOptionsToFields
1145   $ configureOptions ParseArgs
1146
1147   , liftFields
1148       legacyConfigureExFlags
1149       (\flags conf -> conf { legacyConfigureExFlags = flags })
1150   . addFields
1151       [ commaNewLineListFieldParsec "constraints"
1152         (pretty . fst) (fmap (\constraint -> (constraint, constraintSrc)) parsec)
1153         configExConstraints (\v conf -> conf { configExConstraints = v })
1154
1155       , commaNewLineListFieldParsec "preferences"
1156         pretty parsec
1157         configPreferences (\v conf -> conf { configPreferences = v })
1158
1159       , monoidFieldParsec "allow-older"
1160         (maybe mempty pretty) (fmap Just parsec)
1161         (fmap unAllowOlder . configAllowOlder)
1162         (\v conf -> conf { configAllowOlder = fmap AllowOlder v })
1163
1164       , monoidFieldParsec "allow-newer"
1165         (maybe mempty pretty) (fmap Just parsec)
1166         (fmap unAllowNewer . configAllowNewer)
1167         (\v conf -> conf { configAllowNewer = fmap AllowNewer v })
1168       ]
1169   . filterFields
1170       [ "cabal-lib-version", "solver", "write-ghc-environment-files"
1171         -- not "constraint" or "preference", we use our own plural ones above
1172       ]
1173   . commandOptionsToFields
1174   $ configureExOptions ParseArgs constraintSrc
1175
1176   , liftFields
1177       legacyInstallFlags
1178       (\flags conf -> conf { legacyInstallFlags = flags })
1179   . addFields
1180       [ newLineListField "build-summary"
1181           (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ)
1182           (fromNubList . installSummaryFile)
1183           (\v conf -> conf { installSummaryFile = toNubList v })
1184       ]
1185   . filterFields
1186       [ "doc-index-file"
1187       , "root-cmd", "symlink-bindir"
1188       , "build-log"
1189       , "remote-build-reporting", "report-planning-failure"
1190       , "jobs", "keep-going", "offline", "per-component"
1191         -- solver flags:
1192       , "max-backjumps", "reorder-goals", "count-conflicts"
1193       , "fine-grained-conflicts" , "minimize-conflict-set", "independent-goals", "prefer-oldest"
1194       , "strong-flags" , "allow-boot-library-installs"
1195       , "reject-unconstrained-dependencies", "index-state"
1196       ]
1197   . commandOptionsToFields
1198   $ installOptions ParseArgs
1199
1200   , liftFields
1201       legacyClientInstallFlags
1202       (\flags conf -> conf { legacyClientInstallFlags = flags })
1203   . commandOptionsToFields
1204   $ clientInstallOptions ParseArgs
1205
1206   , liftFields
1207       legacyProjectFlags
1208       (\flags conf -> conf { legacyProjectFlags = flags })
1209   . commandOptionsToFields
1210   $ projectFlagsOptions ParseArgs
1211
1212   ]
1213
1214
1215 legacyPackageConfigFieldDescrs :: [FieldDescr LegacyPackageConfig]
1216 legacyPackageConfigFieldDescrs =
1217   ( liftFields
1218       legacyConfigureFlags
1219       (\flags conf -> conf { legacyConfigureFlags = flags })
1220   . addFields
1221       [ newLineListField "extra-include-dirs"
1222           showTokenQ parseTokenQ
1223           configExtraIncludeDirs
1224           (\v conf -> conf { configExtraIncludeDirs = v })
1225       , newLineListField "extra-lib-dirs"
1226           showTokenQ parseTokenQ
1227           configExtraLibDirs
1228           (\v conf -> conf { configExtraLibDirs = v })
1229       , newLineListField "extra-lib-dirs-static"
1230           showTokenQ parseTokenQ
1231           configExtraLibDirsStatic
1232           (\v conf -> conf { configExtraLibDirsStatic = v })
1233       , newLineListField "extra-framework-dirs"
1234           showTokenQ parseTokenQ
1235           configExtraFrameworkDirs
1236           (\v conf -> conf { configExtraFrameworkDirs = v })
1237       , newLineListField "extra-prog-path"
1238           showTokenQ parseTokenQ
1239           (fromNubList . configProgramPathExtra)
1240           (\v conf -> conf { configProgramPathExtra = toNubList v })
1241       , newLineListField "configure-options"
1242           showTokenQ parseTokenQ
1243           configConfigureArgs
1244           (\v conf -> conf { configConfigureArgs = v })
1245       , simpleFieldParsec "flags"
1246           dispFlagAssignment parsecFlagAssignment
1247           configConfigurationsFlags
1248           (\v conf -> conf { configConfigurationsFlags = v })
1249       , overrideDumpBuildInfo
1250       ]
1251   . filterFields
1252       [ "with-compiler", "with-hc-pkg"
1253       , "program-prefix", "program-suffix"
1254       , "library-vanilla", "library-profiling"
1255       , "shared", "static", "executable-dynamic", "executable-static"
1256       , "profiling", "executable-profiling"
1257       , "profiling-detail", "library-profiling-detail"
1258       , "library-for-ghci", "split-objs", "split-sections"
1259       , "executable-stripping", "library-stripping"
1260       , "tests", "benchmarks"
1261       , "coverage", "library-coverage"
1262       , "relocatable"
1263         -- not "extra-include-dirs", "extra-lib-dirs", "extra-framework-dirs"
1264         -- or "extra-prog-path". We use corrected ones above that parse
1265         -- as list fields.
1266       ]
1267   . commandOptionsToFields
1268   ) (configureOptions ParseArgs)
1269  ++
1270     liftFields
1271       legacyConfigureFlags
1272       (\flags conf -> conf { legacyConfigureFlags = flags })
1273     [ overrideFieldCompiler
1274     , overrideFieldOptimization
1275     , overrideFieldDebugInfo
1276     ]
1277  ++
1278   ( liftFields
1279       legacyInstallPkgFlags
1280       (\flags conf -> conf { legacyInstallPkgFlags = flags })
1281   . filterFields
1282       [ "documentation", "run-tests"
1283       ]
1284   . commandOptionsToFields
1285   ) (installOptions ParseArgs)
1286  ++
1287   ( liftFields
1288       legacyHaddockFlags
1289       (\flags conf -> conf { legacyHaddockFlags = flags })
1290   . mapFieldNames
1291       ("haddock-"++)
1292   . addFields
1293       [ simpleFieldParsec "for-hackage"
1294           -- TODO: turn this into a library function
1295           (fromFlagOrDefault Disp.empty . fmap pretty) (toFlag <$> parsec <|> pure mempty)
1296           haddockForHackage (\v conf -> conf { haddockForHackage = v })
1297       ]
1298   . filterFields
1299       [ "hoogle", "html", "html-location"
1300       , "foreign-libraries"
1301       , "executables", "tests", "benchmarks", "all", "internal", "css"
1302       , "hyperlink-source", "quickjump", "hscolour-css"
1303       , "contents-location", "index-location", "keep-temp-files", "base-url"
1304       , "lib"
1305       ]
1306   . commandOptionsToFields
1307   ) (haddockOptions ParseArgs)
1308  ++
1309   ( liftFields
1310       legacyTestFlags
1311       (\flags conf -> conf { legacyTestFlags = flags })
1312   . mapFieldNames
1313       prefixTest
1314   . addFields
1315       [ newLineListField "test-options"
1316           (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ)
1317           testOptions
1318           (\v conf -> conf { testOptions = v })
1319       ]
1320   . filterFields
1321       [ "log", "machine-log", "show-details", "keep-tix-files"
1322       , "fail-when-no-test-suites", "test-wrapper" ]
1323   . commandOptionsToFields
1324   ) (testOptions' ParseArgs)
1325  ++
1326   ( liftFields
1327       legacyBenchmarkFlags
1328       (\flags conf -> conf { legacyBenchmarkFlags = flags })
1329   . addFields
1330       [ newLineListField "benchmark-options"
1331           (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ)
1332           benchmarkOptions
1333           (\v conf -> conf { benchmarkOptions = v })
1334       ]
1335   . filterFields
1336       []
1337   . commandOptionsToFields
1338   ) (benchmarkOptions' ParseArgs)
1339
1340
1341   where
1342     overrideFieldCompiler =
1343       simpleFieldParsec "compiler"
1344         (fromFlagOrDefault Disp.empty . fmap pretty)
1345         (toFlag <$> parsec <|> pure mempty)
1346         configHcFlavor (\v flags -> flags { configHcFlavor = v })
1347
1348     overrideDumpBuildInfo =
1349       liftField configDumpBuildInfo
1350                 (\v flags -> flags { configDumpBuildInfo = v }) $
1351       let name = "build-info" in
1352       FieldDescr name
1353         (\f -> case f of
1354                  Flag NoDumpBuildInfo -> Disp.text "False"
1355                  Flag DumpBuildInfo   -> Disp.text "True"
1356                  _                    -> Disp.empty)
1357         (\line str _ -> case () of
1358          _ |  str == "False" -> ParseOk [] (Flag NoDumpBuildInfo)
1359            |  str == "True"  -> ParseOk [] (Flag DumpBuildInfo)
1360            | lstr == "false" -> ParseOk [caseWarning name] (Flag NoDumpBuildInfo)
1361            | lstr == "true"  -> ParseOk [caseWarning name] (Flag DumpBuildInfo)
1362            | otherwise       -> ParseFailed (NoParse name line)
1363            where
1364              lstr = lowercase str)
1365
1366     -- TODO: [code cleanup] The following is a hack. The "optimization" and
1367     -- "debug-info" fields are OptArg, and viewAsFieldDescr fails on that.
1368     -- Instead of a hand-written parser and printer, we should handle this case
1369     -- properly in the library.
1370
1371     overrideFieldOptimization =
1372       liftField configOptimization
1373                 (\v flags -> flags { configOptimization = v }) $
1374       let name = "optimization" in
1375       FieldDescr name
1376         (\f -> case f of
1377                  Flag NoOptimisation      -> Disp.text "False"
1378                  Flag NormalOptimisation  -> Disp.text "True"
1379                  Flag MaximumOptimisation -> Disp.text "2"
1380                  _                        -> Disp.empty)
1381         (\line str _ -> case () of
1382          _ |  str == "False" -> ParseOk [] (Flag NoOptimisation)
1383            |  str == "True"  -> ParseOk [] (Flag NormalOptimisation)
1384            |  str == "0"     -> ParseOk [] (Flag NoOptimisation)
1385            |  str == "1"     -> ParseOk [] (Flag NormalOptimisation)
1386            |  str == "2"     -> ParseOk [] (Flag MaximumOptimisation)
1387            | lstr == "false" -> ParseOk [caseWarning name] (Flag NoOptimisation)
1388            | lstr == "true"  -> ParseOk [caseWarning name] (Flag NormalOptimisation)
1389            | otherwise       -> ParseFailed (NoParse name line)
1390            where
1391              lstr = lowercase str)
1392
1393     overrideFieldDebugInfo =
1394       liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $
1395       let name = "debug-info" in
1396       FieldDescr name
1397         (\f -> case f of
1398                  Flag NoDebugInfo      -> Disp.text "False"
1399                  Flag MinimalDebugInfo -> Disp.text "1"
1400                  Flag NormalDebugInfo  -> Disp.text "True"
1401                  Flag MaximalDebugInfo -> Disp.text "3"
1402                  _                     -> Disp.empty)
1403         (\line str _ -> case () of
1404          _ |  str == "False" -> ParseOk [] (Flag NoDebugInfo)
1405            |  str == "True"  -> ParseOk [] (Flag NormalDebugInfo)
1406            |  str == "0"     -> ParseOk [] (Flag NoDebugInfo)
1407            |  str == "1"     -> ParseOk [] (Flag MinimalDebugInfo)
1408            |  str == "2"     -> ParseOk [] (Flag NormalDebugInfo)
1409            |  str == "3"     -> ParseOk [] (Flag MaximalDebugInfo)
1410            | lstr == "false" -> ParseOk [caseWarning name] (Flag NoDebugInfo)
1411            | lstr == "true"  -> ParseOk [caseWarning name] (Flag NormalDebugInfo)
1412            | otherwise       -> ParseFailed (NoParse name line)
1413            where
1414              lstr = lowercase str)
1415
1416     caseWarning name = PWarning $
1417       "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'."
1418
1419     prefixTest name | "test-" `isPrefixOf` name = name
1420                     | otherwise = "test-" ++ name
1421
1422
1423 legacyPackageConfigFGSectionDescrs
1424     :: ( FieldGrammar c g, Applicative (g SourceRepoList)
1425        , c (Identity RepoType)
1426        , c (List NoCommaFSep FilePathNT String)
1427        , c (NonEmpty' NoCommaFSep Token String)
1428        )
1429     => [FGSectionDescr g LegacyProjectConfig]
1430 legacyPackageConfigFGSectionDescrs =
1431     [ packageRepoSectionDescr
1432     ]
1433
1434 legacyPackageConfigSectionDescrs :: [SectionDescr LegacyProjectConfig]
1435 legacyPackageConfigSectionDescrs =
1436     [ packageSpecificOptionsSectionDescr
1437     , liftSection
1438         legacyLocalConfig
1439         (\flags conf -> conf { legacyLocalConfig = flags })
1440         programOptionsSectionDescr
1441     , liftSection
1442         legacyLocalConfig
1443         (\flags conf -> conf { legacyLocalConfig = flags })
1444         programLocationsSectionDescr
1445     , liftSection
1446         legacySharedConfig
1447         (\flags conf -> conf { legacySharedConfig = flags }) $
1448       liftSection
1449         legacyGlobalFlags
1450         (\flags conf -> conf { legacyGlobalFlags = flags })
1451         remoteRepoSectionDescr
1452     ]
1453
1454 packageRepoSectionDescr
1455     :: ( FieldGrammar c g, Applicative (g SourceRepoList)
1456        , c (Identity RepoType)
1457        , c (List NoCommaFSep FilePathNT String)
1458        , c (NonEmpty' NoCommaFSep Token String)
1459        )
1460     => FGSectionDescr g LegacyProjectConfig
1461 packageRepoSectionDescr = FGSectionDescr
1462   { fgSectionName        = "source-repository-package"
1463   , fgSectionGrammar     = sourceRepositoryPackageGrammar
1464   , fgSectionGet         = map (\x->("", x)) . legacyPackagesRepo
1465   , fgSectionSet         =
1466         \lineno unused pkgrepo projconf -> do
1467           unless (null unused) $
1468             syntaxError lineno "the section 'source-repository-package' takes no arguments"
1469           return projconf {
1470             legacyPackagesRepo = legacyPackagesRepo projconf ++ [pkgrepo]
1471           }
1472   }
1473
1474 -- | The definitions of all the fields that can appear in the @package pkgfoo@
1475 -- and @package *@ sections of the @cabal.project@-format files.
1476 --
1477 packageSpecificOptionsFieldDescrs :: [FieldDescr LegacyPackageConfig]
1478 packageSpecificOptionsFieldDescrs =
1479     legacyPackageConfigFieldDescrs
1480  ++ programOptionsFieldDescrs
1481       (configProgramArgs . legacyConfigureFlags)
1482       (\args pkgconf -> pkgconf {
1483           legacyConfigureFlags = (legacyConfigureFlags pkgconf) {
1484             configProgramArgs  = args
1485           }
1486         }
1487       )
1488  ++ liftFields
1489       legacyConfigureFlags
1490       (\flags pkgconf -> pkgconf {
1491           legacyConfigureFlags = flags
1492         }
1493       )
1494       programLocationsFieldDescrs
1495
1496 -- | The definition of the @package pkgfoo@ sections of the @cabal.project@-format
1497 -- files. This section is per-package name. The special package @*@ applies to all
1498 -- packages used anywhere by the project, locally or as dependencies.
1499 --
1500 packageSpecificOptionsSectionDescr :: SectionDescr LegacyProjectConfig
1501 packageSpecificOptionsSectionDescr =
1502     SectionDescr {
1503       sectionName        = "package",
1504       sectionFields      = packageSpecificOptionsFieldDescrs,
1505       sectionSubsections = [],
1506       sectionGet         = \projconf ->
1507                              [ (prettyShow pkgname, pkgconf)
1508                              | (pkgname, pkgconf) <-
1509                                  Map.toList . getMapMappend
1510                                . legacySpecificConfig $ projconf ]
1511                           ++ [ ("*", legacyAllConfig projconf) ],
1512       sectionSet         =
1513         \lineno pkgnamestr pkgconf projconf -> case pkgnamestr of
1514           "*" -> return projconf {
1515                    legacyAllConfig = legacyAllConfig projconf <> pkgconf
1516                  }
1517           _   -> do
1518             pkgname <- case simpleParsec pkgnamestr of
1519               Just pkgname -> return pkgname
1520               Nothing      -> syntaxError lineno $
1521                                   "a 'package' section requires a package name "
1522                                ++ "as an argument"
1523             return projconf {
1524               legacySpecificConfig =
1525                 MapMappend $
1526                 Map.insertWith mappend pkgname pkgconf
1527                                (getMapMappend $ legacySpecificConfig projconf)
1528             },
1529       sectionEmpty       = mempty
1530     }
1531
1532 programOptionsFieldDescrs :: (a -> [(String, [String])])
1533                           -> ([(String, [String])] -> a -> a)
1534                           -> [FieldDescr a]
1535 programOptionsFieldDescrs get' set =
1536     commandOptionsToFields
1537   $ programDbOptions
1538       defaultProgramDb
1539       ParseArgs get' set
1540
1541 programOptionsSectionDescr :: SectionDescr LegacyPackageConfig
1542 programOptionsSectionDescr =
1543     SectionDescr {
1544       sectionName        = "program-options",
1545       sectionFields      = programOptionsFieldDescrs
1546                              configProgramArgs
1547                              (\args conf -> conf { configProgramArgs = args }),
1548       sectionSubsections = [],
1549       sectionGet         = (\x->[("", x)])
1550                          . legacyConfigureFlags,
1551       sectionSet         =
1552         \lineno unused confflags pkgconf -> do
1553           unless (null unused) $
1554             syntaxError lineno "the section 'program-options' takes no arguments"
1555           return pkgconf {
1556             legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags
1557           },
1558       sectionEmpty       = mempty
1559     }
1560
1561 programLocationsFieldDescrs :: [FieldDescr ConfigFlags]
1562 programLocationsFieldDescrs =
1563      commandOptionsToFields
1564    $ programDbPaths'
1565        (++ "-location")
1566        defaultProgramDb
1567        ParseArgs
1568        configProgramPaths
1569        (\paths conf -> conf { configProgramPaths = paths })
1570
1571 programLocationsSectionDescr :: SectionDescr LegacyPackageConfig
1572 programLocationsSectionDescr =
1573     SectionDescr {
1574       sectionName        = "program-locations",
1575       sectionFields      = programLocationsFieldDescrs,
1576       sectionSubsections = [],
1577       sectionGet         = (\x->[("", x)])
1578                          . legacyConfigureFlags,
1579       sectionSet         =
1580         \lineno unused confflags pkgconf -> do
1581           unless (null unused) $
1582             syntaxError lineno "the section 'program-locations' takes no arguments"
1583           return pkgconf {
1584             legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags
1585           },
1586       sectionEmpty       = mempty
1587     }
1588
1589
1590 -- | For each known program @PROG@ in 'progDb', produce a @PROG-options@
1591 -- 'OptionField'.
1592 programDbOptions
1593   :: ProgramDb
1594   -> ShowOrParseArgs
1595   -> (flags -> [(String, [String])])
1596   -> ([(String, [String])] -> (flags -> flags))
1597   -> [OptionField flags]
1598 programDbOptions progDb showOrParseArgs get' set =
1599   case showOrParseArgs of
1600     -- we don't want a verbose help text list so we just show a generic one:
1601     ShowArgs  -> [programOptions  "PROG"]
1602     ParseArgs -> map (programOptions . programName . fst)
1603                  (knownPrograms progDb)
1604   where
1605     programOptions prog =
1606       option "" [prog ++ "-options"]
1607         ("give extra options to " ++ prog)
1608         get' set
1609         (reqArg' "OPTS" (\args -> [(prog, splitArgs args)])
1610            (\progArgs -> [ joinsArgs args
1611                          | (prog', args) <- progArgs, prog==prog' ]))
1612
1613
1614     joinsArgs = unwords . map escape
1615     escape arg | any isSpace arg = "\"" ++ arg ++ "\""
1616                | otherwise       = arg
1617
1618
1619 -- The implementation is slight hack: we parse all as remote repository
1620 -- but if the url schema is file+noindex, we switch to local.
1621 remoteRepoSectionDescr :: SectionDescr GlobalFlags
1622 remoteRepoSectionDescr = SectionDescr
1623     { sectionName        = "repository"
1624     , sectionEmpty       = emptyRemoteRepo (RepoName "")
1625     , sectionFields      = remoteRepoFields
1626     , sectionSubsections = []
1627     , sectionGet         = getS
1628     , sectionSet         = setS
1629     }
1630   where
1631     getS :: GlobalFlags -> [(String, RemoteRepo)]
1632     getS gf =
1633         map (\x->(unRepoName $ remoteRepoName x, x)) (fromNubList (globalRemoteRepos gf))
1634         ++
1635         map (\x->(unRepoName $ localRepoName x, localToRemote x)) (fromNubList (globalLocalNoIndexRepos gf))
1636
1637     setS :: Int -> String -> RemoteRepo -> GlobalFlags -> ParseResult GlobalFlags
1638     setS lineno reponame repo0 conf = do
1639         repo1 <- postProcessRepo lineno reponame repo0
1640         case repo1 of
1641             Left repo -> return conf
1642                 { globalLocalNoIndexRepos  = overNubList (++[repo]) (globalLocalNoIndexRepos conf)
1643                 }
1644             Right repo -> return conf
1645                 { globalRemoteRepos = overNubList (++[repo]) (globalRemoteRepos conf)
1646                 }
1647
1648     localToRemote :: LocalRepo -> RemoteRepo
1649     localToRemote (LocalRepo name path sharedCache) = (emptyRemoteRepo name)
1650         { remoteRepoURI = URI "file+noindex:" Nothing path "" (if sharedCache then "#shared-cache" else "")
1651         }
1652
1653 -------------------------------
1654 -- Local field utils
1655 --
1656
1657 -- | Parser combinator for simple fields which uses the field type's
1658 -- 'Monoid' instance for combining multiple occurrences of the field.
1659 monoidFieldParsec
1660     :: Monoid a => String -> (a -> Doc) -> ParsecParser a
1661     -> (b -> a) -> (a -> b -> b) -> FieldDescr b
1662 monoidFieldParsec name showF readF get' set =
1663   liftField get' set' $ ParseUtils.fieldParsec name showF readF
1664   where
1665     set' xs b = set (get' b `mappend` xs) b
1666
1667
1668 --TODO: [code cleanup] local redefinition that should replace the version in
1669 -- D.ParseUtils called showFilePath. This version escapes "." and "--" which
1670 -- otherwise are special syntax.
1671 showTokenQ :: String -> Doc
1672 showTokenQ ""            = Disp.empty
1673 showTokenQ x@('-':'-':_) = Disp.text (show x)
1674 showTokenQ x@('.':[])    = Disp.text (show x)
1675 showTokenQ x             = showToken x
1676
1677
1678 -- Handy util
1679 addFields :: [FieldDescr a]
1680           -> ([FieldDescr a] -> [FieldDescr a])
1681 addFields = (++)