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

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