cabal-install-3.6.0.0: src/Distribution/Client/ProjectConfig/Legacy.hs
{-# LANGUAGE RecordWildCards, NamedFieldPuns, DeriveGeneric, ConstraintKinds #-}
-- | Project configuration, implementation in terms of legacy types.
--
module Distribution.Client.ProjectConfig.Legacy (
-- * Project config in terms of legacy types
LegacyProjectConfig,
parseLegacyProjectConfig,
showLegacyProjectConfig,
-- * Conversion to and from legacy config types
commandLineFlagsToProjectConfig,
convertLegacyProjectConfig,
convertLegacyGlobalConfig,
convertToLegacyProjectConfig,
-- * Internals, just for tests
parsePackageLocationTokenQ,
renderPackageLocationToken,
) where
import Prelude ()
import Distribution.Client.Compat.Prelude
import Distribution.Types.Flag (parsecFlagAssignment)
import Distribution.Client.ProjectConfig.Types
import Distribution.Client.Types.RepoName (RepoName (..), unRepoName)
import Distribution.Client.Types.Repo (RemoteRepo(..), LocalRepo (..), emptyRemoteRepo)
import Distribution.Client.Types.AllowNewer (AllowNewer(..), AllowOlder(..))
import Distribution.Client.Types.SourceRepo (sourceRepositoryPackageGrammar, SourceRepoList)
import Distribution.Client.Config
( SavedConfig(..), remoteRepoFields, postProcessRepo )
import Distribution.Client.CmdInstall.ClientInstallFlags
( ClientInstallFlags(..), defaultClientInstallFlags
, clientInstallOptions )
import Distribution.Solver.Types.ConstraintSource
import Distribution.FieldGrammar
import Distribution.Package
import Distribution.Types.SourceRepo (RepoType)
import Distribution.PackageDescription
( dispFlagAssignment )
import Distribution.Simple.Compiler
( OptimisationLevel(..), DebugInfoLevel(..) )
import Distribution.Simple.InstallDirs ( CopyDest (NoCopyDest) )
import Distribution.Simple.Setup
( Flag(Flag), toFlag, fromFlagOrDefault
, ConfigFlags(..), configureOptions
, HaddockFlags(..), haddockOptions, defaultHaddockFlags
, TestFlags(..), testOptions', defaultTestFlags
, BenchmarkFlags(..), benchmarkOptions', defaultBenchmarkFlags
, programDbPaths', splitArgs
)
import Distribution.Client.NixStyleOptions (NixStyleFlags (..))
import Distribution.Client.ProjectFlags (ProjectFlags (..), projectFlagsOptions, defaultProjectFlags)
import Distribution.Client.Setup
( GlobalFlags(..), globalCommand
, ConfigExFlags(..), configureExOptions, defaultConfigExFlags
, InstallFlags(..), installOptions, defaultInstallFlags )
import Distribution.Simple.Program
( programName, knownPrograms )
import Distribution.Simple.Program.Db
( ProgramDb, defaultProgramDb )
import Distribution.Simple.Utils
( lowercase )
import Distribution.Utils.NubList
( toNubList, fromNubList, overNubList )
import Distribution.Simple.LocalBuildInfo
( toPathTemplate, fromPathTemplate )
import qualified Distribution.Deprecated.ReadP as Parse
import Distribution.Deprecated.ReadP
( ReadP, (+++) )
import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint
( Doc, ($+$) )
import qualified Distribution.Deprecated.ParseUtils as ParseUtils
import Distribution.Deprecated.ParseUtils
( ParseResult(..), PError(..), syntaxError, PWarning(..)
, commaNewLineListFieldParsec, newLineListField, parseTokenQ
, parseHaskellString, showToken
, simpleFieldParsec
)
import Distribution.Client.ParseUtils
import Distribution.Simple.Command
( CommandUI(commandOptions), ShowOrParseArgs(..)
, OptionField, option, reqArg' )
import Distribution.Types.PackageVersionConstraint
( PackageVersionConstraint )
import Distribution.Parsec (ParsecParser)
import qualified Data.Map as Map
import qualified Data.ByteString as BS
import Network.URI (URI (..))
------------------------------------------------------------------
-- Representing the project config file in terms of legacy types
--
-- | We already have parsers\/pretty-printers for almost all the fields in the
-- project config file, but they're in terms of the types used for the command
-- line flags for Setup.hs or cabal commands. We don't want to redefine them
-- all, at least not yet so for the moment we use the parsers at the old types
-- and use conversion functions.
--
-- Ultimately if\/when this project-based approach becomes the default then we
-- can redefine the parsers directly for the new types.
--
data LegacyProjectConfig = LegacyProjectConfig {
legacyPackages :: [String],
legacyPackagesOptional :: [String],
legacyPackagesRepo :: [SourceRepoList],
legacyPackagesNamed :: [PackageVersionConstraint],
legacySharedConfig :: LegacySharedConfig,
legacyAllConfig :: LegacyPackageConfig,
legacyLocalConfig :: LegacyPackageConfig,
legacySpecificConfig :: MapMappend PackageName LegacyPackageConfig
} deriving (Show, Generic)
instance Monoid LegacyProjectConfig where
mempty = gmempty
mappend = (<>)
instance Semigroup LegacyProjectConfig where
(<>) = gmappend
data LegacyPackageConfig = LegacyPackageConfig {
legacyConfigureFlags :: ConfigFlags,
legacyInstallPkgFlags :: InstallFlags,
legacyHaddockFlags :: HaddockFlags,
legacyTestFlags :: TestFlags,
legacyBenchmarkFlags :: BenchmarkFlags
} deriving (Show, Generic)
instance Monoid LegacyPackageConfig where
mempty = gmempty
mappend = (<>)
instance Semigroup LegacyPackageConfig where
(<>) = gmappend
data LegacySharedConfig = LegacySharedConfig {
legacyGlobalFlags :: GlobalFlags,
legacyConfigureShFlags :: ConfigFlags,
legacyConfigureExFlags :: ConfigExFlags,
legacyInstallFlags :: InstallFlags,
legacyClientInstallFlags:: ClientInstallFlags,
legacyProjectFlags :: ProjectFlags
} deriving (Show, Generic)
instance Monoid LegacySharedConfig where
mempty = gmempty
mappend = (<>)
instance Semigroup LegacySharedConfig where
(<>) = gmappend
------------------------------------------------------------------
-- Converting from and to the legacy types
--
-- | Convert configuration from the @cabal configure@ or @cabal build@ command
-- line into a 'ProjectConfig' value that can combined with configuration from
-- other sources.
--
-- At the moment this uses the legacy command line flag types. See
-- 'LegacyProjectConfig' for an explanation.
--
commandLineFlagsToProjectConfig :: GlobalFlags
-> NixStyleFlags a
-> ClientInstallFlags
-> ProjectConfig
commandLineFlagsToProjectConfig globalFlags NixStyleFlags {..} clientInstallFlags =
mempty {
projectConfigBuildOnly = convertLegacyBuildOnlyFlags
globalFlags configFlags
installFlags clientInstallFlags
haddockFlags testFlags benchmarkFlags,
projectConfigShared = convertLegacyAllPackageFlags
globalFlags configFlags
configExFlags installFlags projectFlags,
projectConfigLocalPackages = localConfig,
projectConfigAllPackages = allConfig
}
where (localConfig, allConfig) = splitConfig
(convertLegacyPerPackageFlags
configFlags installFlags
haddockFlags testFlags benchmarkFlags)
-- split the package config (from command line arguments) into
-- those applied to all packages and those to local only.
--
-- for now we will just copy over the ProgramPaths/Args/Extra into
-- the AllPackages. The LocalPackages do not inherit them from
-- AllPackages, and as such need to retain them.
--
-- The general decision rule for what to put into allConfig
-- into localConfig is the following:
--
-- - anything that is host/toolchain/env specific should be applied
-- to all packages, as packagesets have to be host/toolchain/env
-- consistent.
-- - anything else should be in the local config and could potentially
-- be lifted into all-packages vial the `package *` cabal.project
-- section.
--
splitConfig :: PackageConfig -> (PackageConfig, PackageConfig)
splitConfig pc = (pc
, mempty { packageConfigProgramPaths = packageConfigProgramPaths pc
, packageConfigProgramArgs = packageConfigProgramArgs pc
, packageConfigProgramPathExtra = packageConfigProgramPathExtra pc
, packageConfigDocumentation = packageConfigDocumentation pc })
-- | Convert from the types currently used for the user-wide @~/.cabal/config@
-- file into the 'ProjectConfig' type.
--
-- Only a subset of the 'ProjectConfig' can be represented in the user-wide
-- config. In particular it does not include packages that are in the project,
-- and it also doesn't support package-specific configuration (only
-- configuration that applies to all packages).
--
convertLegacyGlobalConfig :: SavedConfig -> ProjectConfig
convertLegacyGlobalConfig
SavedConfig {
savedGlobalFlags = globalFlags,
savedInstallFlags = installFlags,
savedClientInstallFlags= clientInstallFlags,
savedConfigureFlags = configFlags,
savedConfigureExFlags = configExFlags,
savedUserInstallDirs = _,
savedGlobalInstallDirs = _,
savedUploadFlags = _,
savedReportFlags = _,
savedHaddockFlags = haddockFlags,
savedTestFlags = testFlags,
savedBenchmarkFlags = benchmarkFlags,
savedProjectFlags = projectFlags
} =
mempty {
projectConfigBuildOnly = configBuildOnly,
projectConfigShared = configShared,
projectConfigAllPackages = configAllPackages
}
where
--TODO: [code cleanup] eliminate use of default*Flags here and specify the
-- defaults in the various resolve functions in terms of the new types.
configExFlags' = defaultConfigExFlags <> configExFlags
installFlags' = defaultInstallFlags <> installFlags
clientInstallFlags' = defaultClientInstallFlags <> clientInstallFlags
haddockFlags' = defaultHaddockFlags <> haddockFlags
testFlags' = defaultTestFlags <> testFlags
benchmarkFlags' = defaultBenchmarkFlags <> benchmarkFlags
projectFlags' = defaultProjectFlags <> projectFlags
configAllPackages = convertLegacyPerPackageFlags
configFlags installFlags'
haddockFlags' testFlags' benchmarkFlags'
configShared = convertLegacyAllPackageFlags
globalFlags configFlags
configExFlags' installFlags' projectFlags'
configBuildOnly = convertLegacyBuildOnlyFlags
globalFlags configFlags
installFlags' clientInstallFlags'
haddockFlags' testFlags' benchmarkFlags'
-- | Convert the project config from the legacy types to the 'ProjectConfig'
-- and associated types. See 'LegacyProjectConfig' for an explanation of the
-- approach.
--
convertLegacyProjectConfig :: LegacyProjectConfig -> ProjectConfig
convertLegacyProjectConfig
LegacyProjectConfig {
legacyPackages,
legacyPackagesOptional,
legacyPackagesRepo,
legacyPackagesNamed,
legacySharedConfig = LegacySharedConfig globalFlags configShFlags
configExFlags installSharedFlags
clientInstallFlags projectFlags,
legacyAllConfig,
legacyLocalConfig = LegacyPackageConfig configFlags installPerPkgFlags
haddockFlags testFlags benchmarkFlags,
legacySpecificConfig
} =
ProjectConfig {
projectPackages = legacyPackages,
projectPackagesOptional = legacyPackagesOptional,
projectPackagesRepo = legacyPackagesRepo,
projectPackagesNamed = legacyPackagesNamed,
projectConfigBuildOnly = configBuildOnly,
projectConfigShared = configPackagesShared,
projectConfigProvenance = mempty,
projectConfigAllPackages = configAllPackages,
projectConfigLocalPackages = configLocalPackages,
projectConfigSpecificPackage = fmap perPackage legacySpecificConfig
}
where
configAllPackages = convertLegacyPerPackageFlags g i h t b
where LegacyPackageConfig g i h t b = legacyAllConfig
configLocalPackages = convertLegacyPerPackageFlags
configFlags installPerPkgFlags haddockFlags
testFlags benchmarkFlags
configPackagesShared= convertLegacyAllPackageFlags
globalFlags (configFlags <> configShFlags)
configExFlags installSharedFlags projectFlags
configBuildOnly = convertLegacyBuildOnlyFlags
globalFlags configShFlags
installSharedFlags clientInstallFlags
haddockFlags testFlags benchmarkFlags
perPackage (LegacyPackageConfig perPkgConfigFlags perPkgInstallFlags
perPkgHaddockFlags perPkgTestFlags
perPkgBenchmarkFlags) =
convertLegacyPerPackageFlags
perPkgConfigFlags perPkgInstallFlags perPkgHaddockFlags
perPkgTestFlags perPkgBenchmarkFlags
-- | Helper used by other conversion functions that returns the
-- 'ProjectConfigShared' subset of the 'ProjectConfig'.
--
convertLegacyAllPackageFlags
:: GlobalFlags
-> ConfigFlags
-> ConfigExFlags
-> InstallFlags
-> ProjectFlags
-> ProjectConfigShared
convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags projectFlags =
ProjectConfigShared{..}
where
GlobalFlags {
globalConfigFile = projectConfigConfigFile,
globalRemoteRepos = projectConfigRemoteRepos,
globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos,
globalActiveRepos = projectConfigActiveRepos,
globalProgPathExtra = projectConfigProgPathExtra,
globalStoreDir = projectConfigStoreDir
} = globalFlags
ConfigFlags {
configDistPref = projectConfigDistDir,
configHcFlavor = projectConfigHcFlavor,
configHcPath = projectConfigHcPath,
configHcPkg = projectConfigHcPkg
--configProgramPathExtra = projectConfigProgPathExtra DELETE ME
--configInstallDirs = projectConfigInstallDirs,
--configUserInstall = projectConfigUserInstall,
--configPackageDBs = projectConfigPackageDBs,
} = configFlags
ConfigExFlags {
configCabalVersion = projectConfigCabalVersion,
configExConstraints = projectConfigConstraints,
configPreferences = projectConfigPreferences,
configSolver = projectConfigSolver,
configAllowOlder = projectConfigAllowOlder,
configAllowNewer = projectConfigAllowNewer,
configWriteGhcEnvironmentFilesPolicy
= projectConfigWriteGhcEnvironmentFilesPolicy
} = configExFlags
InstallFlags {
installHaddockIndex = projectConfigHaddockIndex,
--installReinstall = projectConfigReinstall,
--installAvoidReinstalls = projectConfigAvoidReinstalls,
--installOverrideReinstall = projectConfigOverrideReinstall,
installIndexState = projectConfigIndexState,
installMaxBackjumps = projectConfigMaxBackjumps,
--installUpgradeDeps = projectConfigUpgradeDeps,
installReorderGoals = projectConfigReorderGoals,
installCountConflicts = projectConfigCountConflicts,
installFineGrainedConflicts = projectConfigFineGrainedConflicts,
installMinimizeConflictSet = projectConfigMinimizeConflictSet,
installPerComponent = projectConfigPerComponent,
installIndependentGoals = projectConfigIndependentGoals,
--installShadowPkgs = projectConfigShadowPkgs,
installStrongFlags = projectConfigStrongFlags,
installAllowBootLibInstalls = projectConfigAllowBootLibInstalls,
installOnlyConstrained = projectConfigOnlyConstrained
} = installFlags
ProjectFlags
{ flagProjectFileName = projectConfigProjectFile
, flagIgnoreProject = projectConfigIgnoreProject
} = projectFlags
-- | Helper used by other conversion functions that returns the
-- 'PackageConfig' subset of the 'ProjectConfig'.
--
convertLegacyPerPackageFlags :: ConfigFlags -> InstallFlags -> HaddockFlags
-> TestFlags -> BenchmarkFlags -> PackageConfig
convertLegacyPerPackageFlags configFlags installFlags
haddockFlags testFlags benchmarkFlags =
PackageConfig{..}
where
ConfigFlags {
configProgramPaths,
configProgramArgs,
configProgramPathExtra = packageConfigProgramPathExtra,
configVanillaLib = packageConfigVanillaLib,
configProfLib = packageConfigProfLib,
configSharedLib = packageConfigSharedLib,
configStaticLib = packageConfigStaticLib,
configDynExe = packageConfigDynExe,
configFullyStaticExe = packageConfigFullyStaticExe,
configProfExe = packageConfigProfExe,
configProf = packageConfigProf,
configProfDetail = packageConfigProfDetail,
configProfLibDetail = packageConfigProfLibDetail,
configConfigureArgs = packageConfigConfigureArgs,
configOptimization = packageConfigOptimization,
configProgPrefix = packageConfigProgPrefix,
configProgSuffix = packageConfigProgSuffix,
configGHCiLib = packageConfigGHCiLib,
configSplitSections = packageConfigSplitSections,
configSplitObjs = packageConfigSplitObjs,
configStripExes = packageConfigStripExes,
configStripLibs = packageConfigStripLibs,
configExtraLibDirs = packageConfigExtraLibDirs,
configExtraFrameworkDirs = packageConfigExtraFrameworkDirs,
configExtraIncludeDirs = packageConfigExtraIncludeDirs,
configConfigurationsFlags = packageConfigFlagAssignment,
configTests = packageConfigTests,
configBenchmarks = packageConfigBenchmarks,
configCoverage = coverage,
configLibCoverage = libcoverage, --deprecated
configDebugInfo = packageConfigDebugInfo,
configRelocatable = packageConfigRelocatable
} = configFlags
packageConfigProgramPaths = MapLast (Map.fromList configProgramPaths)
packageConfigProgramArgs = MapMappend (Map.fromListWith (++) configProgramArgs)
packageConfigCoverage = coverage <> libcoverage
--TODO: defer this merging to the resolve phase
InstallFlags {
installDocumentation = packageConfigDocumentation,
installRunTests = packageConfigRunTests
} = installFlags
HaddockFlags {
haddockHoogle = packageConfigHaddockHoogle,
haddockHtml = packageConfigHaddockHtml,
haddockHtmlLocation = packageConfigHaddockHtmlLocation,
haddockForeignLibs = packageConfigHaddockForeignLibs,
haddockForHackage = packageConfigHaddockForHackage,
haddockExecutables = packageConfigHaddockExecutables,
haddockTestSuites = packageConfigHaddockTestSuites,
haddockBenchmarks = packageConfigHaddockBenchmarks,
haddockInternal = packageConfigHaddockInternal,
haddockCss = packageConfigHaddockCss,
haddockLinkedSource = packageConfigHaddockLinkedSource,
haddockQuickJump = packageConfigHaddockQuickJump,
haddockHscolourCss = packageConfigHaddockHscolourCss,
haddockContents = packageConfigHaddockContents
} = haddockFlags
TestFlags {
testHumanLog = packageConfigTestHumanLog,
testMachineLog = packageConfigTestMachineLog,
testShowDetails = packageConfigTestShowDetails,
testKeepTix = packageConfigTestKeepTix,
testWrapper = packageConfigTestWrapper,
testFailWhenNoTestSuites = packageConfigTestFailWhenNoTestSuites,
testOptions = packageConfigTestTestOptions
} = testFlags
BenchmarkFlags {
benchmarkOptions = packageConfigBenchmarkOptions
} = benchmarkFlags
-- | Helper used by other conversion functions that returns the
-- 'ProjectConfigBuildOnly' subset of the 'ProjectConfig'.
--
convertLegacyBuildOnlyFlags :: GlobalFlags -> ConfigFlags
-> InstallFlags -> ClientInstallFlags
-> HaddockFlags -> TestFlags
-> BenchmarkFlags
-> ProjectConfigBuildOnly
convertLegacyBuildOnlyFlags globalFlags configFlags
installFlags clientInstallFlags
haddockFlags _ _ =
ProjectConfigBuildOnly{..}
where
projectConfigClientInstallFlags = clientInstallFlags
GlobalFlags {
globalCacheDir = projectConfigCacheDir,
globalLogsDir = projectConfigLogsDir,
globalWorldFile = _,
globalHttpTransport = projectConfigHttpTransport,
globalIgnoreExpiry = projectConfigIgnoreExpiry
} = globalFlags
ConfigFlags {
configVerbosity = projectConfigVerbosity
} = configFlags
InstallFlags {
installDryRun = projectConfigDryRun,
installOnlyDownload = projectConfigOnlyDownload,
installOnly = _,
installOnlyDeps = projectConfigOnlyDeps,
installRootCmd = _,
installSummaryFile = projectConfigSummaryFile,
installLogFile = projectConfigLogFile,
installBuildReports = projectConfigBuildReports,
installReportPlanningFailure = projectConfigReportPlanningFailure,
installSymlinkBinDir = projectConfigSymlinkBinDir,
installOneShot = projectConfigOneShot,
installNumJobs = projectConfigNumJobs,
installKeepGoing = projectConfigKeepGoing,
installOfflineMode = projectConfigOfflineMode
} = installFlags
HaddockFlags {
haddockKeepTempFiles = projectConfigKeepTempFiles --TODO: this ought to live elsewhere
} = haddockFlags
convertToLegacyProjectConfig :: ProjectConfig -> LegacyProjectConfig
convertToLegacyProjectConfig
projectConfig@ProjectConfig {
projectPackages,
projectPackagesOptional,
projectPackagesRepo,
projectPackagesNamed,
projectConfigAllPackages,
projectConfigLocalPackages,
projectConfigSpecificPackage
} =
LegacyProjectConfig {
legacyPackages = projectPackages,
legacyPackagesOptional = projectPackagesOptional,
legacyPackagesRepo = projectPackagesRepo,
legacyPackagesNamed = projectPackagesNamed,
legacySharedConfig = convertToLegacySharedConfig projectConfig,
legacyAllConfig = convertToLegacyPerPackageConfig
projectConfigAllPackages,
legacyLocalConfig = convertToLegacyAllPackageConfig projectConfig
<> convertToLegacyPerPackageConfig
projectConfigLocalPackages,
legacySpecificConfig = fmap convertToLegacyPerPackageConfig
projectConfigSpecificPackage
}
convertToLegacySharedConfig :: ProjectConfig -> LegacySharedConfig
convertToLegacySharedConfig
ProjectConfig {
projectConfigBuildOnly = ProjectConfigBuildOnly {..},
projectConfigShared = ProjectConfigShared {..},
projectConfigAllPackages = PackageConfig {
packageConfigDocumentation
}
} =
LegacySharedConfig
{ legacyGlobalFlags = globalFlags
, legacyConfigureShFlags = configFlags
, legacyConfigureExFlags = configExFlags
, legacyInstallFlags = installFlags
, legacyClientInstallFlags = projectConfigClientInstallFlags
, legacyProjectFlags = projectFlags
}
where
globalFlags = GlobalFlags {
globalVersion = mempty,
globalNumericVersion = mempty,
globalConfigFile = projectConfigConfigFile,
globalConstraintsFile = mempty,
globalRemoteRepos = projectConfigRemoteRepos,
globalCacheDir = projectConfigCacheDir,
globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos,
globalActiveRepos = projectConfigActiveRepos,
globalLogsDir = projectConfigLogsDir,
globalWorldFile = mempty,
globalIgnoreExpiry = projectConfigIgnoreExpiry,
globalHttpTransport = projectConfigHttpTransport,
globalNix = mempty,
globalStoreDir = projectConfigStoreDir,
globalProgPathExtra = projectConfigProgPathExtra
}
configFlags = mempty {
configVerbosity = projectConfigVerbosity,
configDistPref = projectConfigDistDir
}
configExFlags = ConfigExFlags {
configCabalVersion = projectConfigCabalVersion,
configExConstraints = projectConfigConstraints,
configPreferences = projectConfigPreferences,
configSolver = projectConfigSolver,
configAllowOlder = projectConfigAllowOlder,
configAllowNewer = projectConfigAllowNewer,
configWriteGhcEnvironmentFilesPolicy
= projectConfigWriteGhcEnvironmentFilesPolicy
}
installFlags = InstallFlags {
installDocumentation = packageConfigDocumentation,
installHaddockIndex = projectConfigHaddockIndex,
installDest = Flag NoCopyDest,
installDryRun = projectConfigDryRun,
installOnlyDownload = projectConfigOnlyDownload,
installReinstall = mempty, --projectConfigReinstall,
installAvoidReinstalls = mempty, --projectConfigAvoidReinstalls,
installOverrideReinstall = mempty, --projectConfigOverrideReinstall,
installMaxBackjumps = projectConfigMaxBackjumps,
installUpgradeDeps = mempty, --projectConfigUpgradeDeps,
installReorderGoals = projectConfigReorderGoals,
installCountConflicts = projectConfigCountConflicts,
installFineGrainedConflicts = projectConfigFineGrainedConflicts,
installMinimizeConflictSet = projectConfigMinimizeConflictSet,
installIndependentGoals = projectConfigIndependentGoals,
installShadowPkgs = mempty, --projectConfigShadowPkgs,
installStrongFlags = projectConfigStrongFlags,
installAllowBootLibInstalls = projectConfigAllowBootLibInstalls,
installOnlyConstrained = projectConfigOnlyConstrained,
installOnly = mempty,
installOnlyDeps = projectConfigOnlyDeps,
installIndexState = projectConfigIndexState,
installRootCmd = mempty, --no longer supported
installSummaryFile = projectConfigSummaryFile,
installLogFile = projectConfigLogFile,
installBuildReports = projectConfigBuildReports,
installReportPlanningFailure = projectConfigReportPlanningFailure,
installSymlinkBinDir = projectConfigSymlinkBinDir,
installPerComponent = projectConfigPerComponent,
installOneShot = projectConfigOneShot,
installNumJobs = projectConfigNumJobs,
installKeepGoing = projectConfigKeepGoing,
installRunTests = mempty,
installOfflineMode = projectConfigOfflineMode
}
projectFlags = ProjectFlags
{ flagProjectFileName = projectConfigProjectFile
, flagIgnoreProject = projectConfigIgnoreProject
}
convertToLegacyAllPackageConfig :: ProjectConfig -> LegacyPackageConfig
convertToLegacyAllPackageConfig
ProjectConfig {
projectConfigBuildOnly = ProjectConfigBuildOnly {..},
projectConfigShared = ProjectConfigShared {..}
} =
LegacyPackageConfig {
legacyConfigureFlags = configFlags,
legacyInstallPkgFlags= mempty,
legacyHaddockFlags = haddockFlags,
legacyTestFlags = mempty,
legacyBenchmarkFlags = mempty
}
where
configFlags = ConfigFlags {
configArgs = mempty,
configPrograms_ = mempty,
configProgramPaths = mempty,
configProgramArgs = mempty,
configProgramPathExtra = mempty,
configHcFlavor = projectConfigHcFlavor,
configHcPath = projectConfigHcPath,
configHcPkg = projectConfigHcPkg,
configInstantiateWith = mempty,
configVanillaLib = mempty,
configProfLib = mempty,
configSharedLib = mempty,
configStaticLib = mempty,
configDynExe = mempty,
configFullyStaticExe = mempty,
configProfExe = mempty,
configProf = mempty,
configProfDetail = mempty,
configProfLibDetail = mempty,
configConfigureArgs = mempty,
configOptimization = mempty,
configProgPrefix = mempty,
configProgSuffix = mempty,
configInstallDirs = mempty,
configScratchDir = mempty,
configDistPref = mempty,
configCabalFilePath = mempty,
configVerbosity = mempty,
configUserInstall = mempty, --projectConfigUserInstall,
configPackageDBs = mempty, --projectConfigPackageDBs,
configGHCiLib = mempty,
configSplitSections = mempty,
configSplitObjs = mempty,
configStripExes = mempty,
configStripLibs = mempty,
configExtraLibDirs = mempty,
configExtraFrameworkDirs = mempty,
configConstraints = mempty,
configDependencies = mempty,
configExtraIncludeDirs = mempty,
configDeterministic = mempty,
configIPID = mempty,
configCID = mempty,
configConfigurationsFlags = mempty,
configTests = mempty,
configCoverage = mempty, --TODO: don't merge
configLibCoverage = mempty, --TODO: don't merge
configExactConfiguration = mempty,
configBenchmarks = mempty,
configFlagError = mempty, --TODO: ???
configRelocatable = mempty,
configDebugInfo = mempty,
configUseResponseFiles = mempty,
configAllowDependingOnPrivateLibs = mempty
}
haddockFlags = mempty {
haddockKeepTempFiles = projectConfigKeepTempFiles
}
convertToLegacyPerPackageConfig :: PackageConfig -> LegacyPackageConfig
convertToLegacyPerPackageConfig PackageConfig {..} =
LegacyPackageConfig {
legacyConfigureFlags = configFlags,
legacyInstallPkgFlags = installFlags,
legacyHaddockFlags = haddockFlags,
legacyTestFlags = testFlags,
legacyBenchmarkFlags = benchmarkFlags
}
where
configFlags = ConfigFlags {
configArgs = mempty,
configPrograms_ = configPrograms_ mempty,
configProgramPaths = Map.toList (getMapLast packageConfigProgramPaths),
configProgramArgs = Map.toList (getMapMappend packageConfigProgramArgs),
configProgramPathExtra = packageConfigProgramPathExtra,
configHcFlavor = mempty,
configHcPath = mempty,
configHcPkg = mempty,
configInstantiateWith = mempty,
configVanillaLib = packageConfigVanillaLib,
configProfLib = packageConfigProfLib,
configSharedLib = packageConfigSharedLib,
configStaticLib = packageConfigStaticLib,
configDynExe = packageConfigDynExe,
configFullyStaticExe = packageConfigFullyStaticExe,
configProfExe = packageConfigProfExe,
configProf = packageConfigProf,
configProfDetail = packageConfigProfDetail,
configProfLibDetail = packageConfigProfLibDetail,
configConfigureArgs = packageConfigConfigureArgs,
configOptimization = packageConfigOptimization,
configProgPrefix = packageConfigProgPrefix,
configProgSuffix = packageConfigProgSuffix,
configInstallDirs = mempty,
configScratchDir = mempty,
configDistPref = mempty,
configCabalFilePath = mempty,
configVerbosity = mempty,
configUserInstall = mempty,
configPackageDBs = mempty,
configGHCiLib = packageConfigGHCiLib,
configSplitSections = packageConfigSplitSections,
configSplitObjs = packageConfigSplitObjs,
configStripExes = packageConfigStripExes,
configStripLibs = packageConfigStripLibs,
configExtraLibDirs = packageConfigExtraLibDirs,
configExtraFrameworkDirs = packageConfigExtraFrameworkDirs,
configConstraints = mempty,
configDependencies = mempty,
configExtraIncludeDirs = packageConfigExtraIncludeDirs,
configIPID = mempty,
configCID = mempty,
configDeterministic = mempty,
configConfigurationsFlags = packageConfigFlagAssignment,
configTests = packageConfigTests,
configCoverage = packageConfigCoverage, --TODO: don't merge
configLibCoverage = packageConfigCoverage, --TODO: don't merge
configExactConfiguration = mempty,
configBenchmarks = packageConfigBenchmarks,
configFlagError = mempty, --TODO: ???
configRelocatable = packageConfigRelocatable,
configDebugInfo = packageConfigDebugInfo,
configUseResponseFiles = mempty,
configAllowDependingOnPrivateLibs = mempty
}
installFlags = mempty {
installDocumentation = packageConfigDocumentation,
installRunTests = packageConfigRunTests
}
haddockFlags = HaddockFlags {
haddockProgramPaths = mempty,
haddockProgramArgs = mempty,
haddockHoogle = packageConfigHaddockHoogle,
haddockHtml = packageConfigHaddockHtml,
haddockHtmlLocation = packageConfigHaddockHtmlLocation,
haddockForHackage = packageConfigHaddockForHackage,
haddockForeignLibs = packageConfigHaddockForeignLibs,
haddockExecutables = packageConfigHaddockExecutables,
haddockTestSuites = packageConfigHaddockTestSuites,
haddockBenchmarks = packageConfigHaddockBenchmarks,
haddockInternal = packageConfigHaddockInternal,
haddockCss = packageConfigHaddockCss,
haddockLinkedSource = packageConfigHaddockLinkedSource,
haddockQuickJump = packageConfigHaddockQuickJump,
haddockHscolourCss = packageConfigHaddockHscolourCss,
haddockContents = packageConfigHaddockContents,
haddockDistPref = mempty,
haddockKeepTempFiles = mempty,
haddockVerbosity = mempty,
haddockCabalFilePath = mempty,
haddockArgs = mempty
}
testFlags = TestFlags {
testDistPref = mempty,
testVerbosity = mempty,
testHumanLog = packageConfigTestHumanLog,
testMachineLog = packageConfigTestMachineLog,
testShowDetails = packageConfigTestShowDetails,
testKeepTix = packageConfigTestKeepTix,
testWrapper = packageConfigTestWrapper,
testFailWhenNoTestSuites = packageConfigTestFailWhenNoTestSuites,
testOptions = packageConfigTestTestOptions
}
benchmarkFlags = BenchmarkFlags {
benchmarkDistPref = mempty,
benchmarkVerbosity = mempty,
benchmarkOptions = packageConfigBenchmarkOptions
}
------------------------------------------------
-- Parsing and showing the project config file
--
parseLegacyProjectConfig :: FilePath -> BS.ByteString -> ParseResult LegacyProjectConfig
parseLegacyProjectConfig source =
parseConfig (legacyProjectConfigFieldDescrs constraintSrc)
legacyPackageConfigSectionDescrs
legacyPackageConfigFGSectionDescrs
mempty
where
constraintSrc = ConstraintSourceProjectConfig source
showLegacyProjectConfig :: LegacyProjectConfig -> String
showLegacyProjectConfig config =
Disp.render $
showConfig (legacyProjectConfigFieldDescrs constraintSrc)
legacyPackageConfigSectionDescrs
legacyPackageConfigFGSectionDescrs
config
$+$
Disp.text ""
where
-- Note: ConstraintSource is unused when pretty-printing. We fake
-- it here to avoid having to pass it on call-sites. It's not great
-- but requires re-work of how we annotate provenance.
constraintSrc = ConstraintSourceProjectConfig "unused"
legacyProjectConfigFieldDescrs :: ConstraintSource -> [FieldDescr LegacyProjectConfig]
legacyProjectConfigFieldDescrs constraintSrc =
[ newLineListField "packages"
(Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ
legacyPackages
(\v flags -> flags { legacyPackages = v })
, newLineListField "optional-packages"
(Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ
legacyPackagesOptional
(\v flags -> flags { legacyPackagesOptional = v })
, commaNewLineListFieldParsec "extra-packages"
pretty parsec
legacyPackagesNamed
(\v flags -> flags { legacyPackagesNamed = v })
]
++ map (liftField
legacySharedConfig
(\flags conf -> conf { legacySharedConfig = flags }))
(legacySharedConfigFieldDescrs constraintSrc)
++ map (liftField
legacyLocalConfig
(\flags conf -> conf { legacyLocalConfig = flags }))
legacyPackageConfigFieldDescrs
-- | This is a bit tricky since it has to cover globs which have embedded @,@
-- chars. But we don't just want to parse strictly as a glob since we want to
-- allow http urls which don't parse as globs, and possibly some
-- system-dependent file paths. So we parse fairly liberally as a token, but
-- we allow @,@ inside matched @{}@ braces.
--
parsePackageLocationTokenQ :: ReadP r String
parsePackageLocationTokenQ = parseHaskellString
Parse.<++ parsePackageLocationToken
where
parsePackageLocationToken :: ReadP r String
parsePackageLocationToken = fmap fst (Parse.gather outerTerm)
where
outerTerm = alternateEither1 outerToken (braces innerTerm)
innerTerm = alternateEither innerToken (braces innerTerm)
outerToken = Parse.munch1 outerChar >> return ()
innerToken = Parse.munch1 innerChar >> return ()
outerChar c = not (isSpace c || c == '{' || c == '}' || c == ',')
innerChar c = not (isSpace c || c == '{' || c == '}')
braces = Parse.between (Parse.char '{') (Parse.char '}')
alternateEither, alternateEither1,
alternatePQs, alternate1PQs, alternateQsP, alternate1QsP
:: ReadP r () -> ReadP r () -> ReadP r ()
alternateEither1 p q = alternate1PQs p q +++ alternate1QsP q p
alternateEither p q = alternateEither1 p q +++ return ()
alternate1PQs p q = p >> alternateQsP q p
alternatePQs p q = alternate1PQs p q +++ return ()
alternate1QsP q p = Parse.many1 q >> alternatePQs p q
alternateQsP q p = alternate1QsP q p +++ return ()
renderPackageLocationToken :: String -> String
renderPackageLocationToken s | needsQuoting = show s
| otherwise = s
where
needsQuoting = not (ok 0 s)
|| s == "." -- . on its own on a line has special meaning
|| take 2 s == "--" -- on its own line is comment syntax
--TODO: [code cleanup] these "." and "--" escaping issues
-- ought to be dealt with systematically in ParseUtils.
ok :: Int -> String -> Bool
ok n [] = n == 0
ok _ ('"':_) = False
ok n ('{':cs) = ok (n+1) cs
ok n ('}':cs) = ok (n-1) cs
ok n (',':cs) = (n > 0) && ok n cs
ok _ (c:_)
| isSpace c = False
ok n (_ :cs) = ok n cs
legacySharedConfigFieldDescrs :: ConstraintSource -> [FieldDescr LegacySharedConfig]
legacySharedConfigFieldDescrs constraintSrc = concat
[ liftFields
legacyGlobalFlags
(\flags conf -> conf { legacyGlobalFlags = flags })
. addFields
[ newLineListField "extra-prog-path-shared-only"
showTokenQ parseTokenQ
(fromNubList . globalProgPathExtra)
(\v conf -> conf { globalProgPathExtra = toNubList v })
]
. filterFields
[ "remote-repo-cache"
, "logs-dir", "store-dir", "ignore-expiry", "http-transport"
, "active-repositories"
]
. commandOptionsToFields
$ commandOptions (globalCommand []) ParseArgs
, liftFields
legacyConfigureShFlags
(\flags conf -> conf { legacyConfigureShFlags = flags })
. filterFields ["verbose", "builddir" ]
. commandOptionsToFields
$ configureOptions ParseArgs
, liftFields
legacyConfigureExFlags
(\flags conf -> conf { legacyConfigureExFlags = flags })
. addFields
[ commaNewLineListFieldParsec "constraints"
(pretty . fst) (fmap (\constraint -> (constraint, constraintSrc)) parsec)
configExConstraints (\v conf -> conf { configExConstraints = v })
, commaNewLineListFieldParsec "preferences"
pretty parsec
configPreferences (\v conf -> conf { configPreferences = v })
, monoidFieldParsec "allow-older"
(maybe mempty pretty) (fmap Just parsec)
(fmap unAllowOlder . configAllowOlder)
(\v conf -> conf { configAllowOlder = fmap AllowOlder v })
, monoidFieldParsec "allow-newer"
(maybe mempty pretty) (fmap Just parsec)
(fmap unAllowNewer . configAllowNewer)
(\v conf -> conf { configAllowNewer = fmap AllowNewer v })
]
. filterFields
[ "cabal-lib-version", "solver", "write-ghc-environment-files"
-- not "constraint" or "preference", we use our own plural ones above
]
. commandOptionsToFields
$ configureExOptions ParseArgs constraintSrc
, liftFields
legacyInstallFlags
(\flags conf -> conf { legacyInstallFlags = flags })
. addFields
[ newLineListField "build-summary"
(showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ)
(fromNubList . installSummaryFile)
(\v conf -> conf { installSummaryFile = toNubList v })
]
. filterFields
[ "doc-index-file"
, "root-cmd", "symlink-bindir"
, "build-log"
, "remote-build-reporting", "report-planning-failure"
, "one-shot", "jobs", "keep-going", "offline", "per-component"
-- solver flags:
, "max-backjumps", "reorder-goals", "count-conflicts"
, "fine-grained-conflicts" , "minimize-conflict-set", "independent-goals"
, "strong-flags" , "allow-boot-library-installs"
, "reject-unconstrained-dependencies", "index-state"
]
. commandOptionsToFields
$ installOptions ParseArgs
, liftFields
legacyClientInstallFlags
(\flags conf -> conf { legacyClientInstallFlags = flags })
. commandOptionsToFields
$ clientInstallOptions ParseArgs
, liftFields
legacyProjectFlags
(\flags conf -> conf { legacyProjectFlags = flags })
. commandOptionsToFields
$ projectFlagsOptions ParseArgs
]
legacyPackageConfigFieldDescrs :: [FieldDescr LegacyPackageConfig]
legacyPackageConfigFieldDescrs =
( liftFields
legacyConfigureFlags
(\flags conf -> conf { legacyConfigureFlags = flags })
. addFields
[ newLineListField "extra-include-dirs"
showTokenQ parseTokenQ
configExtraIncludeDirs
(\v conf -> conf { configExtraIncludeDirs = v })
, newLineListField "extra-lib-dirs"
showTokenQ parseTokenQ
configExtraLibDirs
(\v conf -> conf { configExtraLibDirs = v })
, newLineListField "extra-framework-dirs"
showTokenQ parseTokenQ
configExtraFrameworkDirs
(\v conf -> conf { configExtraFrameworkDirs = v })
, newLineListField "extra-prog-path"
showTokenQ parseTokenQ
(fromNubList . configProgramPathExtra)
(\v conf -> conf { configProgramPathExtra = toNubList v })
, newLineListField "configure-options"
showTokenQ parseTokenQ
configConfigureArgs
(\v conf -> conf { configConfigureArgs = v })
, simpleFieldParsec "flags"
dispFlagAssignment parsecFlagAssignment
configConfigurationsFlags
(\v conf -> conf { configConfigurationsFlags = v })
]
. filterFields
[ "with-compiler", "with-hc-pkg"
, "program-prefix", "program-suffix"
, "library-vanilla", "library-profiling"
, "shared", "static", "executable-dynamic", "executable-static"
, "profiling", "executable-profiling"
, "profiling-detail", "library-profiling-detail"
, "library-for-ghci", "split-objs", "split-sections"
, "executable-stripping", "library-stripping"
, "tests", "benchmarks"
, "coverage", "library-coverage"
, "relocatable"
-- not "extra-include-dirs", "extra-lib-dirs", "extra-framework-dirs"
-- or "extra-prog-path". We use corrected ones above that parse
-- as list fields.
]
. commandOptionsToFields
) (configureOptions ParseArgs)
++
liftFields
legacyConfigureFlags
(\flags conf -> conf { legacyConfigureFlags = flags })
[ overrideFieldCompiler
, overrideFieldOptimization
, overrideFieldDebugInfo
]
++
( liftFields
legacyInstallPkgFlags
(\flags conf -> conf { legacyInstallPkgFlags = flags })
. filterFields
[ "documentation", "run-tests"
]
. commandOptionsToFields
) (installOptions ParseArgs)
++
( liftFields
legacyHaddockFlags
(\flags conf -> conf { legacyHaddockFlags = flags })
. mapFieldNames
("haddock-"++)
. addFields
[ simpleFieldParsec "for-hackage"
-- TODO: turn this into a library function
(fromFlagOrDefault Disp.empty . fmap pretty) (toFlag <$> parsec <|> pure mempty)
haddockForHackage (\v conf -> conf { haddockForHackage = v })
]
. filterFields
[ "hoogle", "html", "html-location"
, "foreign-libraries"
, "executables", "tests", "benchmarks", "all", "internal", "css"
, "hyperlink-source", "quickjump", "hscolour-css"
, "contents-location", "keep-temp-files"
]
. commandOptionsToFields
) (haddockOptions ParseArgs)
++
( liftFields
legacyTestFlags
(\flags conf -> conf { legacyTestFlags = flags })
. mapFieldNames
prefixTest
. addFields
[ newLineListField "test-options"
(showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ)
testOptions
(\v conf -> conf { testOptions = v })
]
. filterFields
[ "log", "machine-log", "show-details", "keep-tix-files"
, "fail-when-no-test-suites", "test-wrapper" ]
. commandOptionsToFields
) (testOptions' ParseArgs)
++
( liftFields
legacyBenchmarkFlags
(\flags conf -> conf { legacyBenchmarkFlags = flags })
. addFields
[ newLineListField "benchmark-options"
(showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ)
benchmarkOptions
(\v conf -> conf { benchmarkOptions = v })
]
. filterFields
[]
. commandOptionsToFields
) (benchmarkOptions' ParseArgs)
where
overrideFieldCompiler =
simpleFieldParsec "compiler"
(fromFlagOrDefault Disp.empty . fmap pretty)
(toFlag <$> parsec <|> pure mempty)
configHcFlavor (\v flags -> flags { configHcFlavor = v })
-- TODO: [code cleanup] The following is a hack. The "optimization" and
-- "debug-info" fields are OptArg, and viewAsFieldDescr fails on that.
-- Instead of a hand-written parser and printer, we should handle this case
-- properly in the library.
overrideFieldOptimization =
liftField configOptimization
(\v flags -> flags { configOptimization = v }) $
let name = "optimization" in
FieldDescr name
(\f -> case f of
Flag NoOptimisation -> Disp.text "False"
Flag NormalOptimisation -> Disp.text "True"
Flag MaximumOptimisation -> Disp.text "2"
_ -> Disp.empty)
(\line str _ -> case () of
_ | str == "False" -> ParseOk [] (Flag NoOptimisation)
| str == "True" -> ParseOk [] (Flag NormalOptimisation)
| str == "0" -> ParseOk [] (Flag NoOptimisation)
| str == "1" -> ParseOk [] (Flag NormalOptimisation)
| str == "2" -> ParseOk [] (Flag MaximumOptimisation)
| lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation)
| lstr == "true" -> ParseOk [caseWarning] (Flag NormalOptimisation)
| otherwise -> ParseFailed (NoParse name line)
where
lstr = lowercase str
caseWarning = PWarning $
"The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.")
overrideFieldDebugInfo =
liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $
let name = "debug-info" in
FieldDescr name
(\f -> case f of
Flag NoDebugInfo -> Disp.text "False"
Flag MinimalDebugInfo -> Disp.text "1"
Flag NormalDebugInfo -> Disp.text "True"
Flag MaximalDebugInfo -> Disp.text "3"
_ -> Disp.empty)
(\line str _ -> case () of
_ | str == "False" -> ParseOk [] (Flag NoDebugInfo)
| str == "True" -> ParseOk [] (Flag NormalDebugInfo)
| str == "0" -> ParseOk [] (Flag NoDebugInfo)
| str == "1" -> ParseOk [] (Flag MinimalDebugInfo)
| str == "2" -> ParseOk [] (Flag NormalDebugInfo)
| str == "3" -> ParseOk [] (Flag MaximalDebugInfo)
| lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo)
| lstr == "true" -> ParseOk [caseWarning] (Flag NormalDebugInfo)
| otherwise -> ParseFailed (NoParse name line)
where
lstr = lowercase str
caseWarning = PWarning $
"The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.")
prefixTest name | "test-" `isPrefixOf` name = name
| otherwise = "test-" ++ name
legacyPackageConfigFGSectionDescrs
:: ( FieldGrammar c g, Applicative (g SourceRepoList)
, c (Identity RepoType)
, c (List NoCommaFSep FilePathNT String)
, c (NonEmpty' NoCommaFSep Token String)
)
=> [FGSectionDescr g LegacyProjectConfig]
legacyPackageConfigFGSectionDescrs =
[ packageRepoSectionDescr
]
legacyPackageConfigSectionDescrs :: [SectionDescr LegacyProjectConfig]
legacyPackageConfigSectionDescrs =
[ packageSpecificOptionsSectionDescr
, liftSection
legacyLocalConfig
(\flags conf -> conf { legacyLocalConfig = flags })
programOptionsSectionDescr
, liftSection
legacyLocalConfig
(\flags conf -> conf { legacyLocalConfig = flags })
programLocationsSectionDescr
, liftSection
legacySharedConfig
(\flags conf -> conf { legacySharedConfig = flags }) $
liftSection
legacyGlobalFlags
(\flags conf -> conf { legacyGlobalFlags = flags })
remoteRepoSectionDescr
]
packageRepoSectionDescr
:: ( FieldGrammar c g, Applicative (g SourceRepoList)
, c (Identity RepoType)
, c (List NoCommaFSep FilePathNT String)
, c (NonEmpty' NoCommaFSep Token String)
)
=> FGSectionDescr g LegacyProjectConfig
packageRepoSectionDescr = FGSectionDescr
{ fgSectionName = "source-repository-package"
, fgSectionGrammar = sourceRepositoryPackageGrammar
, fgSectionGet = map (\x->("", x)) . legacyPackagesRepo
, fgSectionSet =
\lineno unused pkgrepo projconf -> do
unless (null unused) $
syntaxError lineno "the section 'source-repository-package' takes no arguments"
return projconf {
legacyPackagesRepo = legacyPackagesRepo projconf ++ [pkgrepo]
}
}
-- | The definitions of all the fields that can appear in the @package pkgfoo@
-- and @package *@ sections of the @cabal.project@-format files.
--
packageSpecificOptionsFieldDescrs :: [FieldDescr LegacyPackageConfig]
packageSpecificOptionsFieldDescrs =
legacyPackageConfigFieldDescrs
++ programOptionsFieldDescrs
(configProgramArgs . legacyConfigureFlags)
(\args pkgconf -> pkgconf {
legacyConfigureFlags = (legacyConfigureFlags pkgconf) {
configProgramArgs = args
}
}
)
++ liftFields
legacyConfigureFlags
(\flags pkgconf -> pkgconf {
legacyConfigureFlags = flags
}
)
programLocationsFieldDescrs
-- | The definition of the @package pkgfoo@ sections of the @cabal.project@-format
-- files. This section is per-package name. The special package @*@ applies to all
-- packages used anywhere by the project, locally or as dependencies.
--
packageSpecificOptionsSectionDescr :: SectionDescr LegacyProjectConfig
packageSpecificOptionsSectionDescr =
SectionDescr {
sectionName = "package",
sectionFields = packageSpecificOptionsFieldDescrs,
sectionSubsections = [],
sectionGet = \projconf ->
[ (prettyShow pkgname, pkgconf)
| (pkgname, pkgconf) <-
Map.toList . getMapMappend
. legacySpecificConfig $ projconf ]
++ [ ("*", legacyAllConfig projconf) ],
sectionSet =
\lineno pkgnamestr pkgconf projconf -> case pkgnamestr of
"*" -> return projconf {
legacyAllConfig = legacyAllConfig projconf <> pkgconf
}
_ -> do
pkgname <- case simpleParsec pkgnamestr of
Just pkgname -> return pkgname
Nothing -> syntaxError lineno $
"a 'package' section requires a package name "
++ "as an argument"
return projconf {
legacySpecificConfig =
MapMappend $
Map.insertWith mappend pkgname pkgconf
(getMapMappend $ legacySpecificConfig projconf)
},
sectionEmpty = mempty
}
programOptionsFieldDescrs :: (a -> [(String, [String])])
-> ([(String, [String])] -> a -> a)
-> [FieldDescr a]
programOptionsFieldDescrs get' set =
commandOptionsToFields
$ programDbOptions
defaultProgramDb
ParseArgs get' set
programOptionsSectionDescr :: SectionDescr LegacyPackageConfig
programOptionsSectionDescr =
SectionDescr {
sectionName = "program-options",
sectionFields = programOptionsFieldDescrs
configProgramArgs
(\args conf -> conf { configProgramArgs = args }),
sectionSubsections = [],
sectionGet = (\x->[("", x)])
. legacyConfigureFlags,
sectionSet =
\lineno unused confflags pkgconf -> do
unless (null unused) $
syntaxError lineno "the section 'program-options' takes no arguments"
return pkgconf {
legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags
},
sectionEmpty = mempty
}
programLocationsFieldDescrs :: [FieldDescr ConfigFlags]
programLocationsFieldDescrs =
commandOptionsToFields
$ programDbPaths'
(++ "-location")
defaultProgramDb
ParseArgs
configProgramPaths
(\paths conf -> conf { configProgramPaths = paths })
programLocationsSectionDescr :: SectionDescr LegacyPackageConfig
programLocationsSectionDescr =
SectionDescr {
sectionName = "program-locations",
sectionFields = programLocationsFieldDescrs,
sectionSubsections = [],
sectionGet = (\x->[("", x)])
. legacyConfigureFlags,
sectionSet =
\lineno unused confflags pkgconf -> do
unless (null unused) $
syntaxError lineno "the section 'program-locations' takes no arguments"
return pkgconf {
legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags
},
sectionEmpty = mempty
}
-- | For each known program @PROG@ in 'progDb', produce a @PROG-options@
-- 'OptionField'.
programDbOptions
:: ProgramDb
-> ShowOrParseArgs
-> (flags -> [(String, [String])])
-> ([(String, [String])] -> (flags -> flags))
-> [OptionField flags]
programDbOptions progDb showOrParseArgs get' set =
case showOrParseArgs of
-- we don't want a verbose help text list so we just show a generic one:
ShowArgs -> [programOptions "PROG"]
ParseArgs -> map (programOptions . programName . fst)
(knownPrograms progDb)
where
programOptions prog =
option "" [prog ++ "-options"]
("give extra options to " ++ prog)
get' set
(reqArg' "OPTS" (\args -> [(prog, splitArgs args)])
(\progArgs -> [ joinsArgs args
| (prog', args) <- progArgs, prog==prog' ]))
joinsArgs = unwords . map escape
escape arg | any isSpace arg = "\"" ++ arg ++ "\""
| otherwise = arg
-- The implementation is slight hack: we parse all as remote repository
-- but if the url schema is file+noindex, we switch to local.
remoteRepoSectionDescr :: SectionDescr GlobalFlags
remoteRepoSectionDescr = SectionDescr
{ sectionName = "repository"
, sectionEmpty = emptyRemoteRepo (RepoName "")
, sectionFields = remoteRepoFields
, sectionSubsections = []
, sectionGet = getS
, sectionSet = setS
}
where
getS :: GlobalFlags -> [(String, RemoteRepo)]
getS gf =
map (\x->(unRepoName $ remoteRepoName x, x)) (fromNubList (globalRemoteRepos gf))
++
map (\x->(unRepoName $ localRepoName x, localToRemote x)) (fromNubList (globalLocalNoIndexRepos gf))
setS :: Int -> String -> RemoteRepo -> GlobalFlags -> ParseResult GlobalFlags
setS lineno reponame repo0 conf = do
repo1 <- postProcessRepo lineno reponame repo0
case repo1 of
Left repo -> return conf
{ globalLocalNoIndexRepos = overNubList (++[repo]) (globalLocalNoIndexRepos conf)
}
Right repo -> return conf
{ globalRemoteRepos = overNubList (++[repo]) (globalRemoteRepos conf)
}
localToRemote :: LocalRepo -> RemoteRepo
localToRemote (LocalRepo name path sharedCache) = (emptyRemoteRepo name)
{ remoteRepoURI = URI "file+noindex:" Nothing path "" (if sharedCache then "#shared-cache" else "")
}
-------------------------------
-- Local field utils
--
-- | Parser combinator for simple fields which uses the field type's
-- 'Monoid' instance for combining multiple occurrences of the field.
monoidFieldParsec
:: Monoid a => String -> (a -> Doc) -> ParsecParser a
-> (b -> a) -> (a -> b -> b) -> FieldDescr b
monoidFieldParsec name showF readF get' set =
liftField get' set' $ ParseUtils.fieldParsec name showF readF
where
set' xs b = set (get' b `mappend` xs) b
--TODO: [code cleanup] local redefinition that should replace the version in
-- D.ParseUtils called showFilePath. This version escapes "." and "--" which
-- otherwise are special syntax.
showTokenQ :: String -> Doc
showTokenQ "" = Disp.empty
showTokenQ x@('-':'-':_) = Disp.text (show x)
showTokenQ x@('.':[]) = Disp.text (show x)
showTokenQ x = showToken x
-- Handy util
addFields :: [FieldDescr a]
-> ([FieldDescr a] -> [FieldDescr a])
addFields = (++)