From 82c243d1c4b2b11805c825483a28e54a333a7014 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 31 May 2024 09:33:42 +0200 Subject: [PATCH 01/41] Replace cabal project parsing with Parsec --- Cabal-syntax/src/Distribution/FieldGrammar.hs | 14 + .../src/Distribution/Fields/ParseResult.hs | 11 + Cabal/src/Distribution/Simple/Compiler.hs | 55 +- Cabal/src/Distribution/Simple/Flag.hs | 7 + Cabal/src/Distribution/Simple/InstallDirs.hs | 7 + .../Distribution/Simple/PackageDescription.hs | 2 + Cabal/src/Distribution/Simple/Setup/Config.hs | 9 - Cabal/src/Distribution/Types/DumpBuildInfo.hs | 12 + .../src/Distribution/Solver/Types/Settings.hs | 23 + cabal-install/cabal-install.cabal | 3 + .../src/Distribution/Client/ProjectConfig.hs | 72 ++- .../Client/ProjectConfig/FieldGrammar.hs | 182 ++++++ .../Distribution/Client/ProjectConfig/Lens.hs | 522 ++++++++++++++++++ .../Client/ProjectConfig/Parsec.hs | 369 +++++++++++++ .../Client/ProjectConfig/Types.hs | 1 + .../Distribution/Client/Types/AllowNewer.hs | 6 + .../Types/WriteGhcEnvironmentFilesPolicy.hs | 15 + .../src/Distribution/Client/Utils/Parsec.hs | 134 ++++- .../ProjectConfig/Parsec/cabal.test.hs | 436 +++++++++++++++ .../tests/all-packages-concat/cabal.project | 7 + .../Parsec/tests/empty/cabal.project | 0 .../Parsec/tests/extra-packages/cabal.project | 3 + .../tests/optional-packages/cabal.project | 1 + .../Parsec/tests/packages/cabal.project | 1 + .../program-locations-concat/cabal.project | 5 + .../program-options-concat/cabal.project | 7 + .../project-config-all-packages/cabal.project | 3 + .../project-config-build-only/cabal.project | 15 + .../cabal.project | 68 +++ .../tests/project-config-shared/cabal.project | 39 ++ .../cabal.project | 12 + .../source-repository-packages/cabal.project | 10 + .../specific-packages-concat/cabal.project | 7 + .../PackageTests/Regression/T5213/cabal.out | 3 +- .../Regression/T5213/cabal.project | 2 +- cabal-testsuite/cabal-testsuite.cabal | 2 + doc/cabal-project-description-file.rst | 2 +- 37 files changed, 2037 insertions(+), 30 deletions(-) create mode 100644 cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs create mode 100644 cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs create mode 100644 cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs create mode 100644 cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs create mode 100644 cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/all-packages-concat/cabal.project create mode 100644 cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/empty/cabal.project create mode 100644 cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/extra-packages/cabal.project create mode 100644 cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/optional-packages/cabal.project create mode 100644 cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/packages/cabal.project create mode 100644 cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/program-locations-concat/cabal.project create mode 100644 cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/program-options-concat/cabal.project create mode 100644 cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-all-packages/cabal.project create mode 100644 cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-build-only/cabal.project create mode 100644 cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-local-packages/cabal.project create mode 100644 cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-shared/cabal.project create mode 100644 cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-specific-packages/cabal.project create mode 100644 cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/source-repository-packages/cabal.project create mode 100644 cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/specific-packages-concat/cabal.project diff --git a/Cabal-syntax/src/Distribution/FieldGrammar.hs b/Cabal-syntax/src/Distribution/FieldGrammar.hs index e41dd6350c2..35410849165 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar.hs @@ -65,6 +65,20 @@ x ^^^ f = f x data PS ann = PS (Fields ann) [Section ann] [[Section ann]] -- | Partition field list into field map and groups of sections. +-- Groups sections between fields. This means that the following snippet contains +-- two section groups: +-- +-- @ +-- -- first group +-- some-section +-- field: value +-- another-section +-- field: value +-- foo: bar +-- -- second group +-- yet-another-section +-- field: value +-- @ partitionFields :: [Field ann] -> (Fields ann, [[Section ann]]) partitionFields = finalize . foldl' f (PS mempty mempty mempty) where diff --git a/Cabal-syntax/src/Distribution/Fields/ParseResult.hs b/Cabal-syntax/src/Distribution/Fields/ParseResult.hs index aad7de2737a..8a23604771f 100644 --- a/Cabal-syntax/src/Distribution/Fields/ParseResult.hs +++ b/Cabal-syntax/src/Distribution/Fields/ParseResult.hs @@ -16,6 +16,7 @@ module Distribution.Fields.ParseResult , getCabalSpecVersion , setCabalSpecVersion , withoutWarnings + , liftPR ) where import Distribution.Compat.Prelude @@ -62,6 +63,16 @@ runParseResult pr = unPR pr emptyPRState failure success -- If there are any errors, don't return the result success (PRState warns (err : errs) v) _ = (warns, Left (v, err :| errs)) +liftPR :: (a -> IO (ParseResult b)) -> ParseResult a -> IO (ParseResult b) +liftPR f pr = unPR pr emptyPRState failure success + where + failure s = return $ PR $ \s' failure' _ -> failure' (concatPRState s s') + success s a = do + pr' <- f a + return $ PR $ \s' failure' success' -> unPR pr' (concatPRState s s') failure' success' + concatPRState (PRState warnings errors version) (PRState warnings' errors' version') = + (PRState (warnings ++ warnings') (toList errors ++ errors') (version <|> version')) + instance Functor ParseResult where fmap f (PR pr) = PR $ \ !s failure success -> pr s failure $ \ !s' a -> diff --git a/Cabal/src/Distribution/Simple/Compiler.hs b/Cabal/src/Distribution/Simple/Compiler.hs index c24de767172..5764874465f 100644 --- a/Cabal/src/Distribution/Simple/Compiler.hs +++ b/Cabal/src/Distribution/Simple/Compiler.hs @@ -50,6 +50,7 @@ module Distribution.Simple.Compiler , interpretPackageDBStack , coercePackageDB , coercePackageDBStack + , readPackageDb -- * Support for optimisation levels , OptimisationLevel (..) @@ -92,7 +93,9 @@ module Distribution.Simple.Compiler , showProfDetailLevel ) where +import Distribution.Compat.CharParsing import Distribution.Compat.Prelude +import Distribution.Parsec import Distribution.Pretty import Prelude () @@ -103,6 +106,7 @@ import Distribution.Version import Language.Haskell.Extension +import Data.Bool (bool) import qualified Data.Map as Map (lookup) import System.Directory (canonicalizePath) @@ -202,6 +206,15 @@ data PackageDBX fp instance Binary fp => Binary (PackageDBX fp) instance Structured fp => Structured (PackageDBX fp) +-- | Parse a PackageDB stack entry +-- +-- @since 3.7.0.0 +readPackageDb :: String -> Maybe PackageDB +readPackageDb "clear" = Nothing +readPackageDb "global" = Just GlobalPackageDB +readPackageDb "user" = Just UserPackageDB +readPackageDb other = Just (SpecificPackageDB (makeSymbolicPath other)) + -- | We typically get packages from several databases, and stack them -- together. This type lets us be explicit about that stacking. For example -- typical stacks include: @@ -293,20 +306,32 @@ data OptimisationLevel instance Binary OptimisationLevel instance Structured OptimisationLevel +instance Parsec OptimisationLevel where + parsec = parsecOptimisationLevel + +parsecOptimisationLevel :: CabalParsing m => m OptimisationLevel +parsecOptimisationLevel = boolParser <|> intParser + where + boolParser = (bool NoOptimisation NormalOptimisation) <$> parsec + intParser = intToOptimisationLevel <$> integral + flagToOptimisationLevel :: Maybe String -> OptimisationLevel flagToOptimisationLevel Nothing = NormalOptimisation flagToOptimisationLevel (Just s) = case reads s of - [(i, "")] - | i >= fromEnum (minBound :: OptimisationLevel) - && i <= fromEnum (maxBound :: OptimisationLevel) -> - toEnum i - | otherwise -> - error $ - "Bad optimisation level: " - ++ show i - ++ ". Valid values are 0..2" + [(i, "")] -> intToOptimisationLevel i _ -> error $ "Can't parse optimisation level " ++ s +intToOptimisationLevel :: Int -> OptimisationLevel +intToOptimisationLevel i + | i >= fromEnum (minBound :: OptimisationLevel) + && i <= fromEnum (maxBound :: OptimisationLevel) = + toEnum i + | otherwise = + error $ + "Bad optimisation level: " + ++ show i + ++ ". Valid values are 0..2" + -- ------------------------------------------------------------ -- * Debug info levels @@ -326,6 +351,12 @@ data DebugInfoLevel instance Binary DebugInfoLevel instance Structured DebugInfoLevel +instance Parsec DebugInfoLevel where + parsec = parsecDebugInfoLevel + +parsecDebugInfoLevel :: CabalParsing m => m DebugInfoLevel +parsecDebugInfoLevel = flagToDebugInfoLevel <$> pure <$> parsecToken + flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel flagToDebugInfoLevel Nothing = NormalDebugInfo flagToDebugInfoLevel (Just s) = case reads s of @@ -563,6 +594,12 @@ data ProfDetailLevel instance Binary ProfDetailLevel instance Structured ProfDetailLevel +instance Parsec ProfDetailLevel where + parsec = parsecProfDetailLevel + +parsecProfDetailLevel :: CabalParsing m => m ProfDetailLevel +parsecProfDetailLevel = flagToProfDetailLevel <$> parsecToken + flagToProfDetailLevel :: String -> ProfDetailLevel flagToProfDetailLevel "" = ProfDetailDefault flagToProfDetailLevel s = diff --git a/Cabal/src/Distribution/Simple/Flag.hs b/Cabal/src/Distribution/Simple/Flag.hs index 744a7da1331..031259c5e1e 100644 --- a/Cabal/src/Distribution/Simple/Flag.hs +++ b/Cabal/src/Distribution/Simple/Flag.hs @@ -34,6 +34,7 @@ module Distribution.Simple.Flag import Distribution.Compat.Prelude hiding (get) import Distribution.Compat.Stack +import Distribution.Parsec import Prelude () -- ------------------------------------------------------------ @@ -99,6 +100,12 @@ instance Enum a => Enum (Flag a) where enumFromThenTo (Flag a) (Flag b) (Flag c) = toFlag `map` enumFromThenTo a b c enumFromThenTo _ _ _ = [] +instance Parsec a => Parsec (Flag a) where + parsec = parsecFlag + +parsecFlag :: (Parsec a, CabalParsing m) => m (Flag a) +parsecFlag = (Flag <$> parsec) <|> pure mempty + -- | Wraps a value in 'Flag'. toFlag :: a -> Flag a toFlag = Flag diff --git a/Cabal/src/Distribution/Simple/InstallDirs.hs b/Cabal/src/Distribution/Simple/InstallDirs.hs index 86e6fa08777..c24bffc87ae 100644 --- a/Cabal/src/Distribution/Simple/InstallDirs.hs +++ b/Cabal/src/Distribution/Simple/InstallDirs.hs @@ -53,6 +53,7 @@ import Prelude () import Distribution.Compat.Environment (lookupEnv) import Distribution.Compiler import Distribution.Package +import Distribution.Parsec import Distribution.Pretty import Distribution.Simple.InstallDirs.Internal import Distribution.System @@ -506,6 +507,12 @@ instance Read PathTemplate where , (template, "") <- reads path ] +instance Parsec PathTemplate where + parsec = parsecPathTemplate + +parsecPathTemplate :: CabalParsing m => m PathTemplate +parsecPathTemplate = parsecFilePath >>= return . toPathTemplate + -- --------------------------------------------------------------------------- -- Internal utilities diff --git a/Cabal/src/Distribution/Simple/PackageDescription.hs b/Cabal/src/Distribution/Simple/PackageDescription.hs index d0ee9d9f86b..2e609c4a80d 100644 --- a/Cabal/src/Distribution/Simple/PackageDescription.hs +++ b/Cabal/src/Distribution/Simple/PackageDescription.hs @@ -18,6 +18,8 @@ module Distribution.Simple.PackageDescription -- * Utility Parsing function , parseString + , readAndParseFile + , flattenDups ) where import Distribution.Compat.Prelude diff --git a/Cabal/src/Distribution/Simple/Setup/Config.hs b/Cabal/src/Distribution/Simple/Setup/Config.hs index c904ecf2b44..bac73530cb7 100644 --- a/Cabal/src/Distribution/Simple/Setup/Config.hs +++ b/Cabal/src/Distribution/Simple/Setup/Config.hs @@ -897,15 +897,6 @@ configureOptions showOrParseArgs = readPackageDbList :: String -> [Maybe PackageDB] readPackageDbList str = [readPackageDb str] --- | Parse a PackageDB stack entry --- --- @since 3.7.0.0 -readPackageDb :: String -> Maybe PackageDB -readPackageDb "clear" = Nothing -readPackageDb "global" = Just GlobalPackageDB -readPackageDb "user" = Just UserPackageDB -readPackageDb other = Just (SpecificPackageDB (makeSymbolicPath other)) - showPackageDbList :: [Maybe PackageDB] -> [String] showPackageDbList = map showPackageDb diff --git a/Cabal/src/Distribution/Types/DumpBuildInfo.hs b/Cabal/src/Distribution/Types/DumpBuildInfo.hs index 99020febc35..4ce4b3eb97e 100644 --- a/Cabal/src/Distribution/Types/DumpBuildInfo.hs +++ b/Cabal/src/Distribution/Types/DumpBuildInfo.hs @@ -5,6 +5,7 @@ module Distribution.Types.DumpBuildInfo ) where import Distribution.Compat.Prelude +import Distribution.Parsec data DumpBuildInfo = NoDumpBuildInfo @@ -13,3 +14,14 @@ data DumpBuildInfo instance Binary DumpBuildInfo instance Structured DumpBuildInfo + +instance Parsec DumpBuildInfo where + parsec = parsecDumpBuildInfo + +parsecDumpBuildInfo :: CabalParsing m => m DumpBuildInfo +parsecDumpBuildInfo = boolToDumpBuildInfo <$> parsec + +boolToDumpBuildInfo :: Bool -> DumpBuildInfo +boolToDumpBuildInfo bool = case bool of + True -> DumpBuildInfo + _ -> NoDumpBuildInfo diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Settings.hs b/cabal-install-solver/src/Distribution/Solver/Types/Settings.hs index 4b7fe65b769..306c0c12185 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/Settings.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/Settings.hs @@ -105,3 +105,26 @@ instance Parsec OnlyConstrained where , P.string "none" >> return OnlyConstrainedNone ] +instance Parsec ReorderGoals where + parsec = ReorderGoals <$> parsec + +instance Parsec CountConflicts where + parsec = CountConflicts <$> parsec + +instance Parsec FineGrainedConflicts where + parsec = FineGrainedConflicts <$> parsec + +instance Parsec MinimizeConflictSet where + parsec = MinimizeConflictSet <$> parsec + +instance Parsec StrongFlags where + parsec = StrongFlags <$> parsec + +instance Parsec AllowBootLibInstalls where + parsec = AllowBootLibInstalls <$> parsec + +instance Parsec PreferOldest where + parsec = PreferOldest <$> parsec + +instance Parsec IndependentGoals where + parsec = IndependentGoals <$> parsec diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index cef5fbd8277..ce63094aec0 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -170,7 +170,10 @@ library Distribution.Client.ProjectBuilding.PackageFileMonitor Distribution.Client.ProjectBuilding.Types Distribution.Client.ProjectConfig + Distribution.Client.ProjectConfig.FieldGrammar Distribution.Client.ProjectConfig.Legacy + Distribution.Client.ProjectConfig.Lens + Distribution.Client.ProjectConfig.Parsec Distribution.Client.ProjectConfig.Types Distribution.Client.ProjectFlags Distribution.Client.ProjectOrchestration diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index 5387f8e37db..ce8d2bd140f 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -11,6 +11,7 @@ module Distribution.Client.ProjectConfig , ProjectConfigToParse (..) , ProjectConfigBuildOnly (..) , ProjectConfigShared (..) + , ProjectConfigSkeleton , ProjectConfigProvenance (..) , PackageConfig (..) , MapLast (..) @@ -36,10 +37,8 @@ module Distribution.Client.ProjectConfig , writeProjectLocalFreezeConfig , writeProjectConfigFile , commandLineFlagsToProjectConfig - , onlyTopLevelProvenance - , readSourcePackageCabalFile - , readSourcePackageCabalFile' - , CabalFileParseError (..) + , readProjectFileSkeleton + , readProjectFileSkeletonLegacy -- * Packages within projects , ProjectPackageLocation (..) @@ -76,6 +75,7 @@ import Distribution.Client.Glob ) import Distribution.Client.JobControl import Distribution.Client.ProjectConfig.Legacy +import qualified Distribution.Client.ProjectConfig.Parsec as Parsec import Distribution.Client.ProjectConfig.Types import Distribution.Client.RebuildMonad import Distribution.Client.VCS @@ -113,6 +113,10 @@ import Distribution.Client.HttpUtils ) import Distribution.Client.Types import Distribution.Client.Utils.Parsec (renderParseError) +import GHC.Stack (HasCallStack, callStack) + +import Distribution.Simple.Errors +import Distribution.Simple.PackageDescription (flattenDups) import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.PackageConstraint @@ -145,6 +149,7 @@ import Distribution.Fields ( PError , PWarning , runParseResult + , showPError , showPWarning ) import Distribution.Package @@ -819,8 +824,64 @@ readProjectLocalFreezeConfig verbosity httpTransport distDirLayout = "project freeze file" -- | Reads a named extended (with imports and conditionals) config file in the given project root dir, or returns empty. -readProjectFileSkeleton :: Verbosity -> HttpTransport -> DistDirLayout -> String -> String -> Rebuild ProjectConfigSkeleton +readProjectFileSkeleton :: HasCallStack => Verbosity -> HttpTransport -> DistDirLayout -> String -> String -> Rebuild ProjectConfigSkeleton readProjectFileSkeleton + verbosity + httpTransport + dir@DistDirLayout{distProjectFile, distDownloadSrcDirectory} + extensionName + extensionDescription = do + legacyPcs <- readProjectFileSkeletonLegacy verbosity httpTransport dir extensionName extensionDescription + exists <- liftIO $ doesFileExist extensionFile + if exists + then do + monitorFiles [monitorFileHashed extensionFile] + pcs <- liftIO $ readExtensionFile verbosity extensionFile + monitorFiles $ map monitorFileHashed (projectConfigPathRoot <$> projectSkeletonImports pcs) + unless (legacyPcs == pcs) (error (show callStack ++ "\nParsec: " ++ show pcs ++ "\nLegacy: " ++ show legacyPcs)) + pure pcs + else do + monitorFiles [monitorNonExistentFile extensionFile] + return mempty + where + extensionFile = distProjectFile extensionName + readExtensionFile :: Verbosity -> FilePath -> IO ProjectConfigSkeleton + readExtensionFile verbosity' file = readAndParseFile (Parsec.parseProject extensionFile distDownloadSrcDirectory httpTransport verbosity' . ProjectConfigToParse) verbosity' file + +readAndParseFile + :: (BS.ByteString -> IO (Parsec.ParseResult a)) + -> Verbosity + -> FilePath + -> IO a +readAndParseFile parser verbosity fpath = do + exists <- doesFileExist fpath + unless exists $ + dieWithException verbosity $ + ErrorParsingFileDoesntExist fpath + bs <- BS.readFile fpath + parseString parser verbosity fpath bs + +parseString + :: ( BS.ByteString + -> IO (Parsec.ParseResult a) + ) + -> Verbosity + -> FilePath + -> BS.ByteString + -> IO a +parseString parser verbosity fpath bs = do + pr <- parser bs + let (warnings, result) = runParseResult pr + traverse_ (warn verbosity . showPWarning fpath) (flattenDups verbosity warnings) + case result of + Right x -> return x + Left (_, errors) -> do + traverse_ (warn verbosity . showPError fpath) errors + dieWithException verbosity $ FailedParsing fpath + +-- | Reads a named extended (with imports and conditionals) config file in the given project root dir, or returns empty. +readProjectFileSkeletonLegacy :: Verbosity -> HttpTransport -> DistDirLayout -> String -> String -> Rebuild ProjectConfigSkeleton +readProjectFileSkeletonLegacy verbosity httpTransport DistDirLayout{distProjectFile, distDownloadSrcDirectory} @@ -838,7 +899,6 @@ readProjectFileSkeleton return mempty where extensionFile = distProjectFile extensionName - readExtensionFile = reportParseResult verbosity extensionDescription extensionFile =<< parseProject extensionFile distDownloadSrcDirectory httpTransport verbosity . ProjectConfigToParse diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs new file mode 100644 index 00000000000..11f40abe85d --- /dev/null +++ b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | 'ProjectConfig' Field descriptions +module Distribution.Client.ProjectConfig.FieldGrammar + ( projectConfigFieldGrammar + , packageConfigFieldGrammar + ) where + +import qualified Data.ByteString.Char8 as BS +import qualified Data.Set as Set +import Distribution.CabalSpecVersion (CabalSpecVersion (..)) +import qualified Distribution.Client.ProjectConfig.Lens as L +import Distribution.Client.ProjectConfig.Types (PackageConfig (..), ProjectConfig (..), ProjectConfigBuildOnly (..), ProjectConfigProvenance (..), ProjectConfigShared (..)) +import Distribution.Client.Utils.Parsec +import Distribution.Compat.Prelude +import Distribution.FieldGrammar +import Distribution.Simple.Flag +import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) +import Distribution.Solver.Types.ProjectConfigPath +import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..)) + +projectConfigFieldGrammar :: ProjectConfigPath -> [String] -> ParsecFieldGrammar' ProjectConfig +projectConfigFieldGrammar source knownPrograms = + ProjectConfig + <$> monoidalFieldAla "packages" (alaList' FSep Token) L.projectPackages + <*> monoidalFieldAla "optional-packages" (alaList' FSep Token) L.projectPackagesOptional + <*> pure mempty -- source-repository-package stanza + <*> monoidalFieldAla "extra-packages" formatPackageVersionConstraints L.projectPackagesNamed + <*> blurFieldGrammar L.projectConfigBuildOnly projectConfigBuildOnlyFieldGrammar + <*> blurFieldGrammar L.projectConfigShared (projectConfigSharedFieldGrammar source) + <*> pure provenance + <*> pure mempty + -- \^ PackageConfig to be applied to all packages, specified inside 'package *' stanza + <*> blurFieldGrammar L.projectConfigLocalPackages (packageConfigFieldGrammar knownPrograms) + -- \^ PackageConfig to be applied to locally built packages, specified not inside a stanza + <*> pure mempty + where + -- \^ PackageConfig applied to explicitly named packages + provenance = Set.singleton (Explicit source) + +formatPackageVersionConstraints :: [PackageVersionConstraint] -> List CommaVCat (Identity PackageVersionConstraint) PackageVersionConstraint +formatPackageVersionConstraints = alaList CommaVCat + +projectConfigBuildOnlyFieldGrammar :: ParsecFieldGrammar' ProjectConfigBuildOnly +projectConfigBuildOnlyFieldGrammar = + ProjectConfigBuildOnly + <$> optionalFieldDef "verbose" L.projectConfigVerbosity mempty + <*> pure mempty -- cli flag: projectConfigDryRun + <*> pure mempty -- cli flag: projectConfigOnlyDeps + <*> pure mempty -- cli flag: projectConfigOnlyDownload + <*> monoidalFieldAla "build-summary" (alaNubList VCat) L.projectConfigSummaryFile + <*> optionalFieldDef "build-log" L.projectConfigLogFile mempty + <*> optionalFieldDef "remote-build-reporting" L.projectConfigBuildReports mempty + <*> optionalFieldDef "report-planning-failure" L.projectConfigReportPlanningFailure mempty + <*> optionalFieldDefAla "symlink-bindir" (alaFlag FilePathNT) L.projectConfigSymlinkBinDir mempty + <*> optionalFieldDefAla "jobs" (alaFlag NumJobs) L.projectConfigNumJobs mempty + <*> optionalFieldDef "semaphore" L.projectConfigUseSemaphore mempty + <*> optionalFieldDef "keep-going" L.projectConfigKeepGoing mempty + <*> optionalFieldDef "offline" L.projectConfigOfflineMode mempty + <*> optionalFieldDef "haddock-keep-temp-files" L.projectConfigKeepTempFiles mempty + <*> optionalFieldDefAla "http-transport" (alaFlag Token) L.projectConfigHttpTransport mempty + <*> optionalFieldDef "ignore-expiry" L.projectConfigIgnoreExpiry mempty + <*> optionalFieldDefAla "remote-repo-cache" (alaFlag FilePathNT) L.projectConfigCacheDir mempty + <*> optionalFieldDefAla "logs-dir" (alaFlag FilePathNT) L.projectConfigLogsDir mempty + <*> pure mempty -- cli flag: projectConfigClientInstallFlags + +projectConfigSharedFieldGrammar :: ProjectConfigPath -> ParsecFieldGrammar' ProjectConfigShared +projectConfigSharedFieldGrammar source = + ProjectConfigShared + <$> optionalFieldDefAla "builddir" (alaFlag FilePathNT) L.projectConfigDistDir mempty + <*> pure mempty -- cli flag: projectConfigConfigFile + <*> optionalFieldDefAla "project-dir" (alaFlag FilePathNT) L.projectConfigProjectDir mempty + <*> optionalFieldDefAla "project-file" (alaFlag FilePathNT) L.projectConfigProjectFile mempty + <*> optionalFieldDef "ignore-project" L.projectConfigIgnoreProject mempty + <*> optionalFieldDef "compiler" L.projectConfigHcFlavor mempty + <*> optionalFieldDefAla "with-compiler" (alaFlag FilePathNT) L.projectConfigHcPath mempty + <*> optionalFieldDefAla "with-hc-pkg" (alaFlag FilePathNT) L.projectConfigHcPkg mempty + <*> optionalFieldDef "doc-index-file" L.projectConfigHaddockIndex mempty + <*> pure mempty -- cli flag: projectConfigInstallDirs + <*> monoidalFieldAla "package-dbs" (alaList' CommaFSep PackageDBNT) L.projectConfigPackageDBs + <*> pure mempty -- cli flag: projectConfigRemoteRepos + <*> pure mempty -- cli flag: projectConfigLocalNoIndexRepos + <*> monoidalField "active-repositories" L.projectConfigActiveRepos + <*> monoidalField "index-state" L.projectConfigIndexState + <*> optionalFieldDefAla "store-dir" (alaFlag FilePathNT) L.projectConfigStoreDir mempty + <*> monoidalFieldAla "constraints" (alaList' FSep ProjectConstraints) L.projectConfigConstraints + ^^^ (fmap . fmap) (\(userConstraint, _) -> (userConstraint, ConstraintSourceProjectConfig source)) + <*> monoidalFieldAla "preferences" formatPackageVersionConstraints L.projectConfigPreferences + <*> optionalFieldDef "cabal-lib-version" L.projectConfigCabalVersion mempty + <*> optionalFieldDef "solver" L.projectConfigSolver mempty + <*> optionalField "allow-older" L.projectConfigAllowOlder + <*> optionalField "allow-newer" L.projectConfigAllowNewer + <*> optionalFieldDef "write-ghc-environment-files" L.projectConfigWriteGhcEnvironmentFilesPolicy mempty + <*> optionalFieldDefAla "max-backjumps" (alaFlag MaxBackjumps) L.projectConfigMaxBackjumps mempty + <*> optionalFieldDef "reorder-goals" L.projectConfigReorderGoals mempty + <*> optionalFieldDef "count-conflicts" L.projectConfigCountConflicts mempty + <*> optionalFieldDef "fine-grained-conflicts" L.projectConfigFineGrainedConflicts mempty + <*> optionalFieldDef "minimize-conflict-set" L.projectConfigMinimizeConflictSet mempty + <*> optionalFieldDef "strong-flags" L.projectConfigStrongFlags mempty + <*> optionalFieldDef "allow-boot-library-installs" L.projectConfigAllowBootLibInstalls mempty + <*> optionalFieldDef "reject-unconstrained-dependencies" L.projectConfigOnlyConstrained mempty + <*> optionalFieldDef "per-component" L.projectConfigPerComponent mempty + <*> optionalFieldDef "independent-goals" L.projectConfigIndependentGoals mempty + <*> optionalFieldDef "prefer-oldest" L.projectConfigPreferOldest mempty + <*> monoidalFieldAla "extra-prog-path-shared-only" (alaNubList' FSep FilePathNT) L.projectConfigProgPathExtra + <*> optionalFieldDef "multi-repl" L.projectConfigMultiRepl mempty + +packageConfigFieldGrammar :: [String] -> ParsecFieldGrammar' PackageConfig +packageConfigFieldGrammar knownPrograms = + PackageConfig + <$> pure mempty -- program-options stanza + <*> pure mempty -- program-locations stanza + <*> monoidalFieldAla "extra-prog-path" (alaNubList' FSep FilePathNT) L.packageConfigProgramPathExtra + <*> monoidalField "flags" L.packageConfigFlagAssignment + <*> optionalFieldDef "library-vanilla" L.packageConfigVanillaLib mempty + <*> optionalFieldDef "shared" L.packageConfigSharedLib mempty + <*> optionalFieldDef "static" L.packageConfigStaticLib mempty + <*> optionalFieldDef "executable-dynamic" L.packageConfigDynExe mempty + <*> optionalFieldDef "executable-static" L.packageConfigFullyStaticExe mempty + <*> optionalFieldDef "profiling" L.packageConfigProf mempty + <*> optionalFieldDef "library-profiling" L.packageConfigProfLib mempty + <*> optionalFieldDef "executable-profiling" L.packageConfigProfExe mempty + <*> optionalFieldDef "profiling-detail" L.packageConfigProfDetail mempty + <*> optionalFieldDef "library-profiling-detail" L.packageConfigProfLibDetail mempty + <*> monoidalFieldAla "configure-options" (alaList' NoCommaFSep Token) L.packageConfigConfigureArgs + <*> optionalFieldDef "optimization" L.packageConfigOptimization mempty + <*> optionalFieldDef "program-prefix" L.packageConfigProgPrefix mempty + <*> optionalFieldDef "program-suffix" L.packageConfigProgSuffix mempty + <*> monoidalFieldAla "extra-lib-dirs" (alaList' FSep FilePathNT) L.packageConfigExtraLibDirs + <*> monoidalFieldAla "extra-lib-dirs-static" (alaList' FSep FilePathNT) L.packageConfigExtraLibDirsStatic + <*> monoidalFieldAla "extra-framework-dirs" (alaList' FSep FilePathNT) L.packageConfigExtraFrameworkDirs + <*> monoidalFieldAla "extra-include-dirs" (alaList' FSep FilePathNT) L.packageConfigExtraIncludeDirs + <*> optionalFieldDef "library-for-ghci" L.packageConfigGHCiLib mempty + <*> optionalFieldDef "split-sections" L.packageConfigSplitSections mempty + <*> optionalFieldDef "split-objs" L.packageConfigSplitObjs mempty + <*> optionalFieldDef "executable-stripping" L.packageConfigStripExes mempty + <*> optionalFieldDef "library-stripping" L.packageConfigStripLibs mempty + <*> optionalFieldDef "tests" L.packageConfigTests mempty + <*> optionalFieldDef "benchmarks" L.packageConfigBenchmarks mempty + <*> packageConfigCoverageGrammar + <*> optionalFieldDef "relocatable" L.packageConfigRelocatable mempty + <*> optionalFieldDef "debug-info" L.packageConfigDebugInfo mempty + <*> optionalFieldDef "build-info" L.packageConfigDumpBuildInfo mempty + <*> optionalFieldDef "run-tests" L.packageConfigRunTests mempty + <*> optionalFieldDef "documentation" L.packageConfigDocumentation mempty + <*> optionalFieldDef "haddock-hoogle" L.packageConfigHaddockHoogle mempty + <*> optionalFieldDef "haddock-html" L.packageConfigHaddockHtml mempty + <*> optionalFieldDefAla "haddock-html-location" (alaFlag Token) L.packageConfigHaddockHtmlLocation mempty + <*> optionalFieldDef "haddock-foreign-libraries" L.packageConfigHaddockForeignLibs mempty + <*> optionalFieldDef "haddock-executables" L.packageConfigHaddockExecutables mempty + <*> optionalFieldDef "haddock-tests" L.packageConfigHaddockTestSuites mempty + <*> optionalFieldDef "haddock-benchmarks" L.packageConfigHaddockBenchmarks mempty + <*> optionalFieldDef "haddock-internal" L.packageConfigHaddockInternal mempty + <*> optionalFieldDefAla "haddock-css" (alaFlag FilePathNT) L.packageConfigHaddockCss mempty + <*> optionalFieldDef "haddock-hyperlink-source" L.packageConfigHaddockLinkedSource mempty + <*> optionalFieldDef "haddock-quickjump" L.packageConfigHaddockQuickJump mempty + <*> optionalFieldDefAla "haddock-hscolour-css" (alaFlag FilePathNT) L.packageConfigHaddockHscolourCss mempty + <*> optionalFieldDef "haddock-contents-location" L.packageConfigHaddockContents mempty + <*> optionalFieldDef "haddock-index-location" L.packageConfigHaddockIndex mempty + <*> optionalFieldDefAla "haddock-base-url" (alaFlag Token) L.packageConfigHaddockBaseUrl mempty + <*> optionalFieldDefAla "haddock-lib" (alaFlag Token) L.packageConfigHaddockLib mempty + <*> optionalFieldDefAla "haddock-output-dir" (alaFlag FilePathNT) L.packageConfigHaddockOutputDir mempty + <*> optionalFieldDef "haddock-for-hackage" L.packageConfigHaddockForHackage mempty + <*> optionalFieldDef "test-log" L.packageConfigTestHumanLog mempty + <*> optionalFieldDef "test-machine-log" L.packageConfigTestMachineLog mempty + <*> optionalFieldDef "test-show-details" L.packageConfigTestShowDetails mempty + <*> optionalFieldDef "test-keep-tix-files" L.packageConfigTestKeepTix mempty + <*> optionalFieldDefAla "test-wrapper" (alaFlag FilePathNT) L.packageConfigTestWrapper mempty + <*> optionalFieldDef "test-fail-when-no-test-suites" L.packageConfigTestFailWhenNoTestSuites mempty + <*> monoidalFieldAla "test-options" (alaList NoCommaFSep) L.packageConfigTestTestOptions + <*> monoidalFieldAla "benchmark-options" (alaList NoCommaFSep) L.packageConfigBenchmarkOptions + -- A PackageConfig may contain -options and -location fields inside a package * (projectConfigAllPackages) or package stanza (packageConfigSpecificPackage). + -- When declared at top level (packageConfigLocalPackages), the PackageConfig must contain a program-options stanza/program-locations for these fields. + <* traverse_ (knownField . BS.pack . (<> "-options")) knownPrograms + <* traverse_ (knownField . BS.pack . (<> "-location")) knownPrograms + +packageConfigCoverageGrammar :: ParsecFieldGrammar PackageConfig (Distribution.Simple.Flag.Flag Bool) +packageConfigCoverageGrammar = + (<>) + <$> optionalFieldDef "library-coverage" L.packageConfigCoverage mempty + ^^^ deprecatedSince CabalSpecV1_22 "Please use 'coverage' field instead." + <*> optionalFieldDef "coverage" L.packageConfigCoverage mempty diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs new file mode 100644 index 00000000000..b008913d7e3 --- /dev/null +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs @@ -0,0 +1,522 @@ +module Distribution.Client.ProjectConfig.Lens where + +import Distribution.Client.BuildReports.Types (ReportLevel (..)) +import Distribution.Client.Dependency.Types (PreSolver (..)) +import Distribution.Client.IndexUtils.ActiveRepos + ( ActiveRepos + ) +import Distribution.Client.IndexUtils.IndexState (TotalIndexState) +import Distribution.Client.ProjectConfig.Types (MapMappend, PackageConfig, ProjectConfig (..), ProjectConfigBuildOnly (..), ProjectConfigProvenance, ProjectConfigShared) +import qualified Distribution.Client.ProjectConfig.Types as T +import Distribution.Client.Targets (UserConstraint) +import Distribution.Client.Types.AllowNewer (AllowNewer, AllowOlder) +import Distribution.Client.Types.SourceRepo (SourceRepoList) +import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy (WriteGhcEnvironmentFilesPolicy) +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Distribution.Compiler (CompilerFlavor (..)) +import Distribution.Package + ( PackageName + ) +import Distribution.PackageDescription + ( FlagAssignment + ) +import Distribution.Simple.Compiler + ( DebugInfoLevel (..) + , OptimisationLevel (..) + , PackageDB + , ProfDetailLevel + ) +import Distribution.Simple.InstallDirs + ( PathTemplate + ) +import Distribution.Simple.Setup + ( DumpBuildInfo (..) + , Flag + , HaddockTarget (..) + , TestShowDetails (..) + ) +import Distribution.Solver.Types.ConstraintSource (ConstraintSource) +import Distribution.Solver.Types.Settings + ( AllowBootLibInstalls (..) + , CountConflicts (..) + , FineGrainedConflicts (..) + , IndependentGoals (..) + , MinimizeConflictSet (..) + , OnlyConstrained (..) + , PreferOldest (..) + , ReorderGoals (..) + , StrongFlags (..) + ) +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint + ) +import Distribution.Types.Version (Version) +import Distribution.Utils.NubList + ( NubList + ) +import Distribution.Verbosity + +projectPackages :: Lens' ProjectConfig [String] +projectPackages f s = fmap (\x -> s{T.projectPackages = x}) (f (T.projectPackages s)) +{-# INLINEABLE projectPackages #-} + +projectPackagesOptional :: Lens' ProjectConfig [String] +projectPackagesOptional f s = fmap (\x -> s{T.projectPackagesOptional = x}) (f (T.projectPackagesOptional s)) +{-# INLINEABLE projectPackagesOptional #-} + +projectPackagesRepo :: Lens' ProjectConfig [SourceRepoList] +projectPackagesRepo f s = fmap (\x -> s{T.projectPackagesRepo = x}) (f (T.projectPackagesRepo s)) +{-# INLINEABLE projectPackagesRepo #-} + +projectPackagesNamed :: Lens' ProjectConfig [PackageVersionConstraint] +projectPackagesNamed f s = fmap (\x -> s{T.projectPackagesNamed = x}) (f (T.projectPackagesNamed s)) +{-# INLINEABLE projectPackagesNamed #-} + +projectConfigBuildOnly :: Lens' ProjectConfig ProjectConfigBuildOnly +projectConfigBuildOnly f s = fmap (\x -> s{T.projectConfigBuildOnly = x}) (f (T.projectConfigBuildOnly s)) +{-# INLINEABLE projectConfigBuildOnly #-} + +projectConfigShared :: Lens' ProjectConfig ProjectConfigShared +projectConfigShared f s = fmap (\x -> s{T.projectConfigShared = x}) (f (T.projectConfigShared s)) +{-# INLINEABLE projectConfigShared #-} + +projectConfigProvenance :: Lens' ProjectConfig (Set ProjectConfigProvenance) +projectConfigProvenance f s = fmap (\x -> s{T.projectConfigProvenance = x}) (f (T.projectConfigProvenance s)) +{-# INLINEABLE projectConfigProvenance #-} + +projectConfigAllPackages :: Lens' ProjectConfig PackageConfig +projectConfigAllPackages f s = fmap (\x -> s{T.projectConfigAllPackages = x}) (f (T.projectConfigAllPackages s)) +{-# INLINEABLE projectConfigAllPackages #-} + +projectConfigLocalPackages :: Lens' ProjectConfig PackageConfig +projectConfigLocalPackages f s = fmap (\x -> s{T.projectConfigLocalPackages = x}) (f (T.projectConfigLocalPackages s)) +{-# INLINEABLE projectConfigLocalPackages #-} + +projectConfigSpecificPackage :: Lens' ProjectConfig (MapMappend PackageName PackageConfig) +projectConfigSpecificPackage f s = fmap (\x -> s{T.projectConfigSpecificPackage = x}) (f (T.projectConfigSpecificPackage s)) +{-# INLINEABLE projectConfigSpecificPackage #-} + +projectConfigVerbosity :: Lens' ProjectConfigBuildOnly (Flag Verbosity) +projectConfigVerbosity f s = fmap (\x -> s{T.projectConfigVerbosity = x}) (f (T.projectConfigVerbosity s)) +{-# INLINEABLE projectConfigVerbosity #-} + +projectConfigSummaryFile :: Lens' ProjectConfigBuildOnly (NubList PathTemplate) +projectConfigSummaryFile f s = fmap (\x -> s{T.projectConfigSummaryFile = x}) (f (T.projectConfigSummaryFile s)) +{-# INLINEABLE projectConfigSummaryFile #-} + +projectConfigLogFile :: Lens' ProjectConfigBuildOnly (Flag PathTemplate) +projectConfigLogFile f s = fmap (\x -> s{T.projectConfigLogFile = x}) (f (T.projectConfigLogFile s)) +{-# INLINEABLE projectConfigLogFile #-} + +projectConfigBuildReports :: Lens' ProjectConfigBuildOnly (Flag ReportLevel) +projectConfigBuildReports f s = fmap (\x -> s{T.projectConfigBuildReports = x}) (f (T.projectConfigBuildReports s)) +{-# INLINEABLE projectConfigBuildReports #-} + +projectConfigReportPlanningFailure :: Lens' ProjectConfigBuildOnly (Flag Bool) +projectConfigReportPlanningFailure f s = fmap (\x -> s{T.projectConfigReportPlanningFailure = x}) (f (T.projectConfigReportPlanningFailure s)) +{-# INLINEABLE projectConfigReportPlanningFailure #-} + +projectConfigSymlinkBinDir :: Lens' ProjectConfigBuildOnly (Flag FilePath) +projectConfigSymlinkBinDir f s = fmap (\x -> s{T.projectConfigSymlinkBinDir = x}) (f (T.projectConfigSymlinkBinDir s)) +{-# INLINEABLE projectConfigSymlinkBinDir #-} + +projectConfigNumJobs :: Lens' ProjectConfigBuildOnly (Flag (Maybe Int)) +projectConfigNumJobs f s = fmap (\x -> s{T.projectConfigNumJobs = x}) (f (T.projectConfigNumJobs s)) +{-# INLINEABLE projectConfigNumJobs #-} + +projectConfigUseSemaphore :: Lens' ProjectConfigBuildOnly (Flag Bool) +projectConfigUseSemaphore f s = fmap (\x -> s{T.projectConfigUseSemaphore = x}) (f (T.projectConfigUseSemaphore s)) +{-# INLINEABLE projectConfigUseSemaphore #-} + +projectConfigKeepGoing :: Lens' ProjectConfigBuildOnly (Flag Bool) +projectConfigKeepGoing f s = fmap (\x -> s{T.projectConfigKeepGoing = x}) (f (T.projectConfigKeepGoing s)) +{-# INLINEABLE projectConfigKeepGoing #-} + +projectConfigOfflineMode :: Lens' ProjectConfigBuildOnly (Flag Bool) +projectConfigOfflineMode f s = fmap (\x -> s{T.projectConfigOfflineMode = x}) (f (T.projectConfigOfflineMode s)) +{-# INLINEABLE projectConfigOfflineMode #-} + +projectConfigKeepTempFiles :: Lens' ProjectConfigBuildOnly (Flag Bool) +projectConfigKeepTempFiles f s = fmap (\x -> s{T.projectConfigKeepTempFiles = x}) (f (T.projectConfigKeepTempFiles s)) +{-# INLINEABLE projectConfigKeepTempFiles #-} + +projectConfigHttpTransport :: Lens' ProjectConfigBuildOnly (Flag String) +projectConfigHttpTransport f s = fmap (\x -> s{T.projectConfigHttpTransport = x}) (f (T.projectConfigHttpTransport s)) +{-# INLINEABLE projectConfigHttpTransport #-} + +projectConfigIgnoreExpiry :: Lens' ProjectConfigBuildOnly (Flag Bool) +projectConfigIgnoreExpiry f s = fmap (\x -> s{T.projectConfigIgnoreExpiry = x}) (f (T.projectConfigIgnoreExpiry s)) +{-# INLINEABLE projectConfigIgnoreExpiry #-} + +projectConfigCacheDir :: Lens' ProjectConfigBuildOnly (Flag FilePath) +projectConfigCacheDir f s = fmap (\x -> s{T.projectConfigCacheDir = x}) (f (T.projectConfigCacheDir s)) +{-# INLINEABLE projectConfigCacheDir #-} + +projectConfigLogsDir :: Lens' ProjectConfigBuildOnly (Flag FilePath) +projectConfigLogsDir f s = fmap (\x -> s{T.projectConfigLogsDir = x}) (f (T.projectConfigLogsDir s)) +{-# INLINEABLE projectConfigLogsDir #-} + +projectConfigDistDir :: Lens' ProjectConfigShared (Flag FilePath) +projectConfigDistDir f s = fmap (\x -> s{T.projectConfigDistDir = x}) (f (T.projectConfigDistDir s)) +{-# INLINEABLE projectConfigDistDir #-} + +projectConfigProjectDir :: Lens' ProjectConfigShared (Flag FilePath) +projectConfigProjectDir f s = fmap (\x -> s{T.projectConfigProjectDir = x}) (f (T.projectConfigProjectDir s)) +{-# INLINEABLE projectConfigProjectDir #-} + +projectConfigStoreDir :: Lens' ProjectConfigShared (Flag FilePath) +projectConfigStoreDir f s = fmap (\x -> s{T.projectConfigStoreDir = x}) (f (T.projectConfigStoreDir s)) +{-# INLINEABLE projectConfigStoreDir #-} + +projectConfigPerComponent :: Lens' ProjectConfigShared (Flag Bool) +projectConfigPerComponent f s = fmap (\x -> s{T.projectConfigPerComponent = x}) (f (T.projectConfigPerComponent s)) +{-# INLINEABLE projectConfigPerComponent #-} + +projectConfigIndependentGoals :: Lens' ProjectConfigShared (Flag IndependentGoals) +projectConfigIndependentGoals f s = fmap (\x -> s{T.projectConfigIndependentGoals = x}) (f (T.projectConfigIndependentGoals s)) +{-# INLINEABLE projectConfigIndependentGoals #-} + +projectConfigProjectFile :: Lens' ProjectConfigShared (Flag FilePath) +projectConfigProjectFile f s = fmap (\x -> s{T.projectConfigProjectFile = x}) (f (T.projectConfigProjectFile s)) +{-# INLINEABLE projectConfigProjectFile #-} + +projectConfigIgnoreProject :: Lens' ProjectConfigShared (Flag Bool) +projectConfigIgnoreProject f s = fmap (\x -> s{T.projectConfigIgnoreProject = x}) (f (T.projectConfigIgnoreProject s)) +{-# INLINEABLE projectConfigIgnoreProject #-} + +projectConfigHcFlavor :: Lens' ProjectConfigShared (Flag CompilerFlavor) +projectConfigHcFlavor f s = fmap (\x -> s{T.projectConfigHcFlavor = x}) (f (T.projectConfigHcFlavor s)) +{-# INLINEABLE projectConfigHcFlavor #-} + +projectConfigHcPath :: Lens' ProjectConfigShared (Flag FilePath) +projectConfigHcPath f s = fmap (\x -> s{T.projectConfigHcPath = x}) (f (T.projectConfigHcPath s)) +{-# INLINEABLE projectConfigHcPath #-} + +projectConfigHcPkg :: Lens' ProjectConfigShared (Flag FilePath) +projectConfigHcPkg f s = fmap (\x -> s{T.projectConfigHcPkg = x}) (f (T.projectConfigHcPkg s)) +{-# INLINEABLE projectConfigHcPkg #-} + +projectConfigHaddockIndex :: Lens' ProjectConfigShared (Flag PathTemplate) +projectConfigHaddockIndex f s = fmap (\x -> s{T.projectConfigHaddockIndex = x}) (f (T.projectConfigHaddockIndex s)) +{-# INLINEABLE projectConfigHaddockIndex #-} + +projectConfigPackageDBs :: Lens' ProjectConfigShared [Maybe PackageDB] +projectConfigPackageDBs f s = fmap (\x -> s{T.projectConfigPackageDBs = x}) (f (T.projectConfigPackageDBs s)) +{-# INLINEABLE projectConfigPackageDBs #-} + +projectConfigActiveRepos :: Lens' ProjectConfigShared (Flag ActiveRepos) +projectConfigActiveRepos f s = fmap (\x -> s{T.projectConfigActiveRepos = x}) (f (T.projectConfigActiveRepos s)) +{-# INLINEABLE projectConfigActiveRepos #-} + +projectConfigIndexState :: Lens' ProjectConfigShared (Flag TotalIndexState) +projectConfigIndexState f s = fmap (\x -> s{T.projectConfigIndexState = x}) (f (T.projectConfigIndexState s)) +{-# INLINEABLE projectConfigIndexState #-} + +projectConfigConstraints :: Lens' ProjectConfigShared [(UserConstraint, ConstraintSource)] +projectConfigConstraints f s = fmap (\x -> s{T.projectConfigConstraints = x}) (f (T.projectConfigConstraints s)) +{-# INLINEABLE projectConfigConstraints #-} + +projectConfigPreferences :: Lens' ProjectConfigShared [PackageVersionConstraint] +projectConfigPreferences f s = fmap (\x -> s{T.projectConfigPreferences = x}) (f (T.projectConfigPreferences s)) +{-# INLINEABLE projectConfigPreferences #-} + +projectConfigCabalVersion :: Lens' ProjectConfigShared (Flag Version) +projectConfigCabalVersion f s = fmap (\x -> s{T.projectConfigCabalVersion = x}) (f (T.projectConfigCabalVersion s)) +{-# INLINEABLE projectConfigCabalVersion #-} + +projectConfigSolver :: Lens' ProjectConfigShared (Flag PreSolver) +projectConfigSolver f s = fmap (\x -> s{T.projectConfigSolver = x}) (f (T.projectConfigSolver s)) +{-# INLINEABLE projectConfigSolver #-} + +projectConfigAllowOlder :: Lens' ProjectConfigShared (Maybe AllowOlder) +projectConfigAllowOlder f s = fmap (\x -> s{T.projectConfigAllowOlder = x}) (f (T.projectConfigAllowOlder s)) +{-# INLINEABLE projectConfigAllowOlder #-} + +projectConfigAllowNewer :: Lens' ProjectConfigShared (Maybe AllowNewer) +projectConfigAllowNewer f s = fmap (\x -> s{T.projectConfigAllowNewer = x}) (f (T.projectConfigAllowNewer s)) +{-# INLINEABLE projectConfigAllowNewer #-} + +projectConfigWriteGhcEnvironmentFilesPolicy :: Lens' ProjectConfigShared (Flag WriteGhcEnvironmentFilesPolicy) +projectConfigWriteGhcEnvironmentFilesPolicy f s = fmap (\x -> s{T.projectConfigWriteGhcEnvironmentFilesPolicy = x}) (f (T.projectConfigWriteGhcEnvironmentFilesPolicy s)) +{-# INLINEABLE projectConfigWriteGhcEnvironmentFilesPolicy #-} + +projectConfigMaxBackjumps :: Lens' ProjectConfigShared (Flag Int) +projectConfigMaxBackjumps f s = fmap (\x -> s{T.projectConfigMaxBackjumps = x}) (f (T.projectConfigMaxBackjumps s)) +{-# INLINEABLE projectConfigMaxBackjumps #-} + +projectConfigReorderGoals :: Lens' ProjectConfigShared (Flag ReorderGoals) +projectConfigReorderGoals f s = fmap (\x -> s{T.projectConfigReorderGoals = x}) (f (T.projectConfigReorderGoals s)) +{-# INLINEABLE projectConfigReorderGoals #-} + +projectConfigCountConflicts :: Lens' ProjectConfigShared (Flag CountConflicts) +projectConfigCountConflicts f s = fmap (\x -> s{T.projectConfigCountConflicts = x}) (f (T.projectConfigCountConflicts s)) +{-# INLINEABLE projectConfigCountConflicts #-} + +projectConfigFineGrainedConflicts :: Lens' ProjectConfigShared (Flag FineGrainedConflicts) +projectConfigFineGrainedConflicts f s = fmap (\x -> s{T.projectConfigFineGrainedConflicts = x}) (f (T.projectConfigFineGrainedConflicts s)) +{-# INLINEABLE projectConfigFineGrainedConflicts #-} + +projectConfigMinimizeConflictSet :: Lens' ProjectConfigShared (Flag MinimizeConflictSet) +projectConfigMinimizeConflictSet f s = fmap (\x -> s{T.projectConfigMinimizeConflictSet = x}) (f (T.projectConfigMinimizeConflictSet s)) +{-# INLINEABLE projectConfigMinimizeConflictSet #-} + +projectConfigStrongFlags :: Lens' ProjectConfigShared (Flag StrongFlags) +projectConfigStrongFlags f s = fmap (\x -> s{T.projectConfigStrongFlags = x}) (f (T.projectConfigStrongFlags s)) +{-# INLINEABLE projectConfigStrongFlags #-} + +projectConfigAllowBootLibInstalls :: Lens' ProjectConfigShared (Flag AllowBootLibInstalls) +projectConfigAllowBootLibInstalls f s = fmap (\x -> s{T.projectConfigAllowBootLibInstalls = x}) (f (T.projectConfigAllowBootLibInstalls s)) +{-# INLINEABLE projectConfigAllowBootLibInstalls #-} + +projectConfigOnlyConstrained :: Lens' ProjectConfigShared (Flag OnlyConstrained) +projectConfigOnlyConstrained f s = fmap (\x -> s{T.projectConfigOnlyConstrained = x}) (f (T.projectConfigOnlyConstrained s)) +{-# INLINEABLE projectConfigOnlyConstrained #-} + +projectConfigPreferOldest :: Lens' ProjectConfigShared (Flag PreferOldest) +projectConfigPreferOldest f s = fmap (\x -> s{T.projectConfigPreferOldest = x}) (f (T.projectConfigPreferOldest s)) +{-# INLINEABLE projectConfigPreferOldest #-} + +projectConfigProgPathExtra :: Lens' ProjectConfigShared (NubList FilePath) +projectConfigProgPathExtra f s = fmap (\x -> s{T.projectConfigProgPathExtra = x}) (f (T.projectConfigProgPathExtra s)) +{-# INLINEABLE projectConfigProgPathExtra #-} + +projectConfigMultiRepl :: Lens' ProjectConfigShared (Flag Bool) +projectConfigMultiRepl f s = fmap (\x -> s{T.projectConfigMultiRepl = x}) (f (T.projectConfigMultiRepl s)) +{-# INLINEABLE projectConfigMultiRepl #-} + +packageConfigProgramPathExtra :: Lens' PackageConfig (NubList FilePath) +packageConfigProgramPathExtra f s = fmap (\x -> s{T.packageConfigProgramPathExtra = x}) (f (T.packageConfigProgramPathExtra s)) +{-# INLINEABLE packageConfigProgramPathExtra #-} + +packageConfigFlagAssignment :: Lens' PackageConfig (FlagAssignment) +packageConfigFlagAssignment f s = fmap (\x -> s{T.packageConfigFlagAssignment = x}) (f (T.packageConfigFlagAssignment s)) +{-# INLINEABLE packageConfigFlagAssignment #-} + +packageConfigVanillaLib :: Lens' PackageConfig (Flag Bool) +packageConfigVanillaLib f s = fmap (\x -> s{T.packageConfigVanillaLib = x}) (f (T.packageConfigVanillaLib s)) +{-# INLINEABLE packageConfigVanillaLib #-} + +packageConfigSharedLib :: Lens' PackageConfig (Flag Bool) +packageConfigSharedLib f s = fmap (\x -> s{T.packageConfigSharedLib = x}) (f (T.packageConfigSharedLib s)) +{-# INLINEABLE packageConfigSharedLib #-} + +packageConfigStaticLib :: Lens' PackageConfig (Flag Bool) +packageConfigStaticLib f s = fmap (\x -> s{T.packageConfigStaticLib = x}) (f (T.packageConfigStaticLib s)) +{-# INLINEABLE packageConfigStaticLib #-} + +packageConfigDynExe :: Lens' PackageConfig (Flag Bool) +packageConfigDynExe f s = fmap (\x -> s{T.packageConfigDynExe = x}) (f (T.packageConfigDynExe s)) +{-# INLINEABLE packageConfigDynExe #-} + +packageConfigFullyStaticExe :: Lens' PackageConfig (Flag Bool) +packageConfigFullyStaticExe f s = fmap (\x -> s{T.packageConfigFullyStaticExe = x}) (f (T.packageConfigFullyStaticExe s)) +{-# INLINEABLE packageConfigFullyStaticExe #-} + +packageConfigProf :: Lens' PackageConfig (Flag Bool) +packageConfigProf f s = fmap (\x -> s{T.packageConfigProf = x}) (f (T.packageConfigProf s)) +{-# INLINEABLE packageConfigProf #-} + +packageConfigProfLib :: Lens' PackageConfig (Flag Bool) +packageConfigProfLib f s = fmap (\x -> s{T.packageConfigProfLib = x}) (f (T.packageConfigProfLib s)) +{-# INLINEABLE packageConfigProfLib #-} + +packageConfigProfExe :: Lens' PackageConfig (Flag Bool) +packageConfigProfExe f s = fmap (\x -> s{T.packageConfigProfExe = x}) (f (T.packageConfigProfExe s)) +{-# INLINEABLE packageConfigProfExe #-} + +packageConfigProfDetail :: Lens' PackageConfig (Flag ProfDetailLevel) +packageConfigProfDetail f s = fmap (\x -> s{T.packageConfigProfDetail = x}) (f (T.packageConfigProfDetail s)) +{-# INLINEABLE packageConfigProfDetail #-} + +packageConfigProfLibDetail :: Lens' PackageConfig (Flag ProfDetailLevel) +packageConfigProfLibDetail f s = fmap (\x -> s{T.packageConfigProfLibDetail = x}) (f (T.packageConfigProfLibDetail s)) +{-# INLINEABLE packageConfigProfLibDetail #-} + +packageConfigConfigureArgs :: Lens' PackageConfig [String] +packageConfigConfigureArgs f s = fmap (\x -> s{T.packageConfigConfigureArgs = x}) (f (T.packageConfigConfigureArgs s)) +{-# INLINEABLE packageConfigConfigureArgs #-} + +packageConfigOptimization :: Lens' PackageConfig (Flag OptimisationLevel) +packageConfigOptimization f s = fmap (\x -> s{T.packageConfigOptimization = x}) (f (T.packageConfigOptimization s)) +{-# INLINEABLE packageConfigOptimization #-} + +packageConfigProgPrefix :: Lens' PackageConfig (Flag PathTemplate) +packageConfigProgPrefix f s = fmap (\x -> s{T.packageConfigProgPrefix = x}) (f (T.packageConfigProgPrefix s)) +{-# INLINEABLE packageConfigProgPrefix #-} + +packageConfigProgSuffix :: Lens' PackageConfig (Flag PathTemplate) +packageConfigProgSuffix f s = fmap (\x -> s{T.packageConfigProgSuffix = x}) (f (T.packageConfigProgSuffix s)) +{-# INLINEABLE packageConfigProgSuffix #-} + +packageConfigExtraLibDirs :: Lens' PackageConfig [FilePath] +packageConfigExtraLibDirs f s = fmap (\x -> s{T.packageConfigExtraLibDirs = x}) (f (T.packageConfigExtraLibDirs s)) +{-# INLINEABLE packageConfigExtraLibDirs #-} + +packageConfigExtraLibDirsStatic :: Lens' PackageConfig [FilePath] +packageConfigExtraLibDirsStatic f s = fmap (\x -> s{T.packageConfigExtraLibDirsStatic = x}) (f (T.packageConfigExtraLibDirsStatic s)) +{-# INLINEABLE packageConfigExtraLibDirsStatic #-} + +packageConfigExtraFrameworkDirs :: Lens' PackageConfig [FilePath] +packageConfigExtraFrameworkDirs f s = fmap (\x -> s{T.packageConfigExtraFrameworkDirs = x}) (f (T.packageConfigExtraFrameworkDirs s)) +{-# INLINEABLE packageConfigExtraFrameworkDirs #-} + +packageConfigExtraIncludeDirs :: Lens' PackageConfig [FilePath] +packageConfigExtraIncludeDirs f s = fmap (\x -> s{T.packageConfigExtraIncludeDirs = x}) (f (T.packageConfigExtraIncludeDirs s)) +{-# INLINEABLE packageConfigExtraIncludeDirs #-} + +packageConfigGHCiLib :: Lens' PackageConfig (Flag Bool) +packageConfigGHCiLib f s = fmap (\x -> s{T.packageConfigGHCiLib = x}) (f (T.packageConfigGHCiLib s)) +{-# INLINEABLE packageConfigGHCiLib #-} + +packageConfigSplitSections :: Lens' PackageConfig (Flag Bool) +packageConfigSplitSections f s = fmap (\x -> s{T.packageConfigSplitSections = x}) (f (T.packageConfigSplitSections s)) +{-# INLINEABLE packageConfigSplitSections #-} + +packageConfigSplitObjs :: Lens' PackageConfig (Flag Bool) +packageConfigSplitObjs f s = fmap (\x -> s{T.packageConfigSplitObjs = x}) (f (T.packageConfigSplitObjs s)) +{-# INLINEABLE packageConfigSplitObjs #-} + +packageConfigStripExes :: Lens' PackageConfig (Flag Bool) +packageConfigStripExes f s = fmap (\x -> s{T.packageConfigStripExes = x}) (f (T.packageConfigStripExes s)) +{-# INLINEABLE packageConfigStripExes #-} + +packageConfigStripLibs :: Lens' PackageConfig (Flag Bool) +packageConfigStripLibs f s = fmap (\x -> s{T.packageConfigStripLibs = x}) (f (T.packageConfigStripLibs s)) +{-# INLINEABLE packageConfigStripLibs #-} + +packageConfigTests :: Lens' PackageConfig (Flag Bool) +packageConfigTests f s = fmap (\x -> s{T.packageConfigTests = x}) (f (T.packageConfigTests s)) +{-# INLINEABLE packageConfigTests #-} + +packageConfigBenchmarks :: Lens' PackageConfig (Flag Bool) +packageConfigBenchmarks f s = fmap (\x -> s{T.packageConfigBenchmarks = x}) (f (T.packageConfigBenchmarks s)) +{-# INLINEABLE packageConfigBenchmarks #-} + +packageConfigCoverage :: Lens' PackageConfig (Flag Bool) +packageConfigCoverage f s = fmap (\x -> s{T.packageConfigCoverage = x}) (f (T.packageConfigCoverage s)) +{-# INLINEABLE packageConfigCoverage #-} + +packageConfigRelocatable :: Lens' PackageConfig (Flag Bool) +packageConfigRelocatable f s = fmap (\x -> s{T.packageConfigRelocatable = x}) (f (T.packageConfigRelocatable s)) +{-# INLINEABLE packageConfigRelocatable #-} + +packageConfigDebugInfo :: Lens' PackageConfig (Flag DebugInfoLevel) +packageConfigDebugInfo f s = fmap (\x -> s{T.packageConfigDebugInfo = x}) (f (T.packageConfigDebugInfo s)) +{-# INLINEABLE packageConfigDebugInfo #-} + +packageConfigDumpBuildInfo :: Lens' PackageConfig (Flag DumpBuildInfo) +packageConfigDumpBuildInfo f s = fmap (\x -> s{T.packageConfigDumpBuildInfo = x}) (f (T.packageConfigDumpBuildInfo s)) +{-# INLINEABLE packageConfigDumpBuildInfo #-} + +packageConfigRunTests :: Lens' PackageConfig (Flag Bool) +packageConfigRunTests f s = fmap (\x -> s{T.packageConfigRunTests = x}) (f (T.packageConfigRunTests s)) +{-# INLINEABLE packageConfigRunTests #-} + +packageConfigDocumentation :: Lens' PackageConfig (Flag Bool) +packageConfigDocumentation f s = fmap (\x -> s{T.packageConfigDocumentation = x}) (f (T.packageConfigDocumentation s)) +{-# INLINEABLE packageConfigDocumentation #-} + +packageConfigHaddockHoogle :: Lens' PackageConfig (Flag Bool) +packageConfigHaddockHoogle f s = fmap (\x -> s{T.packageConfigHaddockHoogle = x}) (f (T.packageConfigHaddockHoogle s)) +{-# INLINEABLE packageConfigHaddockHoogle #-} + +packageConfigHaddockHtml :: Lens' PackageConfig (Flag Bool) +packageConfigHaddockHtml f s = fmap (\x -> s{T.packageConfigHaddockHtml = x}) (f (T.packageConfigHaddockHtml s)) +{-# INLINEABLE packageConfigHaddockHtml #-} + +packageConfigHaddockHtmlLocation :: Lens' PackageConfig (Flag String) +packageConfigHaddockHtmlLocation f s = fmap (\x -> s{T.packageConfigHaddockHtmlLocation = x}) (f (T.packageConfigHaddockHtmlLocation s)) +{-# INLINEABLE packageConfigHaddockHtmlLocation #-} + +packageConfigHaddockForeignLibs :: Lens' PackageConfig (Flag Bool) +packageConfigHaddockForeignLibs f s = fmap (\x -> s{T.packageConfigHaddockForeignLibs = x}) (f (T.packageConfigHaddockForeignLibs s)) +{-# INLINEABLE packageConfigHaddockForeignLibs #-} + +packageConfigHaddockExecutables :: Lens' PackageConfig (Flag Bool) +packageConfigHaddockExecutables f s = fmap (\x -> s{T.packageConfigHaddockExecutables = x}) (f (T.packageConfigHaddockExecutables s)) +{-# INLINEABLE packageConfigHaddockExecutables #-} + +packageConfigHaddockTestSuites :: Lens' PackageConfig (Flag Bool) +packageConfigHaddockTestSuites f s = fmap (\x -> s{T.packageConfigHaddockTestSuites = x}) (f (T.packageConfigHaddockTestSuites s)) +{-# INLINEABLE packageConfigHaddockTestSuites #-} + +packageConfigHaddockBenchmarks :: Lens' PackageConfig (Flag Bool) +packageConfigHaddockBenchmarks f s = fmap (\x -> s{T.packageConfigHaddockBenchmarks = x}) (f (T.packageConfigHaddockBenchmarks s)) +{-# INLINEABLE packageConfigHaddockBenchmarks #-} + +packageConfigHaddockInternal :: Lens' PackageConfig (Flag Bool) +packageConfigHaddockInternal f s = fmap (\x -> s{T.packageConfigHaddockInternal = x}) (f (T.packageConfigHaddockInternal s)) +{-# INLINEABLE packageConfigHaddockInternal #-} + +packageConfigHaddockCss :: Lens' PackageConfig (Flag FilePath) +packageConfigHaddockCss f s = fmap (\x -> s{T.packageConfigHaddockCss = x}) (f (T.packageConfigHaddockCss s)) +{-# INLINEABLE packageConfigHaddockCss #-} + +packageConfigHaddockLinkedSource :: Lens' PackageConfig (Flag Bool) +packageConfigHaddockLinkedSource f s = fmap (\x -> s{T.packageConfigHaddockLinkedSource = x}) (f (T.packageConfigHaddockLinkedSource s)) +{-# INLINEABLE packageConfigHaddockLinkedSource #-} + +packageConfigHaddockQuickJump :: Lens' PackageConfig (Flag Bool) +packageConfigHaddockQuickJump f s = fmap (\x -> s{T.packageConfigHaddockQuickJump = x}) (f (T.packageConfigHaddockQuickJump s)) +{-# INLINEABLE packageConfigHaddockQuickJump #-} + +packageConfigHaddockHscolourCss :: Lens' PackageConfig (Flag FilePath) +packageConfigHaddockHscolourCss f s = fmap (\x -> s{T.packageConfigHaddockHscolourCss = x}) (f (T.packageConfigHaddockHscolourCss s)) +{-# INLINEABLE packageConfigHaddockHscolourCss #-} + +packageConfigHaddockContents :: Lens' PackageConfig (Flag PathTemplate) +packageConfigHaddockContents f s = fmap (\x -> s{T.packageConfigHaddockContents = x}) (f (T.packageConfigHaddockContents s)) +{-# INLINEABLE packageConfigHaddockContents #-} + +packageConfigHaddockIndex :: Lens' PackageConfig (Flag PathTemplate) +packageConfigHaddockIndex f s = fmap (\x -> s{T.packageConfigHaddockIndex = x}) (f (T.packageConfigHaddockIndex s)) +{-# INLINEABLE packageConfigHaddockIndex #-} + +packageConfigHaddockBaseUrl :: Lens' PackageConfig (Flag String) +packageConfigHaddockBaseUrl f s = fmap (\x -> s{T.packageConfigHaddockBaseUrl = x}) (f (T.packageConfigHaddockBaseUrl s)) +{-# INLINEABLE packageConfigHaddockBaseUrl #-} + +packageConfigHaddockLib :: Lens' PackageConfig (Flag String) +packageConfigHaddockLib f s = fmap (\x -> s{T.packageConfigHaddockLib = x}) (f (T.packageConfigHaddockLib s)) +{-# INLINEABLE packageConfigHaddockLib #-} + +packageConfigHaddockOutputDir :: Lens' PackageConfig (Flag FilePath) +packageConfigHaddockOutputDir f s = fmap (\x -> s{T.packageConfigHaddockOutputDir = x}) (f (T.packageConfigHaddockOutputDir s)) +{-# INLINEABLE packageConfigHaddockOutputDir #-} + +packageConfigHaddockForHackage :: Lens' PackageConfig (Flag HaddockTarget) +packageConfigHaddockForHackage f s = fmap (\x -> s{T.packageConfigHaddockForHackage = x}) (f (T.packageConfigHaddockForHackage s)) +{-# INLINEABLE packageConfigHaddockForHackage #-} + +packageConfigTestHumanLog :: Lens' PackageConfig (Flag PathTemplate) +packageConfigTestHumanLog f s = fmap (\x -> s{T.packageConfigTestHumanLog = x}) (f (T.packageConfigTestHumanLog s)) +{-# INLINEABLE packageConfigTestHumanLog #-} + +packageConfigTestMachineLog :: Lens' PackageConfig (Flag PathTemplate) +packageConfigTestMachineLog f s = fmap (\x -> s{T.packageConfigTestMachineLog = x}) (f (T.packageConfigTestMachineLog s)) +{-# INLINEABLE packageConfigTestMachineLog #-} + +packageConfigTestShowDetails :: Lens' PackageConfig (Flag TestShowDetails) +packageConfigTestShowDetails f s = fmap (\x -> s{T.packageConfigTestShowDetails = x}) (f (T.packageConfigTestShowDetails s)) +{-# INLINEABLE packageConfigTestShowDetails #-} + +packageConfigTestKeepTix :: Lens' PackageConfig (Flag Bool) +packageConfigTestKeepTix f s = fmap (\x -> s{T.packageConfigTestKeepTix = x}) (f (T.packageConfigTestKeepTix s)) +{-# INLINEABLE packageConfigTestKeepTix #-} + +packageConfigTestWrapper :: Lens' PackageConfig (Flag FilePath) +packageConfigTestWrapper f s = fmap (\x -> s{T.packageConfigTestWrapper = x}) (f (T.packageConfigTestWrapper s)) +{-# INLINEABLE packageConfigTestWrapper #-} + +packageConfigTestFailWhenNoTestSuites :: Lens' PackageConfig (Flag Bool) +packageConfigTestFailWhenNoTestSuites f s = fmap (\x -> s{T.packageConfigTestFailWhenNoTestSuites = x}) (f (T.packageConfigTestFailWhenNoTestSuites s)) +{-# INLINEABLE packageConfigTestFailWhenNoTestSuites #-} + +packageConfigTestTestOptions :: Lens' PackageConfig [PathTemplate] +packageConfigTestTestOptions f s = fmap (\x -> s{T.packageConfigTestTestOptions = x}) (f (T.packageConfigTestTestOptions s)) +{-# INLINEABLE packageConfigTestTestOptions #-} + +packageConfigBenchmarkOptions :: Lens' PackageConfig [PathTemplate] +packageConfigBenchmarkOptions f s = fmap (\x -> s{T.packageConfigBenchmarkOptions = x}) (f (T.packageConfigBenchmarkOptions s)) +{-# INLINEABLE packageConfigBenchmarkOptions #-} diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs new file mode 100644 index 00000000000..3907f958af0 --- /dev/null +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Parsing project configuration. +module Distribution.Client.ProjectConfig.Parsec + ( -- * Package configuration + parseProjectSkeleton + , parseProject + , ProjectConfigSkeleton + , ProjectConfig (..) + + -- ** Parsing + , ParseResult + , runParseResult + ) where + +import Network.URI (parseURI) + +import Control.Monad.State.Strict (StateT, execStateT, lift) +import qualified Data.Map.Strict as Map +import Distribution.CabalSpecVersion +import Distribution.Client.HttpUtils +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Distribution.FieldGrammar +import Distribution.FieldGrammar.Parsec (NamelessField (..), namelessFieldAnn) +import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS) +import Distribution.Simple.Utils (debug, warn) +import Distribution.Verbosity + +import Distribution.Client.ProjectConfig.FieldGrammar (packageConfigFieldGrammar, projectConfigFieldGrammar) +import Distribution.Client.ProjectConfig.Legacy (ProjectConfigSkeleton) +import qualified Distribution.Client.ProjectConfig.Lens as L +import Distribution.Client.ProjectConfig.Types (MapLast (..), MapMappend (..), PackageConfig (..), ProjectConfig (..), ProjectConfigShared (..), ProjectConfigToParse (..)) +import Distribution.Client.Types.SourceRepo (sourceRepositoryPackageGrammar) +import Distribution.Fields.ConfVar (parseConditionConfVar) +import Distribution.Fields.ParseResult +import Distribution.Solver.Types.ProjectConfigPath + +-- AST type +import Distribution.Fields (Field (..), FieldLine (..), FieldName, Name (..), SectionArg (..), readFields', showPWarning) +import Distribution.Fields.LexerMonad (toPWarnings) +import Distribution.Parsec (CabalParsing, PError (..), ParsecParser, parsec, parsecFilePath, parsecToken, runParsecParser) +import Distribution.Parsec.Position (Position (..), zeroPos) +import Distribution.Parsec.Warning (PWarnType (..)) +import Distribution.Simple.Program.Db (ProgramDb, defaultProgramDb, knownPrograms, lookupKnownProgram) +import Distribution.Simple.Program.Types (programName) +import Distribution.Simple.Setup (Flag (..)) +import Distribution.Types.CondTree (CondBranch (..), CondTree (..)) +import Distribution.Types.ConfVar (ConfVar (..)) +import Distribution.Types.PackageName (PackageName) +import Distribution.Utils.Generic (fromUTF8BS, toUTF8BS, validateUTF8) + +import qualified Data.ByteString as BS +import Data.Coerce (coerce) +import qualified Distribution.Compat.CharParsing as P +import System.Directory (createDirectoryIfMissing, makeAbsolute) +import System.FilePath (isAbsolute, isPathSeparator, makeValid, splitFileName, ()) +import qualified Text.Parsec +import Text.PrettyPrint (render) + +singletonProjectConfigSkeleton :: ProjectConfig -> ProjectConfigSkeleton +singletonProjectConfigSkeleton x = CondNode x mempty mempty + +readPreprocessFields :: BS.ByteString -> ParseResult [Field Position] +readPreprocessFields bs = do + case readFields' bs' of + Right (fs, lexWarnings) -> do + parseWarnings (toPWarnings lexWarnings) + for_ invalidUtf8 $ \pos -> + parseWarning zeroPos PWTUTF $ "UTF8 encoding problem at byte offset " ++ show pos + return fs + Left perr -> parseFatalFailure pos (show perr) + where + ppos = Text.Parsec.errorPos perr + pos = Position (Text.Parsec.sourceLine ppos) (Text.Parsec.sourceColumn ppos) + where + invalidUtf8 = validateUTF8 bs + bs' = case invalidUtf8 of + Nothing -> bs + Just _ -> toUTF8BS (fromUTF8BS bs) + +-- | Parses a project from its root config file, typically cabal.project. +parseProject + :: FilePath + -- ^ The root of the project configuration, typically cabal.project + -> FilePath + -> HttpTransport + -> Verbosity + -> ProjectConfigToParse + -- ^ The contents of the file to parse + -> IO (ParseResult ProjectConfigSkeleton) +parseProject rootPath cacheDir httpTransport verbosity configToParse = do + let (dir, projectFileName) = splitFileName rootPath + projectDir <- makeAbsolute dir + projectPath <- canonicalizeConfigPath projectDir (ProjectConfigPath $ projectFileName :| []) + parseProjectSkeleton cacheDir httpTransport verbosity projectDir projectPath configToParse + +parseProjectSkeleton + :: FilePath + -> HttpTransport + -> Verbosity + -> FilePath + -- ^ The directory of the project configuration, typically the directory of cabal.project + -> ProjectConfigPath + -- ^ The path of the file being parsed, either the root or an import + -> ProjectConfigToParse + -- ^ The contents of the file to parse + -> IO (ParseResult ProjectConfigSkeleton) +parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (ProjectConfigToParse bs) = (sanityWalkPCS False =<<) <$> liftPR (go []) (readPreprocessFields bs) -- (ParseUtils.readFields bs) + where + go :: [Field Position] -> [Field Position] -> IO (ParseResult ProjectConfigSkeleton) + go acc (x : xs) = case x of + (Field (Name pos name) importLines) | name == "import" -> do + liftPR + ( \importLoc -> do + let importLocPath = importLoc `consProjectConfigPath` source + + -- Once we canonicalize the import path, we can check for cyclical imports + normLocPath <- canonicalizeConfigPath projectDir importLocPath + + debug verbosity $ "\nimport path, normalized\n=======================\n" ++ render (docProjectConfigPath normLocPath) + + if isCyclicConfigPath normLocPath + then pure $ parseFatalFailure pos (render $ cyclicalImportMsg normLocPath) + else do + normSource <- canonicalizeConfigPath projectDir source + let fs = (\z -> CondNode z [normLocPath] mempty) <$> fieldsToConfig normSource (reverse acc) + + importParseResult <- parseProjectSkeleton cacheDir httpTransport verbosity projectDir importLocPath . ProjectConfigToParse =<< fetchImportConfig normLocPath + + -- As PError and PWarning do not store the filepath where they occurred, we need to print them here where we still have this information + let (warnings, result) = runParseResult importParseResult + traverse_ (warn verbosity . showPWarning importLoc) warnings + let res' = case result of + Right cfg -> pure cfg + Left (_, errors) -> do + traverse_ (\(PError errPos str) -> parseFailure errPos str) errors + parseFatalFailure pos $ "Failed to parse import " ++ importLoc + + rest <- go [] xs + pure . fmap mconcat . sequence $ [fs, res', rest] + ) + (parseImport pos importLines) + (Section (Name _pos name) args xs') | name == "if" -> do + subpcs <- go [] xs' + let fs = fmap singletonProjectConfigSkeleton $ fieldsToConfig source (reverse acc) + (elseClauses, rest) <- parseElseClauses xs + let condNode = + (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e]) + <$> parseConditionConfVar args + <*> subpcs + <*> elseClauses + pure . fmap mconcat . sequence $ [fs, condNode, rest] + _ -> go (x : acc) xs + go acc [] = do + normSource <- canonicalizeConfigPath projectDir source + pure . fmap singletonProjectConfigSkeleton . fieldsToConfig normSource $ reverse acc + + parseElseClauses :: [Field Position] -> IO (ParseResult (Maybe ProjectConfigSkeleton), ParseResult ProjectConfigSkeleton) + parseElseClauses x = case x of + (Section (Name _pos name) _args xs' : xs) | name == "else" -> do + subpcs <- go [] xs' + rest <- go [] xs + pure (Just <$> subpcs, rest) + (Section (Name _pos name) args xs' : xs) | name == "elif" -> do + subpcs <- go [] xs' + (elseClauses, rest) <- parseElseClauses xs + let condNode = + (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e]) + <$> parseConditionConfVar args + <*> subpcs + <*> elseClauses + pure (Just <$> condNode, rest) + _ -> (\r -> (pure Nothing, r)) <$> go [] x + + parseImport :: Position -> [FieldLine Position] -> ParseResult FilePath + parseImport pos lines' = runFieldParser pos (P.many P.anyChar) cabalSpec lines' + + -- We want a normalized path for @fieldsToConfig@. This eventually surfaces + -- in solver rejection messages and build messages "this build was affected + -- by the following (project) config files" so we want all paths shown there + -- to be relative to the directory of the project, not relative to the file + -- they were imported from. + fieldsToConfig :: ProjectConfigPath -> [Field Position] -> ParseResult ProjectConfig + fieldsToConfig sourceConfigPath xs = do + let (fs, sectionGroups) = partitionFields xs + sections = concat sectionGroups + config <- parseFieldGrammar cabalSpec fs (projectConfigFieldGrammar sourceConfigPath (knownProgramNames programDb)) + config' <- view stateConfig <$> execStateT (goSections programDb sections) (SectionS config) + return config' + + fetchImportConfig :: ProjectConfigPath -> IO BS.ByteString + fetchImportConfig (ProjectConfigPath (pci :| _)) = do + debug verbosity $ "fetching import: " ++ pci + fetch pci + + fetch :: FilePath -> IO BS.ByteString + fetch pci = case parseURI pci of + Just uri -> do + let fp = cacheDir map (\x -> if isPathSeparator x then '_' else x) (makeValid $ show uri) + createDirectoryIfMissing True cacheDir + _ <- downloadURI httpTransport verbosity uri fp + BS.readFile fp + Nothing -> + BS.readFile $ + if isAbsolute pci then pci else coerce projectDir pci + + modifiesCompiler :: ProjectConfig -> Bool + modifiesCompiler pc = isSet projectConfigHcFlavor || isSet projectConfigHcPath || isSet projectConfigHcPkg + where + isSet f = f (projectConfigShared pc) /= NoFlag + + sanityWalkPCS :: Bool -> ProjectConfigSkeleton -> ParseResult ProjectConfigSkeleton + sanityWalkPCS underConditional t@(CondNode d _c comps) + | underConditional && modifiesCompiler d = parseFatalFailure zeroPos "Cannot set compiler in a conditional clause of a cabal project file" + | otherwise = mapM_ sanityWalkBranch comps >> pure t + + sanityWalkBranch :: CondBranch ConfVar [ProjectConfigPath] ProjectConfig -> ParseResult () + sanityWalkBranch (CondBranch _c t f) = traverse (sanityWalkPCS True) f >> sanityWalkPCS True t >> pure () + + programDb = defaultProgramDb + +knownProgramNames :: ProgramDb -> [String] +knownProgramNames programDb = (programName . fst) <$> knownPrograms programDb + +-- | Monad in which sections are parsed +type SectionParser = StateT SectionS ParseResult + +-- | State of 'SectionParser' +newtype SectionS = SectionS + { _stateConfig :: ProjectConfig + } + +stateConfig :: Lens' SectionS ProjectConfig +stateConfig f (SectionS cfg) = SectionS <$> f cfg +{-# INLINEABLE stateConfig #-} + +goSections :: ProgramDb -> [Section Position] -> SectionParser () +goSections programDb = traverse_ (parseSection programDb) + +parseSection :: ProgramDb -> Section Position -> SectionParser () +parseSection programDb (MkSection (Name pos name) args secFields) + | name == "source-repository-package" = do + verifyNullSubsections + verifyNullSectionArgs + srp <- lift $ parseFieldGrammar cabalSpec fields sourceRepositoryPackageGrammar + stateConfig . L.projectPackagesRepo %= (++ [srp]) + | name == "program-options" = do + verifyNullSubsections + verifyNullSectionArgs + opts <- lift $ parseProgramArgs Warn programDb fields + stateConfig . L.projectConfigLocalPackages %= (\cfg -> cfg{packageConfigProgramArgs = (opts <> packageConfigProgramArgs cfg)}) + | name == "program-locations" = do + verifyNullSubsections + verifyNullSectionArgs + paths <- lift $ parseProgramPaths Warn programDb fields + stateConfig . L.projectConfigLocalPackages %= (\cfg -> cfg{packageConfigProgramPaths = (paths <> packageConfigProgramPaths cfg)}) + | name == "package" = do + verifyNullSubsections + package <- lift $ parsePackageName pos args + case package of + Just AllPackages -> do + packageCfg' <- parsePackageConfig + stateConfig . L.projectConfigAllPackages %= (\packageCfg -> packageCfg' <> packageCfg) + Just (SpecificPackage packageName) -> do + packageCfg <- parsePackageConfig + stateConfig . L.projectConfigSpecificPackage %= (\spcs -> spcs <> MapMappend (Map.singleton packageName packageCfg)) + Nothing -> return () + | otherwise = do + warnInvalidSubsection pos name + where + (fields, sections) = partitionFields secFields + warnInvalidSubsection pos' name' = lift $ parseWarning pos' PWTInvalidSubsection $ "Invalid subsection " ++ show name' + programNames = knownProgramNames programDb + verifyNullSubsections = unless (null sections) (warnInvalidSubsection pos name) + verifyNullSectionArgs = unless (null args) (lift $ parseFailure pos $ "The section '" <> (show name) <> "' takes no arguments") + parsePackageConfig = do + packageCfg <- lift $ parseFieldGrammar cabalSpec fields (packageConfigFieldGrammar programNames) + args' <- lift $ parseProgramArgs Ignore programDb fields + paths <- lift $ parseProgramPaths Ignore programDb fields + return packageCfg{packageConfigProgramPaths = paths, packageConfigProgramArgs = args'} + +data PackageConfigTarget = AllPackages | SpecificPackage PackageName + +parsePackageName :: Position -> [SectionArg Position] -> ParseResult (Maybe PackageConfigTarget) +parsePackageName pos args = case args of + [SecArgName _ secName] -> parseName secName + [SecArgStr _ secName] -> parseName secName + [SecArgOther _ secName] -> parseName secName + _ -> do + parseWarning pos PWTUnknownSection "target package name or * required" + return Nothing + where + parseName secName = case runParsecParser parser "" (fieldLineStreamFromBS secName) of + Left _ -> return Nothing + Right cfgTarget -> return $ pure cfgTarget + parser :: ParsecParser PackageConfigTarget + parser = + P.choice [P.try (P.char '*' >> return AllPackages), SpecificPackage <$> parsec] + +-- | Decide whether to issue Warnings on unknown fields +data WarnUnknownFields = Ignore | Warn + +-- | Parse fields of a program-options stanza. +parseProgramArgs :: WarnUnknownFields -> ProgramDb -> Fields Position -> ParseResult (MapMappend String [String]) +parseProgramArgs warnLevel programDb fields = foldM parseField mempty (Map.toList fields) + where + parseField programArgs (fieldName, fieldLines) = do + case readProgramName "-options" programDb fieldName of + Nothing -> case warnLevel of + Ignore -> return programArgs + Warn -> warnUnknownFields fieldName fieldLines >> return programArgs + Just program -> do + args <- parseProgramArgsField fieldLines + return $ programArgs <> MapMappend (Map.singleton program args) + +-- | Parse fields of a program-locations stanza. +parseProgramPaths :: WarnUnknownFields -> ProgramDb -> Fields Position -> ParseResult (MapLast String FilePath) +parseProgramPaths warnLevel programDb fields = foldM parseField mempty (Map.toList fields) + where + parseField paths (fieldName, fieldLines) = do + case readProgramName "-location" programDb fieldName of + Nothing -> case warnLevel of + Ignore -> return paths + Warn -> warnUnknownFields fieldName fieldLines >> return paths + Just program -> do + case fieldLines of + (MkNamelessField pos lines') : _ -> do + fp <- runFieldParser pos parsecFilePath cabalSpec lines' + return $ paths <> MapLast (Map.singleton program fp) + [] -> return mempty + +-- | Parse all arguments to a single program in program-options stanza. +-- By processing '[NamelessField Position]', we support multiple occurrences of the field, concatenating the arguments. +parseProgramArgsField :: [NamelessField Position] -> ParseResult ([String]) +parseProgramArgsField fieldLines = + concat <$> mapM (\(MkNamelessField pos lines') -> parseProgramArgsFieldLines pos lines') fieldLines + +-- | Parse all fieldLines of a single field occurrence in a program-options stanza. +parseProgramArgsFieldLines :: Position -> [FieldLine Position] -> ParseResult [String] +parseProgramArgsFieldLines pos = runFieldParser pos programArgsFieldParser cabalSpec + +programArgsFieldParser :: CabalParsing m => m [String] +programArgsFieldParser = parseSep (Proxy :: Proxy FSep) parsecToken + +type FieldSuffix = String + +-- | Extract the program name of a field, allow it to have a suffix such as '-options' and check whether the 'ProgramDB' contains it. +readProgramName :: FieldSuffix -> ProgramDb -> FieldName -> Maybe String +readProgramName suffix programDb fieldName = + parseProgramName suffix fieldName >>= ((flip lookupKnownProgram) programDb) >>= pure . programName + +parseProgramName :: FieldSuffix -> FieldName -> Maybe String +parseProgramName suffix fieldName = case runParsecParser parser "" fieldNameStream of + Left _ -> Nothing + Right str -> Just str + where + parser = P.manyTill P.anyChar (P.try ((P.string suffix)) <* P.eof) + fieldNameStream = fieldLineStreamFromBS fieldName + +-- | Issue a 'PWTUnknownField' warning at all occurrences of a field. +warnUnknownFields :: FieldName -> [NamelessField Position] -> ParseResult () +warnUnknownFields fieldName fieldLines = for_ fieldLines (\field -> parseWarning (pos field) PWTUnknownField message) + where + message = "Unknown field: " ++ show fieldName + pos = namelessFieldAnn + +cabalSpec :: CabalSpecVersion +cabalSpec = cabalSpecLatest diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs index 1a2b6ae2fa6..b160f1f4da2 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs @@ -168,6 +168,7 @@ data ProjectConfigBuildOnly = ProjectConfigBuildOnly , projectConfigReportPlanningFailure :: Flag Bool , projectConfigSymlinkBinDir :: Flag FilePath , projectConfigNumJobs :: Flag (Maybe Int) + -- ^ Use 'Just n' for number of jobs, 'Nothing' for number of jobs equal to the number of CPUs and 'NoFlag' if flag is not given. , projectConfigUseSemaphore :: Flag Bool , projectConfigKeepGoing :: Flag Bool , projectConfigOfflineMode :: Flag Bool diff --git a/cabal-install/src/Distribution/Client/Types/AllowNewer.hs b/cabal-install/src/Distribution/Client/Types/AllowNewer.hs index 0a5700174b8..53c55ef08b6 100644 --- a/cabal-install/src/Distribution/Client/Types/AllowNewer.hs +++ b/cabal-install/src/Distribution/Client/Types/AllowNewer.hs @@ -101,6 +101,12 @@ instance Pretty RelaxedDep where instance Parsec RelaxedDep where parsec = P.char '*' *> relaxedDepStarP <|> (parsec >>= relaxedDepPkgidP) +instance Parsec AllowOlder where + parsec = AllowOlder <$> parsec + +instance Parsec AllowNewer where + parsec = AllowNewer <$> parsec + -- continuation after * relaxedDepStarP :: CabalParsing m => m RelaxedDep relaxedDepStarP = diff --git a/cabal-install/src/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs b/cabal-install/src/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs index 042b62d997a..6db210025ee 100644 --- a/cabal-install/src/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs +++ b/cabal-install/src/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs @@ -5,6 +5,8 @@ module Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy ) where import Distribution.Client.Compat.Prelude +import qualified Distribution.Compat.CharParsing as P +import Distribution.Parsec import Prelude () -- | Whether 'v2-build' should write a .ghc.environment file after @@ -19,3 +21,16 @@ data WriteGhcEnvironmentFilesPolicy instance Binary WriteGhcEnvironmentFilesPolicy instance Structured WriteGhcEnvironmentFilesPolicy + +instance Parsec WriteGhcEnvironmentFilesPolicy where + parsec = do + token <- parsecToken + case token of + "always" -> return AlwaysWriteGhcEnvironmentFiles + "never" -> return NeverWriteGhcEnvironmentFiles + "ghc8.4.4+" -> return WriteGhcEnvironmentFilesOnlyForGhc844AndNewer + policy -> + P.unexpected $ + "Cannot parse the GHC environment file write policy '" + <> policy + <> "'" diff --git a/cabal-install/src/Distribution/Client/Utils/Parsec.hs b/cabal-install/src/Distribution/Client/Utils/Parsec.hs index abc9ddd1321..0af52b4e237 100644 --- a/cabal-install/src/Distribution/Client/Utils/Parsec.hs +++ b/cabal-install/src/Distribution/Client/Utils/Parsec.hs @@ -1,16 +1,43 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Distribution.Client.Utils.Parsec ( renderParseError + + -- ** Flag + , alaFlag + , Flag' + + -- ** NubList + , alaNubList + , alaNubList' + , NubList' + + -- ** Newtype wrappers + , NumJobs (..) + , PackageDBNT (..) + , ProjectConstraints (..) + , MaxBackjumps (..) ) where import Distribution.Client.Compat.Prelude +import Distribution.Client.Targets (UserConstraint) +import Distribution.Compat.Newtype +import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) import System.FilePath (normalise) import Prelude () import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 - -import Distribution.Parsec (PError (..), PWarning (..), Position (..), showPos, zeroPos) +import Distribution.Compat.CharParsing +import Distribution.FieldGrammar.Newtypes +import Distribution.Parsec (PError (..), PWarnType (..), PWarning (..), Position (..), parsecToken, parsecWarning, showPos, zeroPos) +import Distribution.Simple.Compiler (PackageDB (..), readPackageDb) +import Distribution.Simple.Flag import Distribution.Simple.Utils (fromUTF8BS) +import Distribution.Utils.NubList (NubList (..)) +import qualified Distribution.Utils.NubList as NubList -- | Render parse error highlighting the part of the input file. renderParseError @@ -103,3 +130,106 @@ advance n z@(Zipper xs ys) | otherwise = case ys of [] -> z (y : ys') -> advance (n - 1) $ Zipper (y : xs) ys' + +-- | Like 'List' for usage with a 'FieldGrammar', but for 'Flag'. +-- This enables to parse type aliases such as 'FilePath' that do not have 'Parsec' instances +-- by using newtype variants such as 'FilePathNT'. +-- For example, if you need to parse a 'Flag FilePath', you can use 'alaFlag' FilePathNT'. +newtype Flag' b a = Flag' {_getFlag :: Flag a} + +-- | 'Flag'' constructor, with additional phantom argument to constrain the resulting type +alaFlag :: (a -> b) -> Flag a -> Flag' b a +alaFlag _ = Flag' + +instance Newtype (Flag a) (Flag' wrapper a) + +instance (Newtype a b, Parsec b) => Parsec (Flag' b a) where + parsec = pack . toFlag . (unpack :: b -> a) <$> parsec + +instance (Newtype a b, Pretty b) => Pretty (Flag' b a) where + pretty = pretty . (pack :: a -> b) . fromFlag . unpack + +-- | Like 'List' for usage with a 'FieldGrammar', but for 'NubList'. +newtype NubList' sep b a = NubList' {_getNubList :: NubList a} + +-- | 'alaNubList' and 'alaNubList'' are simply 'NubList'' constructor, with additional phantom +-- arguments to constrain the resulting type +-- +-- >>> :t alaNubList VCat +-- alaNubList VCat :: NubList a -> NubList' VCat (Identity a) a +-- +-- >>> :t alaNubList' FSep Token +-- alaNubList' FSep Token +-- :: NubList String -> NubList' FSep Token String +-- +-- >>> unpack' (alaNubList' FSep Token) <$> eitherParsec "foo bar foo" +-- Right ["foo","bar"] +alaNubList :: sep -> NubList a -> NubList' sep (Identity a) a +alaNubList _ = NubList' + +-- | More general version of 'alaNubList'. +alaNubList' :: sep -> (a -> b) -> NubList a -> NubList' sep b a +alaNubList' _ _ = NubList' + +instance Newtype (NubList a) (NubList' sep wrapper a) + +instance (Newtype a b, Ord a, Sep sep, Parsec b) => Parsec (NubList' sep b a) where + parsec = pack . NubList.toNubList . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec + +instance (Newtype a b, Sep sep, Pretty b) => Pretty (NubList' sep b a) where + pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . NubList.fromNubList . unpack + +-- | We can't write a Parsec instance for Maybe PackageDB. We need to wrap it in a newtype and define the instance. +newtype PackageDBNT = PackageDBNT {getPackageDBNT :: Maybe PackageDB} + +instance Newtype (Maybe PackageDB) PackageDBNT + +instance Parsec PackageDBNT where + parsec = parsecPackageDB + +parsecPackageDB :: CabalParsing m => m PackageDBNT +parsecPackageDB = PackageDBNT . readPackageDb <$> parsecToken + +-- | We can't write a Parsec instance for Maybe Int. We need to wrap it in a newtype and define the instance. +newtype NumJobs = NumJobs {getNumJobs :: Maybe Int} + +instance Newtype (Maybe Int) NumJobs + +instance Parsec NumJobs where + parsec = parsecNumJobs + +parsecNumJobs :: CabalParsing m => m NumJobs +parsecNumJobs = ncpus <|> numJobs + where + ncpus = string "$ncpus" >> return (NumJobs Nothing) + numJobs = do + num <- integral + if num < (1 :: Int) + then do + parsecWarning PWTOther "The number of jobs should be 1 or more." + return (NumJobs Nothing) + else return (NumJobs $ Just num) + +newtype ProjectConstraints = ProjectConstraints {getProjectConstraints :: (UserConstraint, ConstraintSource)} + +instance Newtype (UserConstraint, ConstraintSource) ProjectConstraints + +instance Parsec ProjectConstraints where + parsec = parsecProjectConstraints + +-- | Parse 'ProjectConstraints'. As the 'CabalParsing' class does not have access to the file we parse, +-- ConstraintSource is first unknown and we set it afterwards +parsecProjectConstraints :: CabalParsing m => m ProjectConstraints +parsecProjectConstraints = do + userConstraint <- parsec + return $ ProjectConstraints (userConstraint, ConstraintSourceUnknown) + +newtype MaxBackjumps = MaxBackjumps {getMaxBackjumps :: Int} + +instance Newtype Int MaxBackjumps + +instance Parsec MaxBackjumps where + parsec = parseMaxBackjumps + +parseMaxBackjumps :: CabalParsing m => m MaxBackjumps +parseMaxBackjumps = MaxBackjumps <$> integral diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs new file mode 100644 index 00000000000..83bf5fe3193 --- /dev/null +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs @@ -0,0 +1,436 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +import qualified Data.ByteString as BS +import Data.Either +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Set as Set +import Distribution.Client.BuildReports.Types (ReportLevel (..)) +import Distribution.Client.Dependency.Types (PreSolver (..)) +import Distribution.Client.DistDirLayout +import Distribution.Client.HttpUtils +import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepoEntry (..), ActiveRepos (..), CombineStrategy (..)) +import Distribution.Client.IndexUtils.IndexState (RepoIndexState (..), headTotalIndexState, insertIndexState) +import Distribution.Client.ProjectConfig +import Distribution.Client.ProjectConfig.Parsec +import Distribution.Client.RebuildMonad (runRebuild) +import Distribution.Client.Targets (readUserConstraint) +import Distribution.Client.Types.AllowNewer (AllowNewer (..), AllowOlder (..), RelaxDepMod (..), RelaxDepScope (..), RelaxDepSubject (..), RelaxDeps (..), RelaxedDep (..)) +import Distribution.Client.Types.RepoName (RepoName (..)) +import Distribution.Client.Types.SourceRepo +import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy (WriteGhcEnvironmentFilesPolicy (..)) +import Distribution.Compiler (CompilerFlavor (..)) +import Distribution.Parsec (simpleParsec) +import Distribution.Simple.Compiler (DebugInfoLevel (..), OptimisationLevel (..), PackageDB (..), ProfDetailLevel (..)) +import Distribution.Simple.Flag +import Distribution.Simple.InstallDirs (toPathTemplate) +import Distribution.Simple.Setup (DumpBuildInfo (..), Flag, HaddockTarget (..), TestShowDetails (..)) +import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) +import Distribution.Solver.Types.ProjectConfigPath (ProjectConfigPath (..)) +import Distribution.Solver.Types.Settings + ( AllowBootLibInstalls (..) + , CountConflicts (..) + , FineGrainedConflicts (..) + , IndependentGoals (..) + , MinimizeConflictSet (..) + , OnlyConstrained (..) + , PreferOldest (..) + , ReorderGoals (..) + , StrongFlags (..) + ) +import Distribution.Types.CondTree (CondTree (..)) +import Distribution.Types.Flag (FlagAssignment (..), FlagName, mkFlagAssignment) +import Distribution.Types.PackageId (PackageIdentifier (..)) +import Distribution.Types.PackageName +import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..)) +import Distribution.Types.SourceRepo (KnownRepoType (..), RepoType (..)) +import Distribution.Types.Version (mkVersion) +import Distribution.Types.VersionRange.Internal (VersionRange (..)) +import Distribution.Utils.NubList +import Distribution.Verbosity +import System.Directory +import System.FilePath + +import Test.Cabal.Prelude hiding (cabal) +import qualified Test.Cabal.Prelude as P + +main = do + cabalTest' "read packages" testPackages + cabalTest' "read optional-packages" testOptionalPackages + cabalTest' "read extra-packages" testExtraPackages + cabalTest' "read source-repository-package" testSourceRepoList + cabalTest' "read project-config-build-only" testProjectConfigBuildOnly + cabalTest' "read project-config-shared" testProjectConfigShared + cabalTest' "set explicit provenance" testProjectConfigProvenance + cabalTest' "read project-config-local-packages" testProjectConfigLocalPackages + cabalTest' "read project-config-all-packages" testProjectConfigAllPackages + cabalTest' "read project-config-specific-packages" testProjectConfigSpecificPackages + cabalTest' "test projectConfigAllPackages concatenation" testAllPackagesConcat + cabalTest' "test projectConfigSpecificPackages concatenation" testSpecificPackagesConcat + cabalTest' "test program-locations concatenation" testProgramLocationsConcat + cabalTest' "test program-options concatenation" testProgramOptionsConcat + +testPackages :: TestM () +testPackages = do + let expected = [".", "packages/packages.cabal"] + -- Note that I currently also run the legacy parser to make sure my expected values + -- do not differ from the non-Parsec implementation, this will be removed in the future + (config, legacy) <- readConfigDefault "packages" + assertConfig expected config legacy (projectPackages . condTreeData) + +testOptionalPackages :: TestM () +testOptionalPackages = do + let expected = [".", "packages/packages.cabal"] + (config, legacy) <- readConfigDefault "optional-packages" + assertConfig expected config legacy (projectPackagesOptional . condTreeData) + +testSourceRepoList :: TestM () +testSourceRepoList = do + let expected = + [ SourceRepositoryPackage + { srpType = KnownRepoType Git + , srpLocation = "https://example.com/Project.git" + , srpTag = Just "1234" + , srpBranch = Nothing + , srpSubdir = [] + , srpCommand = [] + } + , SourceRepositoryPackage + { srpType = KnownRepoType Git + , srpLocation = "https://example.com/example-dir/" + , srpTag = Just "12345" + , srpBranch = Nothing + , srpSubdir = ["subproject"] + , srpCommand = [] + } + ] + (config, legacy) <- readConfigDefault "source-repository-packages" + assertConfig expected config legacy (projectPackagesRepo . condTreeData) + +testExtraPackages :: TestM () +testExtraPackages = do + let expected = + [ PackageVersionConstraint (mkPackageName "a") (OrLaterVersion (mkVersion [0])) + , PackageVersionConstraint (mkPackageName "b") (IntersectVersionRanges (OrLaterVersion (mkVersion [0, 7, 3])) (EarlierVersion (mkVersion [0, 9]))) + ] + (config, legacy) <- readConfigDefault "extra-packages" + assertConfig expected config legacy (projectPackagesNamed . condTreeData) + +testProjectConfigBuildOnly :: TestM () +testProjectConfigBuildOnly = do + let expected = ProjectConfigBuildOnly{..} + (config, legacy) <- readConfigDefault "project-config-build-only" + assertConfig expected config legacy (projectConfigBuildOnly . condTreeData) + where + projectConfigVerbosity = toFlag (toEnum 2) + projectConfigDryRun = mempty -- cli only + projectConfigOnlyDeps = mempty -- cli only + projectConfigOnlyDownload = mempty -- cli only + projectConfigSummaryFile = toNubList [toPathTemplate "summaryFile", toPathTemplate "summaryFile2"] + projectConfigLogFile = toFlag $ toPathTemplate "myLog.log" + projectConfigBuildReports = toFlag $ DetailedReports + projectConfigReportPlanningFailure = toFlag True + projectConfigSymlinkBinDir = toFlag "some-bindir" + projectConfigNumJobs = toFlag $ Just 4 + projectConfigUseSemaphore = toFlag True + projectConfigKeepGoing = toFlag True + projectConfigOfflineMode = toFlag True + projectConfigKeepTempFiles = toFlag True + projectConfigHttpTransport = toFlag "wget" + projectConfigIgnoreExpiry = toFlag True + projectConfigCacheDir = toFlag "some-cache-dir" + projectConfigLogsDir = toFlag "logs-directory" + projectConfigClientInstallFlags = mempty -- cli only + +testProjectConfigShared :: TestM () +testProjectConfigShared = do + let rootFp = "project-config-shared" + testDir <- testDirInfo rootFp "cabal.project" + let + projectConfigConstraints = getProjectConfigConstraints (testDirProjectConfigFp testDir) + expected = ProjectConfigShared{..} + (config, _) <- readConfigDefault rootFp + assertConfig' expected config (projectConfigShared . condTreeData) + where + projectConfigDistDir = toFlag "something" + projectConfigConfigFile = mempty -- cli only + projectConfigProjectDir = toFlag "my-project-dir" + projectConfigProjectFile = toFlag "my-project" + projectConfigIgnoreProject = toFlag False + projectConfigHcFlavor = toFlag GHCJS + projectConfigHcPath = toFlag "/some/path/to/compiler" + projectConfigHcPkg = toFlag "/some/path/to/ghc-pkg" + projectConfigHaddockIndex = toFlag $ toPathTemplate "/path/to/haddock-index" + projectConfigInstallDirs = mempty -- cli only + projectConfigPackageDBs = [Nothing, Just (SpecificPackageDB "foo"), Nothing, Just (SpecificPackageDB "bar"), Just (SpecificPackageDB "baz")] + projectConfigRemoteRepos = mempty -- cli only + projectConfigLocalNoIndexRepos = mempty -- cli only + projectConfigActiveRepos = Flag (ActiveRepos [ActiveRepo (RepoName "hackage.haskell.org") CombineStrategyMerge, ActiveRepo (RepoName "my-repository") CombineStrategyOverride]) + projectConfigIndexState = + let + hackageState = IndexStateTime $ fromJust $ simpleParsec "2020-05-06T22:33:27Z" + indexState' = insertIndexState (RepoName "hackage.haskell.org") hackageState headTotalIndexState + headHackageState = IndexStateTime $ fromJust $ simpleParsec "2020-04-29T04:11:05Z" + indexState'' = insertIndexState (RepoName "head.hackage") headHackageState indexState' + in + toFlag indexState'' + projectConfigStoreDir = toFlag "a/store/dir/path" -- cli only + getProjectConfigConstraints projectFileFp = + let + bar = fromRight (error "error parsing bar") $ readUserConstraint "bar == 2.1" + barFlags = fromRight (error "error parsing bar flags") $ readUserConstraint "bar +foo -baz" + source = ConstraintSourceProjectConfig $ ProjectConfigPath $ "cabal.project" :| [] + in + [(bar, source), (barFlags, source)] + projectConfigPreferences = [PackageVersionConstraint (mkPackageName "foo") (ThisVersion (mkVersion [0, 9])), PackageVersionConstraint (mkPackageName "baz") (LaterVersion (mkVersion [2, 0]))] + projectConfigCabalVersion = Flag (mkVersion [1, 24, 0, 1]) + projectConfigSolver = Flag AlwaysModular + projectConfigAllowOlder = Just (AllowOlder $ RelaxDepsSome [RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "dep")), RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "pkga") (mkVersion [1, 1, 2]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "dep-pkg"))]) + projectConfigAllowNewer = Just (AllowNewer $ RelaxDepsSome [RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "pkgb") (mkVersion [1, 2, 3]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "dep-pkgb")), RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "importantlib"))]) + projectConfigWriteGhcEnvironmentFilesPolicy = Flag AlwaysWriteGhcEnvironmentFiles + projectConfigMaxBackjumps = toFlag 42 + projectConfigReorderGoals = Flag (ReorderGoals True) + projectConfigCountConflicts = Flag (CountConflicts False) + projectConfigFineGrainedConflicts = Flag (FineGrainedConflicts False) + projectConfigMinimizeConflictSet = Flag (MinimizeConflictSet True) + projectConfigStrongFlags = Flag (StrongFlags True) + projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls True) + projectConfigOnlyConstrained = Flag OnlyConstrainedAll + projectConfigPerComponent = Flag True + projectConfigIndependentGoals = Flag (IndependentGoals True) + projectConfigPreferOldest = Flag (PreferOldest True) + projectConfigProgPathExtra = toNubList ["/foo/bar", "/baz/quux"] + projectConfigMultiRepl = toFlag True + +testProjectConfigProvenance :: TestM () +testProjectConfigProvenance = do + let rootFp = "empty" + testDir <- testDirInfo rootFp "cabal.project" + let + expected = Set.singleton (Explicit (ProjectConfigPath $ "cabal.project" :| [])) + (config, legacy) <- readConfigDefault rootFp + assertConfig expected config legacy (projectConfigProvenance . condTreeData) + +testProjectConfigLocalPackages :: TestM () +testProjectConfigLocalPackages = do + let rootFp = "project-config-local-packages" + let expected = PackageConfig{..} + (config, legacy) <- readConfigDefault rootFp + assertConfig expected config legacy (projectConfigLocalPackages . condTreeData) + where + packageConfigProgramPaths = MapLast $ Map.fromList [("ghc", "/tmp/bin/ghc"), ("gcc", "/tmp/bin/gcc")] + packageConfigProgramArgs = MapMappend $ Map.fromList [("ghc", ["-fno-state-hack", "-foo"]), ("gcc", ["-baz", "-quux"])] + packageConfigProgramPathExtra = toNubList ["/tmp/bin/extra", "/usr/local/bin"] + packageConfigFlagAssignment = mkFlagAssignment [("foo", True), ("bar", False)] + packageConfigVanillaLib = Flag False + packageConfigSharedLib = Flag True + packageConfigStaticLib = Flag True + packageConfigDynExe = Flag True + packageConfigFullyStaticExe = Flag True + packageConfigProf = Flag True + packageConfigProfLib = Flag True + packageConfigProfExe = Flag True + packageConfigProfDetail = Flag ProfDetailAllFunctions + packageConfigProfLibDetail = Flag ProfDetailExportedFunctions + packageConfigConfigureArgs = ["-some-arg", "/some/path"] + packageConfigOptimization = Flag MaximumOptimisation + packageConfigProgPrefix = Flag $ toPathTemplate "another/path" + packageConfigProgSuffix = Flag $ toPathTemplate "and/another/path" + packageConfigExtraLibDirs = ["so", "many", "lib/dirs"] + packageConfigExtraLibDirsStatic = ["a/few", "static/lib/dirs"] + packageConfigExtraFrameworkDirs = ["osx/framework", "dirs"] + packageConfigExtraIncludeDirs = ["incredible/amount", "of", "include", "directories"] + packageConfigGHCiLib = Flag False + packageConfigSplitSections = Flag True + packageConfigSplitObjs = Flag True + packageConfigStripExes = Flag False + packageConfigStripLibs = Flag False + packageConfigTests = Flag True + packageConfigBenchmarks = Flag True + packageConfigCoverage = Flag True + packageConfigRelocatable = Flag True + packageConfigDebugInfo = Flag MaximalDebugInfo + packageConfigDumpBuildInfo = Flag DumpBuildInfo + packageConfigRunTests = Flag True + packageConfigDocumentation = Flag True + -- Haddock options + packageConfigHaddockHoogle = Flag True + packageConfigHaddockHtml = Flag False + packageConfigHaddockHtmlLocation = Flag "http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html" + packageConfigHaddockForeignLibs = Flag True + packageConfigHaddockExecutables = Flag True + packageConfigHaddockTestSuites = Flag True + packageConfigHaddockBenchmarks = Flag True + packageConfigHaddockInternal = Flag True + packageConfigHaddockCss = Flag "some/path/to/file.css" + packageConfigHaddockLinkedSource = Flag True + packageConfigHaddockQuickJump = Flag True + packageConfigHaddockHscolourCss = Flag "another/path/to/hscolour.css" + packageConfigHaddockContents = Flag $ toPathTemplate "https://example.com/$pkg/contents" + packageConfigHaddockIndex = Flag $ toPathTemplate "separately-generated/HTML/index" + packageConfigHaddockBaseUrl = Flag "https://example.com/haddock-base-url" + packageConfigHaddockLib = Flag "/haddock/static" + packageConfigHaddockOutputDir = Flag "/haddock/output" + packageConfigHaddockForHackage = Flag ForHackage + packageConfigTestHumanLog = Flag $ toPathTemplate "human-log.log" + packageConfigTestMachineLog = Flag $ toPathTemplate "machine.log" + packageConfigTestShowDetails = Flag Streaming + packageConfigTestKeepTix = Flag True + packageConfigTestWrapper = Flag "/test-wrapper-path/" + packageConfigTestFailWhenNoTestSuites = Flag True + packageConfigTestTestOptions = [toPathTemplate "--some-option", toPathTemplate "42"] + packageConfigBenchmarkOptions = [toPathTemplate "--some-benchmark-option", toPathTemplate "--another-option"] + +testProjectConfigAllPackages :: TestM () +testProjectConfigAllPackages = do + let rootFp = "project-config-all-packages" + (config, legacy) <- readConfigDefault rootFp + assertConfig expected config legacy (projectConfigAllPackages . condTreeData) + where + expected :: PackageConfig + expected = + mempty + { packageConfigProfDetail = Flag ProfDetailAllFunctions + , packageConfigProfLibDetail = Flag ProfDetailExportedFunctions + } + +testProjectConfigSpecificPackages :: TestM () +testProjectConfigSpecificPackages = do + let rootFp = "project-config-specific-packages" + (config, legacy) <- readConfigDefault rootFp + assertConfig expected config legacy (projectConfigSpecificPackage . condTreeData) + where + expected = MapMappend $ Map.fromList [("foo", expectedFoo), ("bar", expectedBar), ("baz", expectedBaz)] + expectedFoo :: PackageConfig + expectedFoo = + mempty + { packageConfigProfDetail = Flag ProfDetailAllFunctions + , packageConfigProfLibDetail = Flag ProfDetailExportedFunctions + , packageConfigVanillaLib = Flag True + } + expectedBar :: PackageConfig + expectedBar = + mempty + { packageConfigProfDetail = Flag ProfDetailTopLate + , packageConfigProfLibDetail = Flag ProfDetailNone + , packageConfigProgPrefix = Flag $ toPathTemplate "prefix/path" + } + expectedBaz :: PackageConfig + expectedBaz = + mempty + { packageConfigSharedLib = Flag True + } + +testAllPackagesConcat :: TestM () +testAllPackagesConcat = do + let rootFp = "all-packages-concat" + (config, legacy) <- readConfigDefault rootFp + assertConfig expected config legacy (projectConfigAllPackages . condTreeData) + where + expected :: PackageConfig + expected = + mempty + { packageConfigSharedLib = Flag True + , packageConfigStaticLib = Flag True + , packageConfigProgramArgs = MapMappend $ Map.fromList [("ghc", ["-fwarn-tabs", "-Wall"])] + } + +testSpecificPackagesConcat :: TestM () +testSpecificPackagesConcat = do + let rootFp = "specific-packages-concat" + (config, legacy) <- readConfigDefault rootFp + assertConfig expected config legacy (projectConfigSpecificPackage . condTreeData) + where + expected = MapMappend $ Map.fromList [("foo", expectedFoo)] + expectedFoo :: PackageConfig + expectedFoo = + mempty + { packageConfigSharedLib = Flag True + , packageConfigStaticLib = Flag True + , packageConfigProgramArgs = MapMappend $ Map.fromList [("ghc", ["-fno-state-hack", "-threaded"])] + } + +testProgramLocationsConcat :: TestM () +testProgramLocationsConcat = do + let rootFp = "program-locations-concat" + (config, legacy) <- readConfigDefault rootFp + assertConfig expected config legacy (projectConfigLocalPackages . condTreeData) + where + expected :: PackageConfig + expected = + mempty + { packageConfigProgramPaths = MapLast $ Map.fromList [("gcc", "/tmp/bin/gcc"), ("ghc", "/tmp/bin/ghc")] + } + +testProgramOptionsConcat :: TestM () +testProgramOptionsConcat = do + let rootFp = "program-options-concat" + (config, legacy) <- readConfigDefault rootFp + assertConfig expected config legacy (projectConfigLocalPackages . condTreeData) + where + expected :: PackageConfig + expected = + mempty + { packageConfigProgramArgs = MapMappend $ Map.fromList [("ghc", ["-threaded", "-Wall", "-fno-state-hack"]), ("gcc", ["-baz", "-foo", "-bar"])] + } + +readConfigDefault :: FilePath -> TestM (ProjectConfigSkeleton, ProjectConfigSkeleton) +readConfigDefault testSubDir = readConfig testSubDir "cabal.project" + +readConfig :: FilePath -> FilePath -> TestM (ProjectConfigSkeleton, ProjectConfigSkeleton) +readConfig testSubDir projectFileName = do + (TestDir testRootFp projectConfigFp distDirLayout) <- testDirInfo testSubDir projectFileName + exists <- liftIO $ doesFileExist projectConfigFp + assertBool ("projectConfig does not exist: " <> projectConfigFp) exists + httpTransport <- liftIO $ configureTransport verbosity [] Nothing + let extensionName = "" + extensionDescription = "" + parsec <- + liftIO $ + runRebuild testRootFp $ + readProjectFileSkeleton verbosity httpTransport distDirLayout extensionName extensionDescription + legacy <- + liftIO $ + runRebuild testRootFp $ + readProjectFileSkeletonLegacy verbosity httpTransport distDirLayout extensionName extensionDescription + return (parsec, legacy) + +data TestDir = TestDir + { testDirTestRootFp :: FilePath + -- ^ Every test has its own root in ./tests/ + , testDirProjectConfigFp :: FilePath + -- ^ Every test has a project config in testDirTestRootFp/cabal.project + , testDirDistDirLayout :: DistDirLayout + } + +testDirInfo :: FilePath -> FilePath -> TestM TestDir +testDirInfo testSubDir projectFileName = do + testEnv <- getTestEnv + testRootFp <- liftIO $ canonicalizePath (testCurrentDir testEnv "tests" testSubDir) + let + projectRoot = ProjectRootExplicit testRootFp projectFileName + distDirLayout = defaultDistDirLayout projectRoot Nothing Nothing + extensionName = "" + projectConfigFp = distProjectFile distDirLayout extensionName + return $ TestDir testRootFp projectConfigFp distDirLayout + where + extensionName = "" + +assertConfig' :: (Eq a, Show a) => a -> ProjectConfigSkeleton -> (ProjectConfigSkeleton -> a) -> TestM () +assertConfig' expected config access = assertEqual "Parsec Config" expected actual + where + actual = access config + +assertConfig :: (Eq a, Show a) => a -> ProjectConfigSkeleton -> ProjectConfigSkeleton -> (ProjectConfigSkeleton -> a) -> TestM () +assertConfig expected config configLegacy access = do + assertEqual "Equal Legacy Config" expected actualLegacy + assertEqual "Equal Parsec Config" expected actual + where + actual = access config + actualLegacy = access configLegacy + +-- | Test Utilities +verbosity :: Verbosity +verbosity = normal -- minBound --normal --verbose --maxBound --minBound diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/all-packages-concat/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/all-packages-concat/cabal.project new file mode 100644 index 00000000000..c6ea2f56eb6 --- /dev/null +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/all-packages-concat/cabal.project @@ -0,0 +1,7 @@ +package * + static: True + ghc-options: -Wall + +package * + shared: True + ghc-options: -fwarn-tabs diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/empty/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/empty/cabal.project new file mode 100644 index 00000000000..e69de29bb2d diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/extra-packages/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/extra-packages/cabal.project new file mode 100644 index 00000000000..13d55f2ef33 --- /dev/null +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/extra-packages/cabal.project @@ -0,0 +1,3 @@ +extra-packages: + a + , b >= 0.7.3 && < 0.9, diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/optional-packages/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/optional-packages/cabal.project new file mode 100644 index 00000000000..37e21016d6a --- /dev/null +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/optional-packages/cabal.project @@ -0,0 +1 @@ +optional-packages: . packages/packages.cabal diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/packages/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/packages/cabal.project new file mode 100644 index 00000000000..6d9d4728a55 --- /dev/null +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/packages/cabal.project @@ -0,0 +1 @@ +packages: . packages/packages.cabal diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/program-locations-concat/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/program-locations-concat/cabal.project new file mode 100644 index 00000000000..95657d95a17 --- /dev/null +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/program-locations-concat/cabal.project @@ -0,0 +1,5 @@ +program-locations + gcc-location: /tmp/bin/gcc + +program-locations + ghc-location: /tmp/bin/ghc diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/program-options-concat/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/program-options-concat/cabal.project new file mode 100644 index 00000000000..d880c442874 --- /dev/null +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/program-options-concat/cabal.project @@ -0,0 +1,7 @@ +program-options + ghc-options: -fno-state-hack + gcc-options: -foo -bar + +program-options + ghc-options: -threaded -Wall + gcc-options: -baz diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-all-packages/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-all-packages/cabal.project new file mode 100644 index 00000000000..2b336cf830c --- /dev/null +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-all-packages/cabal.project @@ -0,0 +1,3 @@ +package * + profiling-detail: all-functions + library-profiling-detail: exported-functions diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-build-only/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-build-only/cabal.project new file mode 100644 index 00000000000..7502a29b796 --- /dev/null +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-build-only/cabal.project @@ -0,0 +1,15 @@ +verbose: 2 +build-summary: summaryFile, summaryFile2 +build-log: myLog.log +remote-build-reporting: detailed +report-planning-failure: True +symlink-bindir: some-bindir +jobs: 4 +semaphore: True +keep-going: True +offline: True +haddock-keep-temp-files: True +http-transport: wget +ignore-expiry: True +remote-repo-cache: some-cache-dir +logs-dir: logs-directory diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-local-packages/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-local-packages/cabal.project new file mode 100644 index 00000000000..b9677ed4a05 --- /dev/null +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-local-packages/cabal.project @@ -0,0 +1,68 @@ +program-options + ghc-options: -fno-state-hack -foo + gcc-options: -baz -quux + +program-locations + ghc-location: /tmp/bin/ghc + gcc-location: /tmp/bin/gcc + +extra-prog-path: /tmp/bin/extra, /usr/local/bin +flags: +foo -bar +library-vanilla: False +shared: True +static: True +executable-dynamic: True +executable-static: True +profiling: True +library-profiling: True +executable-profiling: True +profiling-detail: all-functions +library-profiling-detail: exported-functions +configure-options: -some-arg /some/path +optimization: 2 +program-prefix: another/path +program-suffix: and/another/path +extra-lib-dirs: so, many, lib/dirs +extra-lib-dirs-static: a/few, static/lib/dirs +extra-framework-dirs: osx/framework, dirs +extra-include-dirs: incredible/amount, of, include, directories +library-for-ghci: False +split-sections: True +split-objs: True +executable-stripping: False +library-stripping: False +tests: True +benchmarks: True +coverage: True +relocatable: True +debug-info: 3 +build-info: True +run-tests: True +documentation: True +haddock-hoogle: True +haddock-html: False +haddock-html-location: http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html +haddock-foreign-libraries: True +haddock-executables: True +haddock-tests: True +haddock-benchmarks: True +haddock-internal: True +haddock-css: some/path/to/file.css +haddock-hyperlink-source: True +haddock-quickjump: True +haddock-hscolour-css: another/path/to/hscolour.css +haddock-contents-location: https://example.com/$pkg/contents +haddock-index-location: separately-generated/HTML/index +haddock-base-url: https://example.com/haddock-base-url +haddock-lib: /haddock/static +haddock-output-dir: /haddock/output +haddock-for-hackage: for-hackage + +test-log: human-log.log +test-machine-log: machine.log +test-keep-tix-files: True +test-wrapper: /test-wrapper-path/ +test-fail-when-no-test-suites: True +test-show-details: streaming +test-options: --some-option 42 +benchmark-options: --some-benchmark-option --another-option diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-shared/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-shared/cabal.project new file mode 100644 index 00000000000..90f00f96278 --- /dev/null +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-shared/cabal.project @@ -0,0 +1,39 @@ +builddir: something +project-dir: my-project-dir +project-file: my-project +store-dir: a/store/dir/path +per-component: True +independent-goals: True +ignore-project: False +compiler: ghcjs +with-compiler: /some/path/to/compiler +with-hc-pkg: /some/path/to/ghc-pkg +doc-index-file: /path/to/haddock-index +package-dbs: clear, foo, clear, bar, baz +active-repositories: + , hackage.haskell.org + , my-repository:override +index-state: + , hackage.haskell.org 2020-05-06T22:33:27Z + , head.hackage 2020-04-29T04:11:05Z +constraints: bar == 2.1, + bar +foo -baz +preferences: foo == 0.9, + baz > 2.0 +cabal-lib-version: 1.24.0.1 +solver: modular +allow-older: dep, pkga-1.1.2:dep-pkg +allow-newer: pkgb-1.2.3:dep-pkgb, importantlib +write-ghc-environment-files: always +max-backjumps: 42 +reorder-goals: True +count-conflicts: False +fine-grained-conflicts: False +minimize-conflict-set: True +strong-flags: True +allow-boot-library-installs: True +reject-unconstrained-dependencies: all +prefer-oldest: True +extra-prog-path: /foo/bar, /baz/quux +extra-prog-path-shared-only: /foo/bar, /baz/quux +multi-repl: True diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-specific-packages/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-specific-packages/cabal.project new file mode 100644 index 00000000000..166b5db3d68 --- /dev/null +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-specific-packages/cabal.project @@ -0,0 +1,12 @@ +package foo + profiling-detail: all-functions + library-profiling-detail: exported-functions + library-vanilla: True + +package bar + profiling-detail: late-toplevel + library-profiling-detail: none + program-prefix: prefix/path + +package baz + shared: True diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/source-repository-packages/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/source-repository-packages/cabal.project new file mode 100644 index 00000000000..1ab7d417b54 --- /dev/null +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/source-repository-packages/cabal.project @@ -0,0 +1,10 @@ +source-repository-package + type: git + location: https://example.com/Project.git + tag: 1234 + +source-repository-package + type: git + location: https://example.com/example-dir/ + tag: 12345 + subdir: subproject diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/specific-packages-concat/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/specific-packages-concat/cabal.project new file mode 100644 index 00000000000..94766d451fa --- /dev/null +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/specific-packages-concat/cabal.project @@ -0,0 +1,7 @@ +package foo + static: True + ghc-options: -fno-state-hack + +package foo + shared: True + ghc-options: -threaded diff --git a/cabal-testsuite/PackageTests/Regression/T5213/cabal.out b/cabal-testsuite/PackageTests/Regression/T5213/cabal.out index 799c2005c0b..b6be4708e0d 100644 --- a/cabal-testsuite/PackageTests/Regression/T5213/cabal.out +++ b/cabal-testsuite/PackageTests/Regression/T5213/cabal.out @@ -1,6 +1,5 @@ # cabal new-test -Configuration is affected by the following files: -- cabal.project +Warning: /cabal.project:4:3: The field "library-coverage" is deprecated in the Cabal specification version 1.22. Please use 'coverage' field instead. Resolving dependencies... Build profile: -w ghc- -O1 In order, the following will be built: diff --git a/cabal-testsuite/PackageTests/Regression/T5213/cabal.project b/cabal-testsuite/PackageTests/Regression/T5213/cabal.project index e1c33e00303..45f18c1f5cb 100644 --- a/cabal-testsuite/PackageTests/Regression/T5213/cabal.project +++ b/cabal-testsuite/PackageTests/Regression/T5213/cabal.project @@ -1,4 +1,4 @@ packages: . package cabal-gh5213 - library-coverage: true + library-coverage: True diff --git a/cabal-testsuite/cabal-testsuite.cabal b/cabal-testsuite/cabal-testsuite.cabal index 4e31b87d254..d22b646b227 100644 --- a/cabal-testsuite/cabal-testsuite.cabal +++ b/cabal-testsuite/cabal-testsuite.cabal @@ -131,6 +131,8 @@ executable test-runtime-deps build-depends: , Cabal , Cabal-syntax + , cabal-install + , cabal-install-solver , Cabal-hooks , base , bytestring diff --git a/doc/cabal-project-description-file.rst b/doc/cabal-project-description-file.rst index 929ec642f6f..6c8bde25cb4 100644 --- a/doc/cabal-project-description-file.rst +++ b/doc/cabal-project-description-file.rst @@ -1814,7 +1814,7 @@ Advanced global configuration options ``--build-summary=TEMPLATE``. Undocumented fields: ``root-cmd``, ``symlink-bindir``, ``build-log``, -``remote-build-reporting``, ``report-planned-failure``, ``offline``. +``remote-build-reporting``, ``report-planning-failure``, ``offline``. Advanced solver options ^^^^^^^^^^^^^^^^^^^^^^^ From e3373be347f6f74095e6a9bf183eb9bc4c1546c2 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 31 May 2024 14:07:41 +0200 Subject: [PATCH 02/41] Replace haddock-lib with haddock-resources-dir --- .../src/Distribution/Client/ProjectConfig/FieldGrammar.hs | 2 +- cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs | 6 +++--- .../src/Distribution/Client/ProjectConfig/Parsec.hs | 2 +- .../PackageTests/ProjectConfig/Parsec/cabal.test.hs | 2 +- .../tests/project-config-local-packages/cabal.project | 2 +- 5 files changed, 7 insertions(+), 7 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs index 11f40abe85d..ceec2a0452f 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs @@ -158,7 +158,7 @@ packageConfigFieldGrammar knownPrograms = <*> optionalFieldDef "haddock-contents-location" L.packageConfigHaddockContents mempty <*> optionalFieldDef "haddock-index-location" L.packageConfigHaddockIndex mempty <*> optionalFieldDefAla "haddock-base-url" (alaFlag Token) L.packageConfigHaddockBaseUrl mempty - <*> optionalFieldDefAla "haddock-lib" (alaFlag Token) L.packageConfigHaddockLib mempty + <*> optionalFieldDefAla "haddock-resources-dir" (alaFlag Token) L.packageConfigHaddockResourcesDir mempty <*> optionalFieldDefAla "haddock-output-dir" (alaFlag FilePathNT) L.packageConfigHaddockOutputDir mempty <*> optionalFieldDef "haddock-for-hackage" L.packageConfigHaddockForHackage mempty <*> optionalFieldDef "test-log" L.packageConfigTestHumanLog mempty diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs index b008913d7e3..b43eed7d163 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs @@ -477,9 +477,9 @@ packageConfigHaddockBaseUrl :: Lens' PackageConfig (Flag String) packageConfigHaddockBaseUrl f s = fmap (\x -> s{T.packageConfigHaddockBaseUrl = x}) (f (T.packageConfigHaddockBaseUrl s)) {-# INLINEABLE packageConfigHaddockBaseUrl #-} -packageConfigHaddockLib :: Lens' PackageConfig (Flag String) -packageConfigHaddockLib f s = fmap (\x -> s{T.packageConfigHaddockLib = x}) (f (T.packageConfigHaddockLib s)) -{-# INLINEABLE packageConfigHaddockLib #-} +packageConfigHaddockResourcesDir :: Lens' PackageConfig (Flag String) +packageConfigHaddockResourcesDir f s = fmap (\x -> s{T.packageConfigHaddockResourcesDir = x}) (f (T.packageConfigHaddockResourcesDir s)) +{-# INLINEABLE packageConfigHaddockResourcesDir #-} packageConfigHaddockOutputDir :: Lens' PackageConfig (Flag FilePath) packageConfigHaddockOutputDir f s = fmap (\x -> s{T.packageConfigHaddockOutputDir = x}) (f (T.packageConfigHaddockOutputDir s)) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index 3907f958af0..8c3b18d0aa0 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -216,7 +216,7 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project | otherwise = mapM_ sanityWalkBranch comps >> pure t sanityWalkBranch :: CondBranch ConfVar [ProjectConfigPath] ProjectConfig -> ParseResult () - sanityWalkBranch (CondBranch _c t f) = traverse (sanityWalkPCS True) f >> sanityWalkPCS True t >> pure () + sanityWalkBranch (CondBranch _c t f) = traverse_ (sanityWalkPCS True) f >> sanityWalkPCS True t >> pure () programDb = defaultProgramDb diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs index 83bf5fe3193..385b8ef51f1 100644 --- a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs @@ -271,7 +271,7 @@ testProjectConfigLocalPackages = do packageConfigHaddockContents = Flag $ toPathTemplate "https://example.com/$pkg/contents" packageConfigHaddockIndex = Flag $ toPathTemplate "separately-generated/HTML/index" packageConfigHaddockBaseUrl = Flag "https://example.com/haddock-base-url" - packageConfigHaddockLib = Flag "/haddock/static" + packageConfigHaddockResourcesDir = Flag "/haddock/static" packageConfigHaddockOutputDir = Flag "/haddock/output" packageConfigHaddockForHackage = Flag ForHackage packageConfigTestHumanLog = Flag $ toPathTemplate "human-log.log" diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-local-packages/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-local-packages/cabal.project index b9677ed4a05..b173b3dc45e 100644 --- a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-local-packages/cabal.project +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-local-packages/cabal.project @@ -54,7 +54,7 @@ haddock-hscolour-css: another/path/to/hscolour.css haddock-contents-location: https://example.com/$pkg/contents haddock-index-location: separately-generated/HTML/index haddock-base-url: https://example.com/haddock-base-url -haddock-lib: /haddock/static +haddock-resources-dir: /haddock/static haddock-output-dir: /haddock/output haddock-for-hackage: for-hackage From ebd6c9ff3a1e64b3f53c719731de88cc20b8a3ca Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 31 May 2024 14:09:50 +0200 Subject: [PATCH 03/41] Add parsing of ClientInstallFlags --- .../Client/CmdInstall/ClientInstallFlags.hs | 47 ++++++++++++++++++- .../Client/ProjectConfig/FieldGrammar.hs | 3 +- .../Distribution/Client/ProjectConfig/Lens.hs | 5 ++ .../ProjectConfig/Parsec/cabal.test.hs | 12 ++++- .../project-config-build-only/cabal.project | 7 +++ 5 files changed, 71 insertions(+), 3 deletions(-) diff --git a/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs b/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs index b35cd06fe7a..de210a2f3d9 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs @@ -1,13 +1,17 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} module Distribution.Client.CmdInstall.ClientInstallFlags ( InstallMethod (..) , ClientInstallFlags (..) , defaultClientInstallFlags , clientInstallOptions + , clientInstallFlagsGrammar ) where import Distribution.Client.Compat.Prelude +import Distribution.Compat.Lens (Lens') +import Distribution.FieldGrammar import Prelude () import Distribution.ReadE @@ -33,6 +37,7 @@ import Distribution.Client.Types.InstallMethod import Distribution.Client.Types.OverwritePolicy ( OverwritePolicy (..) ) +import Distribution.Client.Utils.Parsec import qualified Distribution.Compat.CharParsing as P @@ -71,7 +76,7 @@ clientInstallOptions _ = [] ["lib"] ( "Install libraries rather than executables from the target package " - <> "(provisional, see https://github.com/haskell/cabal/issues/6481 for more information)." + <> "(provisional, see https://github.com/haskell/cabal/issues\/6481 for more information)." ) cinstInstallLibs (\v flags -> flags{cinstInstallLibs = v}) @@ -112,6 +117,26 @@ clientInstallOptions _ = $ reqArg "DIR" (succeedReadE Flag) flagToList ] +clientInstallFlagsGrammar + :: ( FieldGrammar c g + , Applicative (g ClientInstallFlags) + , c (Identity (Flag Bool)) + , c ((Flag' FilePathNT FilePath)) + , c (Identity (Flag OverwritePolicy)) + , c (Identity (Flag InstallMethod)) + ) + => g ClientInstallFlags ClientInstallFlags +clientInstallFlagsGrammar = + ClientInstallFlags + <$> optionalFieldDef "lib" cinstInstallLibsLens mempty + <*> ( optionalFieldDefAla "package-env" (alaFlag FilePathNT) cinstEnvironmentPathLens mempty + <* optionalFieldDefAla "env" (alaFlag FilePathNT) cinstEnvironmentPathLens mempty + ) + <*> optionalFieldDef "overwrite-policy" cinstOverwritePolicyLens mempty + <*> optionalFieldDef "install-method" cinstInstallMethodLens mempty + <*> optionalFieldDefAla "installdir" (alaFlag FilePathNT) cinstInstalldirLens mempty +{-# SPECIALIZE clientInstallFlagsGrammar :: ParsecFieldGrammar' ClientInstallFlags #-} + parsecInstallMethod :: CabalParsing m => m InstallMethod parsecInstallMethod = do name <- P.munch1 isAlpha @@ -119,3 +144,23 @@ parsecInstallMethod = do "copy" -> pure InstallMethodCopy "symlink" -> pure InstallMethodSymlink _ -> P.unexpected $ "InstallMethod: " ++ name + +cinstInstallLibsLens :: Lens' ClientInstallFlags (Flag Bool) +cinstInstallLibsLens f c = fmap (\x -> c{cinstInstallLibs = x}) (f (cinstInstallLibs c)) +{-# INLINEABLE cinstInstallLibsLens #-} + +cinstEnvironmentPathLens :: Lens' ClientInstallFlags (Flag FilePath) +cinstEnvironmentPathLens f c = fmap (\x -> c{cinstEnvironmentPath = x}) (f (cinstEnvironmentPath c)) +{-# INLINEABLE cinstEnvironmentPathLens #-} + +cinstOverwritePolicyLens :: Lens' ClientInstallFlags (Flag OverwritePolicy) +cinstOverwritePolicyLens f c = fmap (\x -> c{cinstOverwritePolicy = x}) (f (cinstOverwritePolicy c)) +{-# INLINEABLE cinstOverwritePolicyLens #-} + +cinstInstallMethodLens :: Lens' ClientInstallFlags (Flag InstallMethod) +cinstInstallMethodLens f c = fmap (\x -> c{cinstInstallMethod = x}) (f (cinstInstallMethod c)) +{-# INLINEABLE cinstInstallMethodLens #-} + +cinstInstalldirLens :: Lens' ClientInstallFlags (Flag FilePath) +cinstInstalldirLens f c = fmap (\x -> c{cinstInstalldir = x}) (f (cinstInstalldir c)) +{-# INLINEABLE cinstInstalldirLens #-} diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs index ceec2a0452f..729a41e43f6 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs @@ -9,6 +9,7 @@ module Distribution.Client.ProjectConfig.FieldGrammar import qualified Data.ByteString.Char8 as BS import qualified Data.Set as Set import Distribution.CabalSpecVersion (CabalSpecVersion (..)) +import Distribution.Client.CmdInstall.ClientInstallFlags (clientInstallFlagsGrammar) import qualified Distribution.Client.ProjectConfig.Lens as L import Distribution.Client.ProjectConfig.Types (PackageConfig (..), ProjectConfig (..), ProjectConfigBuildOnly (..), ProjectConfigProvenance (..), ProjectConfigShared (..)) import Distribution.Client.Utils.Parsec @@ -62,7 +63,7 @@ projectConfigBuildOnlyFieldGrammar = <*> optionalFieldDef "ignore-expiry" L.projectConfigIgnoreExpiry mempty <*> optionalFieldDefAla "remote-repo-cache" (alaFlag FilePathNT) L.projectConfigCacheDir mempty <*> optionalFieldDefAla "logs-dir" (alaFlag FilePathNT) L.projectConfigLogsDir mempty - <*> pure mempty -- cli flag: projectConfigClientInstallFlags + <*> blurFieldGrammar L.projectConfigClientInstallFlags clientInstallFlagsGrammar projectConfigSharedFieldGrammar :: ProjectConfigPath -> ParsecFieldGrammar' ProjectConfigShared projectConfigSharedFieldGrammar source = diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs index b43eed7d163..4edfd3dc677 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs @@ -1,6 +1,7 @@ module Distribution.Client.ProjectConfig.Lens where import Distribution.Client.BuildReports.Types (ReportLevel (..)) +import Distribution.Client.CmdInstall.ClientInstallFlags (ClientInstallFlags (..)) import Distribution.Client.Dependency.Types (PreSolver (..)) import Distribution.Client.IndexUtils.ActiveRepos ( ActiveRepos @@ -157,6 +158,10 @@ projectConfigLogsDir :: Lens' ProjectConfigBuildOnly (Flag FilePath) projectConfigLogsDir f s = fmap (\x -> s{T.projectConfigLogsDir = x}) (f (T.projectConfigLogsDir s)) {-# INLINEABLE projectConfigLogsDir #-} +projectConfigClientInstallFlags :: Lens' ProjectConfigBuildOnly (ClientInstallFlags) +projectConfigClientInstallFlags f s = fmap (\x -> s{T.projectConfigClientInstallFlags = x}) (f (T.projectConfigClientInstallFlags s)) +{-# INLINEABLE projectConfigClientInstallFlags #-} + projectConfigDistDir :: Lens' ProjectConfigShared (Flag FilePath) projectConfigDistDir f s = fmap (\x -> s{T.projectConfigDistDir = x}) (f (T.projectConfigDistDir s)) {-# INLINEABLE projectConfigDistDir #-} diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs index 385b8ef51f1..cb5bf5d7acd 100644 --- a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs @@ -8,6 +8,7 @@ import qualified Data.Map as Map import Data.Maybe import qualified Data.Set as Set import Distribution.Client.BuildReports.Types (ReportLevel (..)) +import Distribution.Client.CmdInstall.ClientInstallFlags (ClientInstallFlags (..)) import Distribution.Client.Dependency.Types (PreSolver (..)) import Distribution.Client.DistDirLayout import Distribution.Client.HttpUtils @@ -18,6 +19,8 @@ import Distribution.Client.ProjectConfig.Parsec import Distribution.Client.RebuildMonad (runRebuild) import Distribution.Client.Targets (readUserConstraint) import Distribution.Client.Types.AllowNewer (AllowNewer (..), AllowOlder (..), RelaxDepMod (..), RelaxDepScope (..), RelaxDepSubject (..), RelaxDeps (..), RelaxedDep (..)) +import Distribution.Client.Types.InstallMethod (InstallMethod (..)) +import Distribution.Client.Types.OverwritePolicy (OverwritePolicy (..)) import Distribution.Client.Types.RepoName (RepoName (..)) import Distribution.Client.Types.SourceRepo import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy (WriteGhcEnvironmentFilesPolicy (..)) @@ -142,7 +145,14 @@ testProjectConfigBuildOnly = do projectConfigIgnoreExpiry = toFlag True projectConfigCacheDir = toFlag "some-cache-dir" projectConfigLogsDir = toFlag "logs-directory" - projectConfigClientInstallFlags = mempty -- cli only + projectConfigClientInstallFlags = + ClientInstallFlags + { cinstInstallLibs = Flag True + , cinstEnvironmentPath = Flag "path/to/env" + , cinstOverwritePolicy = Flag AlwaysOverwrite + , cinstInstallMethod = Flag InstallMethodSymlink + , cinstInstalldir = Flag "path/to/installdir" + } testProjectConfigShared :: TestM () testProjectConfigShared = do diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-build-only/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-build-only/cabal.project index 7502a29b796..eac06d8aadd 100644 --- a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-build-only/cabal.project +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-build-only/cabal.project @@ -13,3 +13,10 @@ http-transport: wget ignore-expiry: True remote-repo-cache: some-cache-dir logs-dir: logs-directory + +-- clientInstallFlags +lib: True +package-env: path/to/env +overwrite-policy: always +install-method: symlink +installdir: path/to/installdir From e5cbba4fa9b0fdecc38de63028f4d96b4ec59aa5 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 31 May 2024 15:40:36 +0200 Subject: [PATCH 04/41] Add parsing of InstallDirs --- Cabal/src/Distribution/Simple/InstallDirs.hs | 83 +++++++++++++++++++ .../Client/ProjectConfig/FieldGrammar.hs | 3 +- .../Distribution/Client/ProjectConfig/Lens.hs | 7 +- .../ProjectConfig/Parsec/cabal.test.hs | 22 ++++- .../tests/project-config-shared/cabal.project | 15 ++++ 5 files changed, 126 insertions(+), 4 deletions(-) diff --git a/Cabal/src/Distribution/Simple/InstallDirs.hs b/Cabal/src/Distribution/Simple/InstallDirs.hs index c24bffc87ae..c264e755c50 100644 --- a/Cabal/src/Distribution/Simple/InstallDirs.hs +++ b/Cabal/src/Distribution/Simple/InstallDirs.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- @@ -44,6 +45,7 @@ module Distribution.Simple.InstallDirs , compilerTemplateEnv , packageTemplateEnv , abiTemplateEnv + , installDirsGrammar , installDirsTemplateEnv ) where @@ -51,10 +53,13 @@ import Distribution.Compat.Prelude import Prelude () import Distribution.Compat.Environment (lookupEnv) +import Distribution.Compat.Lens (Lens') import Distribution.Compiler +import Distribution.FieldGrammar import Distribution.Package import Distribution.Parsec import Distribution.Pretty +import Distribution.Simple.Flag import Distribution.Simple.InstallDirs.Internal import Distribution.System @@ -559,3 +564,81 @@ foreign import CALLCONV unsafe "shlobj.h SHGetFolderPathW" -> Prelude.IO CInt #endif {- FOURMOLU_ENABLE -} + +-- --------------------------------------------------------------------------- +-- FieldGrammar + +installDirsGrammar :: ParsecFieldGrammar' (InstallDirs (Flag PathTemplate)) +installDirsGrammar = + InstallDirs + <$> optionalFieldDef "prefix" installDirsPrefixLens mempty + <*> optionalFieldDef "bindir" installDirsBindirLens mempty + <*> optionalFieldDef "libdir" installDirsLibdirLens mempty + <*> optionalFieldDef "libsubdir" installDirsLibsubdirLens mempty + <*> optionalFieldDef "dynlibdir" installDirsDynlibdirLens mempty + <*> (pure NoFlag) -- flibdir + <*> optionalFieldDef "libexecdir" installDirsLibexecdirLens mempty + <*> optionalFieldDef "libexecsubdir" installDirsLibexecsubdirLens mempty + <*> (pure NoFlag) -- includedir + <*> optionalFieldDef "datadir" installDirsDatadirLens mempty + <*> optionalFieldDef "datasubdir" installDirsDatasubdirLens mempty + <*> optionalFieldDef "docdir" installDirsDocdirLens mempty + <*> (pure NoFlag) -- mandir + <*> optionalFieldDef "htmldir" installDirsHtmldirLens mempty + <*> optionalFieldDef "haddockdir" installDirsHaddockdirLens mempty + <*> optionalFieldDef "sysconfdir" installDirsSysconfdirLens mempty + +-- --------------------------------------------------------------------------- +-- Lenses + +installDirsPrefixLens :: Lens' (InstallDirs a) a +installDirsPrefixLens f c = fmap (\x -> c{prefix = x}) (f (prefix c)) +{-# INLINEABLE installDirsPrefixLens #-} + +installDirsBindirLens :: Lens' (InstallDirs a) a +installDirsBindirLens f c = fmap (\x -> c{bindir = x}) (f (bindir c)) +{-# INLINEABLE installDirsBindirLens #-} + +installDirsLibdirLens :: Lens' (InstallDirs a) a +installDirsLibdirLens f c = fmap (\x -> c{libdir = x}) (f (libdir c)) +{-# INLINEABLE installDirsLibdirLens #-} + +installDirsLibsubdirLens :: Lens' (InstallDirs a) a +installDirsLibsubdirLens f c = fmap (\x -> c{libsubdir = x}) (f (libsubdir c)) +{-# INLINEABLE installDirsLibsubdirLens #-} + +installDirsDynlibdirLens :: Lens' (InstallDirs a) a +installDirsDynlibdirLens f c = fmap (\x -> c{dynlibdir = x}) (f (dynlibdir c)) +{-# INLINEABLE installDirsDynlibdirLens #-} + +installDirsLibexecdirLens :: Lens' (InstallDirs a) a +installDirsLibexecdirLens f c = fmap (\x -> c{libexecdir = x}) (f (libexecdir c)) +{-# INLINEABLE installDirsLibexecdirLens #-} + +installDirsLibexecsubdirLens :: Lens' (InstallDirs a) a +installDirsLibexecsubdirLens f c = fmap (\x -> c{libexecsubdir = x}) (f (libexecsubdir c)) +{-# INLINEABLE installDirsLibexecsubdirLens #-} + +installDirsDatadirLens :: Lens' (InstallDirs a) a +installDirsDatadirLens f c = fmap (\x -> c{datadir = x}) (f (datadir c)) +{-# INLINEABLE installDirsDatadirLens #-} + +installDirsDatasubdirLens :: Lens' (InstallDirs a) a +installDirsDatasubdirLens f c = fmap (\x -> c{datasubdir = x}) (f (datasubdir c)) +{-# INLINEABLE installDirsDatasubdirLens #-} + +installDirsDocdirLens :: Lens' (InstallDirs a) a +installDirsDocdirLens f c = fmap (\x -> c{docdir = x}) (f (docdir c)) +{-# INLINEABLE installDirsDocdirLens #-} + +installDirsHtmldirLens :: Lens' (InstallDirs a) a +installDirsHtmldirLens f c = fmap (\x -> c{htmldir = x}) (f (htmldir c)) +{-# INLINEABLE installDirsHtmldirLens #-} + +installDirsHaddockdirLens :: Lens' (InstallDirs a) a +installDirsHaddockdirLens f c = fmap (\x -> c{haddockdir = x}) (f (haddockdir c)) +{-# INLINEABLE installDirsHaddockdirLens #-} + +installDirsSysconfdirLens :: Lens' (InstallDirs a) a +installDirsSysconfdirLens f c = fmap (\x -> c{sysconfdir = x}) (f (sysconfdir c)) +{-# INLINEABLE installDirsSysconfdirLens #-} diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs index 729a41e43f6..040eadac8c1 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs @@ -16,6 +16,7 @@ import Distribution.Client.Utils.Parsec import Distribution.Compat.Prelude import Distribution.FieldGrammar import Distribution.Simple.Flag +import Distribution.Simple.InstallDirs import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) import Distribution.Solver.Types.ProjectConfigPath import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..)) @@ -77,7 +78,7 @@ projectConfigSharedFieldGrammar source = <*> optionalFieldDefAla "with-compiler" (alaFlag FilePathNT) L.projectConfigHcPath mempty <*> optionalFieldDefAla "with-hc-pkg" (alaFlag FilePathNT) L.projectConfigHcPkg mempty <*> optionalFieldDef "doc-index-file" L.projectConfigHaddockIndex mempty - <*> pure mempty -- cli flag: projectConfigInstallDirs + <*> blurFieldGrammar L.projectConfigInstallDirs installDirsGrammar <*> monoidalFieldAla "package-dbs" (alaList' CommaFSep PackageDBNT) L.projectConfigPackageDBs <*> pure mempty -- cli flag: projectConfigRemoteRepos <*> pure mempty -- cli flag: projectConfigLocalNoIndexRepos diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs index 4edfd3dc677..65fd44b9da9 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs @@ -29,7 +29,8 @@ import Distribution.Simple.Compiler , ProfDetailLevel ) import Distribution.Simple.InstallDirs - ( PathTemplate + ( InstallDirs + , PathTemplate ) import Distribution.Simple.Setup ( DumpBuildInfo (..) @@ -206,6 +207,10 @@ projectConfigHaddockIndex :: Lens' ProjectConfigShared (Flag PathTemplate) projectConfigHaddockIndex f s = fmap (\x -> s{T.projectConfigHaddockIndex = x}) (f (T.projectConfigHaddockIndex s)) {-# INLINEABLE projectConfigHaddockIndex #-} +projectConfigInstallDirs :: Lens' ProjectConfigShared (InstallDirs (Flag PathTemplate)) +projectConfigInstallDirs f s = fmap (\x -> s{T.projectConfigInstallDirs = x}) (f (T.projectConfigInstallDirs s)) +{-# INLINEABLE projectConfigInstallDirs #-} + projectConfigPackageDBs :: Lens' ProjectConfigShared [Maybe PackageDB] projectConfigPackageDBs f s = fmap (\x -> s{T.projectConfigPackageDBs = x}) (f (T.projectConfigPackageDBs s)) {-# INLINEABLE projectConfigPackageDBs #-} diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs index cb5bf5d7acd..7048297ee01 100644 --- a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs @@ -28,7 +28,7 @@ import Distribution.Compiler (CompilerFlavor (..)) import Distribution.Parsec (simpleParsec) import Distribution.Simple.Compiler (DebugInfoLevel (..), OptimisationLevel (..), PackageDB (..), ProfDetailLevel (..)) import Distribution.Simple.Flag -import Distribution.Simple.InstallDirs (toPathTemplate) +import Distribution.Simple.InstallDirs (InstallDirs (..), toPathTemplate) import Distribution.Simple.Setup (DumpBuildInfo (..), Flag, HaddockTarget (..), TestShowDetails (..)) import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) import Distribution.Solver.Types.ProjectConfigPath (ProjectConfigPath (..)) @@ -173,7 +173,25 @@ testProjectConfigShared = do projectConfigHcPath = toFlag "/some/path/to/compiler" projectConfigHcPkg = toFlag "/some/path/to/ghc-pkg" projectConfigHaddockIndex = toFlag $ toPathTemplate "/path/to/haddock-index" - projectConfigInstallDirs = mempty -- cli only + projectConfigInstallDirs = + InstallDirs + { prefix = Flag $ toPathTemplate "my/prefix-path" + , bindir = Flag $ toPathTemplate "bin/dir/" + , libdir = Flag $ toPathTemplate "lib/dir/path" + , libsubdir = Flag $ toPathTemplate "/lib/sub/dir" + , dynlibdir = Flag $ toPathTemplate "dyn/lib/dir/path" + , flibdir = mempty + , libexecdir = Flag $ toPathTemplate "lib/exec/dir/" + , libexecsubdir = Flag $ toPathTemplate "libexec/subdir" + , includedir = mempty + , datadir = Flag $ toPathTemplate "path/to/datadir/" + , datasubdir = Flag $ toPathTemplate "a/datadir/subdir" + , docdir = Flag $ toPathTemplate "path/to/docs" + , mandir = mempty + , htmldir = Flag $ toPathTemplate "dir/html/" + , haddockdir = Flag $ toPathTemplate "haddock/dir" + , sysconfdir = Flag $ toPathTemplate "sys/conf/dir" + } projectConfigPackageDBs = [Nothing, Just (SpecificPackageDB "foo"), Nothing, Just (SpecificPackageDB "bar"), Just (SpecificPackageDB "baz")] projectConfigRemoteRepos = mempty -- cli only projectConfigLocalNoIndexRepos = mempty -- cli only diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-shared/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-shared/cabal.project index 90f00f96278..82eb52a1cbb 100644 --- a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-shared/cabal.project +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-shared/cabal.project @@ -37,3 +37,18 @@ prefer-oldest: True extra-prog-path: /foo/bar, /baz/quux extra-prog-path-shared-only: /foo/bar, /baz/quux multi-repl: True + +-- InstallDirs +prefix: my/prefix-path +bindir: bin/dir/ +libdir: lib/dir/path +libsubdir: /lib/sub/dir +dynlibdir: dyn/lib/dir/path +libexecdir: lib/exec/dir/ +libexecsubdir: libexec/subdir +datadir: path/to/datadir/ +datasubdir: a/datadir/subdir +docdir: path/to/docs +htmldir: dir/html/ +haddockdir: haddock/dir +sysconfdir: sys/conf/dir From 24440c9f5b690924a9394cedff2691076718642f Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 31 May 2024 16:14:56 +0200 Subject: [PATCH 05/41] Add missing constraintKinds --- .../src/Distribution/Client/CmdInstall/ClientInstallFlags.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs b/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs index de210a2f3d9..7c26b8f02a9 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} From 2ed99c1dfaacb54554f634190d0694b3421383f4 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 14 Jun 2024 13:40:32 +0200 Subject: [PATCH 06/41] Update docs and remove comment --- Cabal-syntax/src/Distribution/Fields/ParseResult.hs | 1 + cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/Cabal-syntax/src/Distribution/Fields/ParseResult.hs b/Cabal-syntax/src/Distribution/Fields/ParseResult.hs index 8a23604771f..c08611f8424 100644 --- a/Cabal-syntax/src/Distribution/Fields/ParseResult.hs +++ b/Cabal-syntax/src/Distribution/Fields/ParseResult.hs @@ -63,6 +63,7 @@ runParseResult pr = unPR pr emptyPRState failure success -- If there are any errors, don't return the result success (PRState warns (err : errs) v) _ = (warns, Left (v, err :| errs)) +-- | Chain parsing operations that involve 'IO' actions. liftPR :: (a -> IO (ParseResult b)) -> ParseResult a -> IO (ParseResult b) liftPR f pr = unPR pr emptyPRState failure success where diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index 8c3b18d0aa0..b05bf12069c 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -106,7 +106,7 @@ parseProjectSkeleton -> ProjectConfigToParse -- ^ The contents of the file to parse -> IO (ParseResult ProjectConfigSkeleton) -parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (ProjectConfigToParse bs) = (sanityWalkPCS False =<<) <$> liftPR (go []) (readPreprocessFields bs) -- (ParseUtils.readFields bs) +parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (ProjectConfigToParse bs) = (sanityWalkPCS False =<<) <$> liftPR (go []) (readPreprocessFields bs) where go :: [Field Position] -> [Field Position] -> IO (ParseResult ProjectConfigSkeleton) go acc (x : xs) = case x of From 06455e15d1b6bdd0d91dae8d4f0988ca3f210cc8 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 14 Jun 2024 13:52:24 +0200 Subject: [PATCH 07/41] Extract testInstallDirs into separate test --- .../ProjectConfig/Parsec/cabal.test.hs | 48 +++++++++++-------- .../Parsec/tests/install-dirs/cabal.project | 13 +++++ .../tests/local-no-index-repos/cabal.project | 0 .../tests/project-config-shared/cabal.project | 15 ------ .../Parsec/tests/remote-repos/cabal.project | 0 5 files changed, 42 insertions(+), 34 deletions(-) create mode 100644 cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/install-dirs/cabal.project create mode 100644 cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/local-no-index-repos/cabal.project create mode 100644 cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/remote-repos/cabal.project diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs index 7048297ee01..a47fa69eff7 100644 --- a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs @@ -66,6 +66,7 @@ main = do cabalTest' "read source-repository-package" testSourceRepoList cabalTest' "read project-config-build-only" testProjectConfigBuildOnly cabalTest' "read project-config-shared" testProjectConfigShared + cabalTest' "read install-dirs" testInstallDirs cabalTest' "set explicit provenance" testProjectConfigProvenance cabalTest' "read project-config-local-packages" testProjectConfigLocalPackages cabalTest' "read project-config-all-packages" testProjectConfigAllPackages @@ -173,25 +174,7 @@ testProjectConfigShared = do projectConfigHcPath = toFlag "/some/path/to/compiler" projectConfigHcPkg = toFlag "/some/path/to/ghc-pkg" projectConfigHaddockIndex = toFlag $ toPathTemplate "/path/to/haddock-index" - projectConfigInstallDirs = - InstallDirs - { prefix = Flag $ toPathTemplate "my/prefix-path" - , bindir = Flag $ toPathTemplate "bin/dir/" - , libdir = Flag $ toPathTemplate "lib/dir/path" - , libsubdir = Flag $ toPathTemplate "/lib/sub/dir" - , dynlibdir = Flag $ toPathTemplate "dyn/lib/dir/path" - , flibdir = mempty - , libexecdir = Flag $ toPathTemplate "lib/exec/dir/" - , libexecsubdir = Flag $ toPathTemplate "libexec/subdir" - , includedir = mempty - , datadir = Flag $ toPathTemplate "path/to/datadir/" - , datasubdir = Flag $ toPathTemplate "a/datadir/subdir" - , docdir = Flag $ toPathTemplate "path/to/docs" - , mandir = mempty - , htmldir = Flag $ toPathTemplate "dir/html/" - , haddockdir = Flag $ toPathTemplate "haddock/dir" - , sysconfdir = Flag $ toPathTemplate "sys/conf/dir" - } + projectConfigInstallDirs = mempty -- tested below in testInstallDirs projectConfigPackageDBs = [Nothing, Just (SpecificPackageDB "foo"), Nothing, Just (SpecificPackageDB "bar"), Just (SpecificPackageDB "baz")] projectConfigRemoteRepos = mempty -- cli only projectConfigLocalNoIndexRepos = mempty -- cli only @@ -232,6 +215,33 @@ testProjectConfigShared = do projectConfigProgPathExtra = toNubList ["/foo/bar", "/baz/quux"] projectConfigMultiRepl = toFlag True +testInstallDirs :: TestM () +testInstallDirs = do + let rootFp = "install-dirs" + testDir <- testDirInfo rootFp "cabal.project" + (config, _) <- readConfigDefault rootFp + assertConfig' expected config (projectConfigInstallDirs . projectConfigShared . condTreeData) + where + expected = + InstallDirs + { prefix = Flag $ toPathTemplate "my/prefix-path" + , bindir = Flag $ toPathTemplate "bin/dir/" + , libdir = Flag $ toPathTemplate "lib/dir/path" + , libsubdir = Flag $ toPathTemplate "/lib/sub/dir" + , dynlibdir = Flag $ toPathTemplate "dyn/lib/dir/path" + , flibdir = mempty + , libexecdir = Flag $ toPathTemplate "lib/exec/dir/" + , libexecsubdir = Flag $ toPathTemplate "libexec/subdir" + , includedir = mempty + , datadir = Flag $ toPathTemplate "path/to/datadir/" + , datasubdir = Flag $ toPathTemplate "a/datadir/subdir" + , docdir = Flag $ toPathTemplate "path/to/docs" + , mandir = mempty + , htmldir = Flag $ toPathTemplate "dir/html/" + , haddockdir = Flag $ toPathTemplate "haddock/dir" + , sysconfdir = Flag $ toPathTemplate "sys/conf/dir" + } + testProjectConfigProvenance :: TestM () testProjectConfigProvenance = do let rootFp = "empty" diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/install-dirs/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/install-dirs/cabal.project new file mode 100644 index 00000000000..e9397c1bbef --- /dev/null +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/install-dirs/cabal.project @@ -0,0 +1,13 @@ +prefix: my/prefix-path +bindir: bin/dir/ +libdir: lib/dir/path +libsubdir: /lib/sub/dir +dynlibdir: dyn/lib/dir/path +libexecdir: lib/exec/dir/ +libexecsubdir: libexec/subdir +datadir: path/to/datadir/ +datasubdir: a/datadir/subdir +docdir: path/to/docs +htmldir: dir/html/ +haddockdir: haddock/dir +sysconfdir: sys/conf/dir diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/local-no-index-repos/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/local-no-index-repos/cabal.project new file mode 100644 index 00000000000..e69de29bb2d diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-shared/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-shared/cabal.project index 82eb52a1cbb..90f00f96278 100644 --- a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-shared/cabal.project +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-shared/cabal.project @@ -37,18 +37,3 @@ prefer-oldest: True extra-prog-path: /foo/bar, /baz/quux extra-prog-path-shared-only: /foo/bar, /baz/quux multi-repl: True - --- InstallDirs -prefix: my/prefix-path -bindir: bin/dir/ -libdir: lib/dir/path -libsubdir: /lib/sub/dir -dynlibdir: dyn/lib/dir/path -libexecdir: lib/exec/dir/ -libexecsubdir: libexec/subdir -datadir: path/to/datadir/ -datasubdir: a/datadir/subdir -docdir: path/to/docs -htmldir: dir/html/ -haddockdir: haddock/dir -sysconfdir: sys/conf/dir diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/remote-repos/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/remote-repos/cabal.project new file mode 100644 index 00000000000..e69de29bb2d From 63aee4e4639b3fdb00eca28b3caaad059dae3b9c Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 14 Jun 2024 14:06:19 +0200 Subject: [PATCH 08/41] Add RemoteRepos and LocalNoIndexRepos test stubs --- .../ProjectConfig/Parsec/cabal.test.hs | 27 +++++++++++++++++-- 1 file changed, 25 insertions(+), 2 deletions(-) diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs index a47fa69eff7..c659a1963a2 100644 --- a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs @@ -21,6 +21,7 @@ import Distribution.Client.Targets (readUserConstraint) import Distribution.Client.Types.AllowNewer (AllowNewer (..), AllowOlder (..), RelaxDepMod (..), RelaxDepScope (..), RelaxDepSubject (..), RelaxDeps (..), RelaxedDep (..)) import Distribution.Client.Types.InstallMethod (InstallMethod (..)) import Distribution.Client.Types.OverwritePolicy (OverwritePolicy (..)) +import Distribution.Client.Types.Repo (LocalRepo (..), RemoteRepo (..)) import Distribution.Client.Types.RepoName (RepoName (..)) import Distribution.Client.Types.SourceRepo import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy (WriteGhcEnvironmentFilesPolicy (..)) @@ -67,6 +68,8 @@ main = do cabalTest' "read project-config-build-only" testProjectConfigBuildOnly cabalTest' "read project-config-shared" testProjectConfigShared cabalTest' "read install-dirs" testInstallDirs + cabalTest' "read remote-repos" testRemoteRepos + cabalTest' "read local-no-index-repos" testLocalNoIndexRepos cabalTest' "set explicit provenance" testProjectConfigProvenance cabalTest' "read project-config-local-packages" testProjectConfigLocalPackages cabalTest' "read project-config-all-packages" testProjectConfigAllPackages @@ -176,8 +179,8 @@ testProjectConfigShared = do projectConfigHaddockIndex = toFlag $ toPathTemplate "/path/to/haddock-index" projectConfigInstallDirs = mempty -- tested below in testInstallDirs projectConfigPackageDBs = [Nothing, Just (SpecificPackageDB "foo"), Nothing, Just (SpecificPackageDB "bar"), Just (SpecificPackageDB "baz")] - projectConfigRemoteRepos = mempty -- cli only - projectConfigLocalNoIndexRepos = mempty -- cli only + projectConfigRemoteRepos = mempty -- tested below in testRemoteRepos + projectConfigLocalNoIndexRepos = mempty -- tested below in testLocalNoIndexRepos projectConfigActiveRepos = Flag (ActiveRepos [ActiveRepo (RepoName "hackage.haskell.org") CombineStrategyMerge, ActiveRepo (RepoName "my-repository") CombineStrategyOverride]) projectConfigIndexState = let @@ -242,6 +245,26 @@ testInstallDirs = do , sysconfdir = Flag $ toPathTemplate "sys/conf/dir" } +testRemoteRepos :: TestM () +testRemoteRepos = do + let rootFp = "remote-repos" + testDir <- testDirInfo rootFp "cabal.project" + (config, _) <- readConfigDefault rootFp + assertConfig' expected config (projectConfigRemoteRepos . projectConfigShared . condTreeData) + assertConfig' mempty config (projectConfigLocalNoIndexRepos . projectConfigShared . condTreeData) + where + expected = mempty + +testLocalNoIndexRepos :: TestM () +testLocalNoIndexRepos = do + let rootFp = "local-no-index-repos" + testDir <- testDirInfo rootFp "cabal.project" + (config, _) <- readConfigDefault rootFp + assertConfig' expected config (projectConfigLocalNoIndexRepos . projectConfigShared . condTreeData) + assertConfig' mempty config (projectConfigRemoteRepos . projectConfigShared . condTreeData) + where + expected = mempty + testProjectConfigProvenance :: TestM () testProjectConfigProvenance = do let rootFp = "empty" From 6f34619e63d20675050dc346cceef5a52ee8ba3f Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 14 Jun 2024 14:23:52 +0200 Subject: [PATCH 09/41] Add RemoteRepos test --- .../ProjectConfig/Parsec/cabal.test.hs | 21 ++++++++++++++++++- .../Parsec/tests/remote-repos/cabal.project | 12 +++++++++++ cabal-testsuite/cabal-testsuite.cabal | 1 + 3 files changed, 33 insertions(+), 1 deletion(-) diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs index c659a1963a2..7818c991251 100644 --- a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs @@ -56,6 +56,7 @@ import Distribution.Utils.NubList import Distribution.Verbosity import System.Directory import System.FilePath +import Network.URI (parseURI) import Test.Cabal.Prelude hiding (cabal) import qualified Test.Cabal.Prelude as P @@ -253,7 +254,25 @@ testRemoteRepos = do assertConfig' expected config (projectConfigRemoteRepos . projectConfigShared . condTreeData) assertConfig' mempty config (projectConfigLocalNoIndexRepos . projectConfigShared . condTreeData) where - expected = mempty + expected = toNubList [packagesRepository, morePackagesRepository] + packagesRepository = + RemoteRepo + { remoteRepoName = RepoName $ "packages.example.org" + , remoteRepoURI = fromJust $ parseURI "http://packages.example.org/" + , remoteRepoSecure = pure True + , remoteRepoRootKeys = ["21", "42"] + , remoteRepoKeyThreshold = 123 + , remoteRepoShouldTryHttps = True + } + morePackagesRepository = + RemoteRepo + { remoteRepoName = RepoName $ "more-packages.example.org" + , remoteRepoURI = fromJust $ parseURI "https://more-packages.example.org/" + , remoteRepoSecure = pure True + , remoteRepoRootKeys = ["foo", "bar"] + , remoteRepoKeyThreshold = 42 + , remoteRepoShouldTryHttps = True + } testLocalNoIndexRepos :: TestM () testLocalNoIndexRepos = do diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/remote-repos/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/remote-repos/cabal.project index e69de29bb2d..17c89e0cc99 100644 --- a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/remote-repos/cabal.project +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/remote-repos/cabal.project @@ -0,0 +1,12 @@ +repository packages.example.org + url: http://packages.example.org/ + secure: True + root-keys: 21, 42 + key-threshold: 123 + +repository more-packages.example.org + url: https://more-packages.example.org/ + secure: True + root-keys: foo + , bar + key-threshold: 42 diff --git a/cabal-testsuite/cabal-testsuite.cabal b/cabal-testsuite/cabal-testsuite.cabal index d22b646b227..c877f960b4f 100644 --- a/cabal-testsuite/cabal-testsuite.cabal +++ b/cabal-testsuite/cabal-testsuite.cabal @@ -141,6 +141,7 @@ executable test-runtime-deps , directory , exceptions , filepath + , network-uri , process , time , transformers From e92f9514e02697a696c6991db494cff16a170658 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 14 Jun 2024 15:04:56 +0200 Subject: [PATCH 10/41] Add LocalNoIndexRepos Test --- .../ProjectConfig/Parsec/cabal.test.hs | 31 ++++++++++++++++--- .../tests/local-no-index-repos/cabal.project | 5 +++ .../Parsec/tests/remote-repos/cabal.project | 8 ++++- 3 files changed, 38 insertions(+), 6 deletions(-) diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs index 7818c991251..92887b85aff 100644 --- a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs @@ -54,9 +54,9 @@ import Distribution.Types.Version (mkVersion) import Distribution.Types.VersionRange.Internal (VersionRange (..)) import Distribution.Utils.NubList import Distribution.Verbosity +import Network.URI (parseURI) import System.Directory import System.FilePath -import Network.URI (parseURI) import Test.Cabal.Prelude hiding (cabal) import qualified Test.Cabal.Prelude as P @@ -262,16 +262,25 @@ testRemoteRepos = do , remoteRepoSecure = pure True , remoteRepoRootKeys = ["21", "42"] , remoteRepoKeyThreshold = 123 - , remoteRepoShouldTryHttps = True + , remoteRepoShouldTryHttps = False } morePackagesRepository = RemoteRepo { remoteRepoName = RepoName $ "more-packages.example.org" , remoteRepoURI = fromJust $ parseURI "https://more-packages.example.org/" - , remoteRepoSecure = pure True + , remoteRepoSecure = pure False , remoteRepoRootKeys = ["foo", "bar"] , remoteRepoKeyThreshold = 42 - , remoteRepoShouldTryHttps = True + , remoteRepoShouldTryHttps = False + } + secureLocalRepository = + RemoteRepo + { remoteRepoName = RepoName $ "my-secure-local-repository" + , remoteRepoURI = fromJust $ parseURI "file:/path/to/secure/repo" + , remoteRepoSecure = pure True + , remoteRepoRootKeys = ["123"] + , remoteRepoKeyThreshold = 1 + , remoteRepoShouldTryHttps = False } testLocalNoIndexRepos :: TestM () @@ -282,7 +291,19 @@ testLocalNoIndexRepos = do assertConfig' expected config (projectConfigLocalNoIndexRepos . projectConfigShared . condTreeData) assertConfig' mempty config (projectConfigRemoteRepos . projectConfigShared . condTreeData) where - expected = mempty + expected = toNubList [myRepository, mySecureRepository] + myRepository = + LocalRepo + { localRepoName = RepoName $ "my-repository" + , localRepoPath = "/absolute/path/to/directory" + , localRepoSharedCache = False + } + mySecureRepository = + LocalRepo + { localRepoName = RepoName $ "my-other-repository" + , localRepoPath = "/another/path/to/repository" + , localRepoSharedCache = False + } testProjectConfigProvenance :: TestM () testProjectConfigProvenance = do diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/local-no-index-repos/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/local-no-index-repos/cabal.project index e69de29bb2d..f6b42df28b6 100644 --- a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/local-no-index-repos/cabal.project +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/local-no-index-repos/cabal.project @@ -0,0 +1,5 @@ +repository my-repository + url: file+noindex:///absolute/path/to/directory + +repository my-other-repository + url: file+noindex:/another/path/to/repository diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/remote-repos/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/remote-repos/cabal.project index 17c89e0cc99..7767a4541f1 100644 --- a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/remote-repos/cabal.project +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/remote-repos/cabal.project @@ -6,7 +6,13 @@ repository packages.example.org repository more-packages.example.org url: https://more-packages.example.org/ - secure: True + secure: False root-keys: foo , bar key-threshold: 42 + +repository my-secure-local-repository + url: file:/path/to/secure/repo + secure: True + root-keys: 123 + key-threshold: 1 From c1f80719f87e89585425ed0f624fbe7467fa7fe2 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 14 Jun 2024 15:41:58 +0200 Subject: [PATCH 11/41] Update only compare parsed values of repositories --- .../ProjectConfig/Parsec/cabal.test.hs | 57 +++++++++++-------- 1 file changed, 34 insertions(+), 23 deletions(-) diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs index 92887b85aff..78805bf9c5f 100644 --- a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs @@ -166,8 +166,8 @@ testProjectConfigShared = do let projectConfigConstraints = getProjectConfigConstraints (testDirProjectConfigFp testDir) expected = ProjectConfigShared{..} - (config, _) <- readConfigDefault rootFp - assertConfig' expected config (projectConfigShared . condTreeData) + (config, legacy) <- readConfigDefault rootFp + assertConfig expected config legacy (projectConfigShared . condTreeData) where projectConfigDistDir = toFlag "something" projectConfigConfigFile = mempty -- cli only @@ -222,9 +222,8 @@ testProjectConfigShared = do testInstallDirs :: TestM () testInstallDirs = do let rootFp = "install-dirs" - testDir <- testDirInfo rootFp "cabal.project" - (config, _) <- readConfigDefault rootFp - assertConfig' expected config (projectConfigInstallDirs . projectConfigShared . condTreeData) + (config, legacy) <- readConfigDefault rootFp + assertConfig expected config legacy (projectConfigInstallDirs . projectConfigShared . condTreeData) where expected = InstallDirs @@ -249,12 +248,12 @@ testInstallDirs = do testRemoteRepos :: TestM () testRemoteRepos = do let rootFp = "remote-repos" - testDir <- testDirInfo rootFp "cabal.project" - (config, _) <- readConfigDefault rootFp - assertConfig' expected config (projectConfigRemoteRepos . projectConfigShared . condTreeData) - assertConfig' mempty config (projectConfigLocalNoIndexRepos . projectConfigShared . condTreeData) + (config, legacy) <- readConfigDefault rootFp + let actualRemoteRepos = (fromNubList . projectConfigRemoteRepos . projectConfigShared . condTreeData) config + assertBool "Expected RemoteRepos do not match parsed values" $ compareLists expected actualRemoteRepos compareRemoteRepos + assertConfig mempty config legacy (projectConfigLocalNoIndexRepos . projectConfigShared . condTreeData) where - expected = toNubList [packagesRepository, morePackagesRepository] + expected = [packagesRepository, morePackagesRepository, secureLocalRepository] packagesRepository = RemoteRepo { remoteRepoName = RepoName $ "packages.example.org" @@ -283,15 +282,24 @@ testRemoteRepos = do , remoteRepoShouldTryHttps = False } +-- We do not parse remoteRepoShouldTryHttps, so we skip it +compareRemoteRepos :: RemoteRepo -> RemoteRepo -> Bool +compareRemoteRepos repo1 repo2 = + remoteRepoName repo1 == remoteRepoName repo2 + && remoteRepoURI repo1 == remoteRepoURI repo2 + && remoteRepoSecure repo1 == remoteRepoSecure repo2 + && remoteRepoRootKeys repo1 == remoteRepoRootKeys repo2 + && remoteRepoKeyThreshold repo1 == remoteRepoKeyThreshold repo2 + testLocalNoIndexRepos :: TestM () testLocalNoIndexRepos = do let rootFp = "local-no-index-repos" - testDir <- testDirInfo rootFp "cabal.project" - (config, _) <- readConfigDefault rootFp - assertConfig' expected config (projectConfigLocalNoIndexRepos . projectConfigShared . condTreeData) - assertConfig' mempty config (projectConfigRemoteRepos . projectConfigShared . condTreeData) + (config, legacy) <- readConfigDefault rootFp + let actualLocalRepos = (fromNubList . projectConfigLocalNoIndexRepos . projectConfigShared . condTreeData) config + assertBool "Expected LocalNoIndexRepos do not match parsed values" $ compareLists expected actualLocalRepos compareLocalRepos + assertConfig mempty config legacy (projectConfigRemoteRepos . projectConfigShared . condTreeData) where - expected = toNubList [myRepository, mySecureRepository] + expected = [myRepository, mySecureRepository] myRepository = LocalRepo { localRepoName = RepoName $ "my-repository" @@ -305,10 +313,15 @@ testLocalNoIndexRepos = do , localRepoSharedCache = False } +-- We do not parse localRepoSharedCache, so we skip it +compareLocalRepos :: LocalRepo -> LocalRepo -> Bool +compareLocalRepos repo1 repo2 = + localRepoName repo1 == localRepoName repo2 + && localRepoPath repo1 == localRepoPath repo2 + testProjectConfigProvenance :: TestM () testProjectConfigProvenance = do let rootFp = "empty" - testDir <- testDirInfo rootFp "cabal.project" let expected = Set.singleton (Explicit (ProjectConfigPath $ "cabal.project" :| [])) (config, legacy) <- readConfigDefault rootFp @@ -519,15 +532,10 @@ testDirInfo testSubDir projectFileName = do where extensionName = "" -assertConfig' :: (Eq a, Show a) => a -> ProjectConfigSkeleton -> (ProjectConfigSkeleton -> a) -> TestM () -assertConfig' expected config access = assertEqual "Parsec Config" expected actual - where - actual = access config - assertConfig :: (Eq a, Show a) => a -> ProjectConfigSkeleton -> ProjectConfigSkeleton -> (ProjectConfigSkeleton -> a) -> TestM () assertConfig expected config configLegacy access = do - assertEqual "Equal Legacy Config" expected actualLegacy - assertEqual "Equal Parsec Config" expected actual + assertEqual "Expectation does not match result of Legacy parser" expected actualLegacy + assertEqual "Parsed Config does not match expected" expected actual where actual = access config actualLegacy = access configLegacy @@ -535,3 +543,6 @@ assertConfig expected config configLegacy access = do -- | Test Utilities verbosity :: Verbosity verbosity = normal -- minBound --normal --verbose --maxBound --minBound + +compareLists :: [a] -> [a] -> (a -> a -> Bool) -> Bool +compareLists xs ys compare = length xs == length ys && all (uncurry compare) (zip xs ys) From 9ceadbc20d7cb03e4d806258276898cea2068376 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 12 Jul 2024 15:08:20 +0200 Subject: [PATCH 12/41] Add Distribution.Client.Utils.Newtypes module --- cabal-install/cabal-install.cabal | 1 + .../Client/ProjectConfig/FieldGrammar.hs | 4 +- .../src/Distribution/Client/Utils/Newtypes.hs | 89 +++++++++++++++++++ .../src/Distribution/Client/Utils/Parsec.hs | 81 ++++------------- 4 files changed, 109 insertions(+), 66 deletions(-) create mode 100644 cabal-install/src/Distribution/Client/Utils/Newtypes.hs diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index ce63094aec0..50c7a60c6bc 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -221,6 +221,7 @@ library Distribution.Client.Upload Distribution.Client.Utils Distribution.Client.Utils.Json + Distribution.Client.Utils.Newtypes Distribution.Client.Utils.Parsec Distribution.Client.VCS Distribution.Client.Version diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs index 040eadac8c1..dcc888037f3 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs @@ -80,8 +80,8 @@ projectConfigSharedFieldGrammar source = <*> optionalFieldDef "doc-index-file" L.projectConfigHaddockIndex mempty <*> blurFieldGrammar L.projectConfigInstallDirs installDirsGrammar <*> monoidalFieldAla "package-dbs" (alaList' CommaFSep PackageDBNT) L.projectConfigPackageDBs - <*> pure mempty -- cli flag: projectConfigRemoteRepos - <*> pure mempty -- cli flag: projectConfigLocalNoIndexRepos + <*> pure mempty -- repository stanza for projectConfigRemoteRepos + <*> pure mempty -- repository stanza for projectConfigLocalNoIndexRepos <*> monoidalField "active-repositories" L.projectConfigActiveRepos <*> monoidalField "index-state" L.projectConfigIndexState <*> optionalFieldDefAla "store-dir" (alaFlag FilePathNT) L.projectConfigStoreDir mempty diff --git a/cabal-install/src/Distribution/Client/Utils/Newtypes.hs b/cabal-install/src/Distribution/Client/Utils/Newtypes.hs new file mode 100644 index 00000000000..34ce1887def --- /dev/null +++ b/cabal-install/src/Distribution/Client/Utils/Newtypes.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | This module provides @newtype@ wrappers to be used with "Distribution.FieldGrammar". +-- Whenever we can not provide a Parsec instance for a type, we need to wrap it in a newtype and define the instance. +module Distribution.Client.Utils.Newtypes + ( NumJobs (..) + , PackageDBNT (..) + , ProjectConstraints (..) + , MaxBackjumps (..) + , URI_NT (..) + ) +where + +import Distribution.Client.Compat.Prelude +import Distribution.Client.Targets (UserConstraint) +import Distribution.Compat.CharParsing +import Distribution.Compat.Newtype +import Distribution.Parsec +import Distribution.Simple.Compiler (PackageDB (..), readPackageDb) +import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) +import Network.URI (URI, parseURI) + +newtype PackageDBNT = PackageDBNT {getPackageDBNT :: Maybe PackageDB} + +instance Newtype (Maybe PackageDB) PackageDBNT + +instance Parsec PackageDBNT where + parsec = parsecPackageDB + +parsecPackageDB :: CabalParsing m => m PackageDBNT +parsecPackageDB = PackageDBNT . readPackageDb <$> parsecToken + +newtype NumJobs = NumJobs {getNumJobs :: Maybe Int} + +instance Newtype (Maybe Int) NumJobs + +instance Parsec NumJobs where + parsec = parsecNumJobs + +newtype URI_NT = URI_NT {getURI_NT :: URI} + +instance Newtype (URI) URI_NT + +instance Parsec URI_NT where + parsec = parsecURI_NT + +parsecURI_NT :: CabalParsing m => m URI_NT +parsecURI_NT = do + token <- parsecToken' + case parseURI token of + Nothing -> fail $ "failed to parse URI " <> token + Just uri -> return $ URI_NT uri + +parsecNumJobs :: CabalParsing m => m NumJobs +parsecNumJobs = ncpus <|> numJobs + where + ncpus = string "$ncpus" >> return (NumJobs Nothing) + numJobs = do + num <- integral + if num < (1 :: Int) + then do + parsecWarning PWTOther "The number of jobs should be 1 or more." + return (NumJobs Nothing) + else return (NumJobs $ Just num) + +newtype ProjectConstraints = ProjectConstraints {getProjectConstraints :: (UserConstraint, ConstraintSource)} + +instance Newtype (UserConstraint, ConstraintSource) ProjectConstraints + +instance Parsec ProjectConstraints where + parsec = parsecProjectConstraints + +-- | Parse 'ProjectConstraints'. As the 'CabalParsing' class does not have access to the file we parse, +-- ConstraintSource is first unknown and we set it afterwards +parsecProjectConstraints :: CabalParsing m => m ProjectConstraints +parsecProjectConstraints = do + userConstraint <- parsec + return $ ProjectConstraints (userConstraint, ConstraintSourceUnknown) + +newtype MaxBackjumps = MaxBackjumps {getMaxBackjumps :: Int} + +instance Newtype Int MaxBackjumps + +instance Parsec MaxBackjumps where + parsec = parseMaxBackjumps + +parseMaxBackjumps :: CabalParsing m => m MaxBackjumps +parseMaxBackjumps = MaxBackjumps <$> integral diff --git a/cabal-install/src/Distribution/Client/Utils/Parsec.hs b/cabal-install/src/Distribution/Client/Utils/Parsec.hs index 0af52b4e237..6ac4e92c769 100644 --- a/cabal-install/src/Distribution/Client/Utils/Parsec.hs +++ b/cabal-install/src/Distribution/Client/Utils/Parsec.hs @@ -4,6 +4,7 @@ module Distribution.Client.Utils.Parsec ( renderParseError + , remoteRepoGrammar -- ** Flag , alaFlag @@ -15,25 +16,21 @@ module Distribution.Client.Utils.Parsec , NubList' -- ** Newtype wrappers - , NumJobs (..) - , PackageDBNT (..) - , ProjectConstraints (..) - , MaxBackjumps (..) + , module Distribution.Client.Utils.Newtypes ) where import Distribution.Client.Compat.Prelude -import Distribution.Client.Targets (UserConstraint) import Distribution.Compat.Newtype -import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) import System.FilePath (normalise) import Prelude () import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 -import Distribution.Compat.CharParsing -import Distribution.FieldGrammar.Newtypes -import Distribution.Parsec (PError (..), PWarnType (..), PWarning (..), Position (..), parsecToken, parsecWarning, showPos, zeroPos) -import Distribution.Simple.Compiler (PackageDB (..), readPackageDb) +import Distribution.Client.Types.Repo +import Distribution.Client.Types.RepoName +import Distribution.Client.Utils.Newtypes +import Distribution.FieldGrammar +import Distribution.Parsec import Distribution.Simple.Flag import Distribution.Simple.Utils (fromUTF8BS) import Distribution.Utils.NubList (NubList (..)) @@ -179,57 +176,13 @@ instance (Newtype a b, Ord a, Sep sep, Parsec b) => Parsec (NubList' sep b a) wh instance (Newtype a b, Sep sep, Pretty b) => Pretty (NubList' sep b a) where pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . NubList.fromNubList . unpack --- | We can't write a Parsec instance for Maybe PackageDB. We need to wrap it in a newtype and define the instance. -newtype PackageDBNT = PackageDBNT {getPackageDBNT :: Maybe PackageDB} - -instance Newtype (Maybe PackageDB) PackageDBNT - -instance Parsec PackageDBNT where - parsec = parsecPackageDB - -parsecPackageDB :: CabalParsing m => m PackageDBNT -parsecPackageDB = PackageDBNT . readPackageDb <$> parsecToken - --- | We can't write a Parsec instance for Maybe Int. We need to wrap it in a newtype and define the instance. -newtype NumJobs = NumJobs {getNumJobs :: Maybe Int} - -instance Newtype (Maybe Int) NumJobs - -instance Parsec NumJobs where - parsec = parsecNumJobs - -parsecNumJobs :: CabalParsing m => m NumJobs -parsecNumJobs = ncpus <|> numJobs - where - ncpus = string "$ncpus" >> return (NumJobs Nothing) - numJobs = do - num <- integral - if num < (1 :: Int) - then do - parsecWarning PWTOther "The number of jobs should be 1 or more." - return (NumJobs Nothing) - else return (NumJobs $ Just num) - -newtype ProjectConstraints = ProjectConstraints {getProjectConstraints :: (UserConstraint, ConstraintSource)} - -instance Newtype (UserConstraint, ConstraintSource) ProjectConstraints - -instance Parsec ProjectConstraints where - parsec = parsecProjectConstraints - --- | Parse 'ProjectConstraints'. As the 'CabalParsing' class does not have access to the file we parse, --- ConstraintSource is first unknown and we set it afterwards -parsecProjectConstraints :: CabalParsing m => m ProjectConstraints -parsecProjectConstraints = do - userConstraint <- parsec - return $ ProjectConstraints (userConstraint, ConstraintSourceUnknown) - -newtype MaxBackjumps = MaxBackjumps {getMaxBackjumps :: Int} - -instance Newtype Int MaxBackjumps - -instance Parsec MaxBackjumps where - parsec = parseMaxBackjumps - -parseMaxBackjumps :: CabalParsing m => m MaxBackjumps -parseMaxBackjumps = MaxBackjumps <$> integral +remoteRepoGrammar :: RepoName -> ParsecFieldGrammar RemoteRepo RemoteRepo +remoteRepoGrammar name = + RemoteRepo + <$> pure name + -- <*> uniqueFieldAla "url" URI_NT undefined -- remoteRepoURI "url" + <*> undefined + <*> undefined -- remoteRepoSecure "secure" + <*> undefined -- remoteRepoRootKeys "root-keys" + <*> undefined -- remoteRepoKeyThreshold "key-threshold" + <*> undefined -- remoteRepoShouldTryHttps --nope From f3f2a02493f2d1457b414a0060acd08bd0e6924e Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 12 Jul 2024 16:04:38 +0200 Subject: [PATCH 13/41] Add RemoteRepo Lenses --- .../src/Distribution/Client/Types/Repo.hs | 21 +++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/cabal-install/src/Distribution/Client/Types/Repo.hs b/cabal-install/src/Distribution/Client/Types/Repo.hs index b5606725432..bbf989a4f81 100644 --- a/cabal-install/src/Distribution/Client/Types/Repo.hs +++ b/cabal-install/src/Distribution/Client/Types/Repo.hs @@ -4,6 +4,10 @@ module Distribution.Client.Types.Repo ( -- * Remote repository RemoteRepo (..) , emptyRemoteRepo + , remoteRepoKeyThresholdLens + , remoteRepoRootKeysLens + , remoteRepoSecureLens + , remoteRepoURILens -- * Local repository (no-index) , LocalRepo (..) @@ -25,6 +29,7 @@ import Network.URI (URI (..), nullURI, parseAbsoluteURI, uriToString) import Distribution.Simple.Utils (toUTF8BS) import Distribution.Client.HashValue (hashValue, showHashValue, truncateHash) +import Distribution.Compat.Lens import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Distribution.Compat.CharParsing as P @@ -90,6 +95,22 @@ instance Parsec RemoteRepo where emptyRemoteRepo :: RepoName -> RemoteRepo emptyRemoteRepo name = RemoteRepo name nullURI Nothing [] 0 False +remoteRepoURILens :: Lens' RemoteRepo URI +remoteRepoURILens f s = fmap (\x -> s{remoteRepoURI = x}) (f (remoteRepoURI s)) +{-# INLINE remoteRepoURILens #-} + +remoteRepoSecureLens :: Lens' RemoteRepo (Maybe Bool) +remoteRepoSecureLens f s = fmap (\x -> s{remoteRepoSecure = x}) (f (remoteRepoSecure s)) +{-# INLINE remoteRepoSecureLens #-} + +remoteRepoRootKeysLens :: Lens' RemoteRepo [String] +remoteRepoRootKeysLens f s = fmap (\x -> s{remoteRepoRootKeys = x}) (f (remoteRepoRootKeys s)) +{-# INLINE remoteRepoRootKeysLens #-} + +remoteRepoKeyThresholdLens :: Lens' RemoteRepo Int +remoteRepoKeyThresholdLens f s = fmap (\x -> s{remoteRepoKeyThreshold = x}) (f (remoteRepoKeyThreshold s)) +{-# INLINE remoteRepoKeyThresholdLens #-} + ------------------------------------------------------------------------------- -- Local repository ------------------------------------------------------------------------------- From 8a1abbcfff9c089adbb2bd1c98f1fb93a242775b Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 12 Jul 2024 16:05:44 +0200 Subject: [PATCH 14/41] Add RemoteRepo FieldGrammar --- .../src/Distribution/Client/Utils/Newtypes.hs | 8 ++++++++ .../src/Distribution/Client/Utils/Parsec.hs | 12 ++++++------ 2 files changed, 14 insertions(+), 6 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Utils/Newtypes.hs b/cabal-install/src/Distribution/Client/Utils/Newtypes.hs index 34ce1887def..69db368d048 100644 --- a/cabal-install/src/Distribution/Client/Utils/Newtypes.hs +++ b/cabal-install/src/Distribution/Client/Utils/Newtypes.hs @@ -9,6 +9,7 @@ module Distribution.Client.Utils.Newtypes , ProjectConstraints (..) , MaxBackjumps (..) , URI_NT (..) + , KeyThreshold (..) ) where @@ -52,6 +53,13 @@ parsecURI_NT = do Nothing -> fail $ "failed to parse URI " <> token Just uri -> return $ URI_NT uri +newtype KeyThreshold = KeyThreshold {getKeyThreshold :: Int} + +instance Newtype Int KeyThreshold + +instance Parsec KeyThreshold where + parsec = KeyThreshold <$> integral + parsecNumJobs :: CabalParsing m => m NumJobs parsecNumJobs = ncpus <|> numJobs where diff --git a/cabal-install/src/Distribution/Client/Utils/Parsec.hs b/cabal-install/src/Distribution/Client/Utils/Parsec.hs index 6ac4e92c769..aaf200261a9 100644 --- a/cabal-install/src/Distribution/Client/Utils/Parsec.hs +++ b/cabal-install/src/Distribution/Client/Utils/Parsec.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Distribution.Client.Utils.Parsec @@ -180,9 +181,8 @@ remoteRepoGrammar :: RepoName -> ParsecFieldGrammar RemoteRepo RemoteRepo remoteRepoGrammar name = RemoteRepo <$> pure name - -- <*> uniqueFieldAla "url" URI_NT undefined -- remoteRepoURI "url" - <*> undefined - <*> undefined -- remoteRepoSecure "secure" - <*> undefined -- remoteRepoRootKeys "root-keys" - <*> undefined -- remoteRepoKeyThreshold "key-threshold" - <*> undefined -- remoteRepoShouldTryHttps --nope + <*> uniqueFieldAla "url" URI_NT remoteRepoURILens + <*> optionalField "secure" remoteRepoSecureLens + <*> monoidalFieldAla "root-keys" (alaList' FSep Token) remoteRepoRootKeysLens + <*> optionalFieldDefAla "key-threshold" KeyThreshold remoteRepoKeyThresholdLens 0 + <*> pure False -- we don't parse remoteRepoShouldTryHttps From ce0a82d422d4cd61e40d1efc326c17375efd33be Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 26 Jul 2024 22:22:56 +0200 Subject: [PATCH 15/41] Add parsing of repository sections --- .../Distribution/Client/ProjectConfig/Lens.hs | 9 +++ .../Client/ProjectConfig/Parsec.hs | 77 ++++++++++++++++--- 2 files changed, 76 insertions(+), 10 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs index 65fd44b9da9..1b10f0227a1 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs @@ -11,6 +11,7 @@ import Distribution.Client.ProjectConfig.Types (MapMappend, PackageConfig, Proje import qualified Distribution.Client.ProjectConfig.Types as T import Distribution.Client.Targets (UserConstraint) import Distribution.Client.Types.AllowNewer (AllowNewer, AllowOlder) +import Distribution.Client.Types.Repo (LocalRepo, RemoteRepo) import Distribution.Client.Types.SourceRepo (SourceRepoList) import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy (WriteGhcEnvironmentFilesPolicy) import Distribution.Compat.Lens @@ -215,6 +216,14 @@ projectConfigPackageDBs :: Lens' ProjectConfigShared [Maybe PackageDB] projectConfigPackageDBs f s = fmap (\x -> s{T.projectConfigPackageDBs = x}) (f (T.projectConfigPackageDBs s)) {-# INLINEABLE projectConfigPackageDBs #-} +projectConfigLocalNoIndexRepos :: Lens' ProjectConfigShared (NubList LocalRepo) +projectConfigLocalNoIndexRepos f s = fmap (\x -> s{T.projectConfigLocalNoIndexRepos = x}) (f (T.projectConfigLocalNoIndexRepos s)) +{-# INLINEABLE projectConfigLocalNoIndexRepos #-} + +projectConfigRemoteRepos :: Lens' ProjectConfigShared (NubList RemoteRepo) +projectConfigRemoteRepos f s = fmap (\x -> s{T.projectConfigRemoteRepos = x}) (f (T.projectConfigRemoteRepos s)) +{-# INLINEABLE projectConfigRemoteRepos #-} + projectConfigActiveRepos :: Lens' ProjectConfigShared (Flag ActiveRepos) projectConfigActiveRepos f s = fmap (\x -> s{T.projectConfigActiveRepos = x}) (f (T.projectConfigActiveRepos s)) {-# INLINEABLE projectConfigActiveRepos #-} diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index b05bf12069c..2bd537c4e72 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -13,12 +13,15 @@ module Distribution.Client.ProjectConfig.Parsec , runParseResult ) where -import Network.URI (parseURI) +import Network.URI (parseURI, uriFragment, uriPath, uriScheme) import Control.Monad.State.Strict (StateT, execStateT, lift) import qualified Data.Map.Strict as Map import Distribution.CabalSpecVersion import Distribution.Client.HttpUtils +import Distribution.Client.Types.Repo hiding (repoName) +import Distribution.Client.Types.RepoName (RepoName (..)) +import Distribution.Client.Utils.Parsec import Distribution.Compat.Lens import Distribution.Compat.Prelude import Distribution.FieldGrammar @@ -36,10 +39,9 @@ import Distribution.Fields.ConfVar (parseConditionConfVar) import Distribution.Fields.ParseResult import Distribution.Solver.Types.ProjectConfigPath --- AST type import Distribution.Fields (Field (..), FieldLine (..), FieldName, Name (..), SectionArg (..), readFields', showPWarning) import Distribution.Fields.LexerMonad (toPWarnings) -import Distribution.Parsec (CabalParsing, PError (..), ParsecParser, parsec, parsecFilePath, parsecToken, runParsecParser) +import Distribution.Parsec (CabalParsing, PError (..), ParsecParser, eitherParsec, parsec, parsecFilePath, parsecToken, runParsecParser) import Distribution.Parsec.Position (Position (..), zeroPos) import Distribution.Parsec.Warning (PWarnType (..)) import Distribution.Simple.Program.Db (ProgramDb, defaultProgramDb, knownPrograms, lookupKnownProgram) @@ -49,6 +51,7 @@ import Distribution.Types.CondTree (CondBranch (..), CondTree (..)) import Distribution.Types.ConfVar (ConfVar (..)) import Distribution.Types.PackageName (PackageName) import Distribution.Utils.Generic (fromUTF8BS, toUTF8BS, validateUTF8) +import Distribution.Utils.NubList (toNubList) import qualified Data.ByteString as BS import Data.Coerce (coerce) @@ -255,6 +258,17 @@ parseSection programDb (MkSection (Name pos name) args secFields) verifyNullSectionArgs paths <- lift $ parseProgramPaths Warn programDb fields stateConfig . L.projectConfigLocalPackages %= (\cfg -> cfg{packageConfigProgramPaths = (paths <> packageConfigProgramPaths cfg)}) + | name == "repository" = do + verifyNullSubsections + mRepoName <- lift $ parseRepoName pos args + case mRepoName of + Just repoName -> do + remoteRepo <- lift $ parseFieldGrammar cabalSpec fields (remoteRepoGrammar repoName) + remoteOrLocalRepo <- lift $ postProcessRemoteRepo pos remoteRepo + case remoteOrLocalRepo of + Left local -> stateConfig . L.projectConfigShared %= (\pcs -> pcs{projectConfigLocalNoIndexRepos = (toNubList [local] <> projectConfigLocalNoIndexRepos pcs)}) + Right remote -> stateConfig . L.projectConfigShared %= (\pcs -> pcs{projectConfigRemoteRepos = (toNubList [remote] <> projectConfigRemoteRepos pcs)}) + Nothing -> lift $ parseFailure pos "a 'repository' section requires the repository name as an argument" | name == "package" = do verifyNullSubsections package <- lift $ parsePackageName pos args @@ -265,7 +279,9 @@ parseSection programDb (MkSection (Name pos name) args secFields) Just (SpecificPackage packageName) -> do packageCfg <- parsePackageConfig stateConfig . L.projectConfigSpecificPackage %= (\spcs -> spcs <> MapMappend (Map.singleton packageName packageCfg)) - Nothing -> return () + Nothing -> do + lift $ parseWarning pos PWTUnknownSection "target package name or * required" + return () | otherwise = do warnInvalidSubsection pos name where @@ -280,25 +296,66 @@ parseSection programDb (MkSection (Name pos name) args secFields) paths <- lift $ parseProgramPaths Ignore programDb fields return packageCfg{packageConfigProgramPaths = paths, packageConfigProgramArgs = args'} -data PackageConfigTarget = AllPackages | SpecificPackage PackageName +-- | Currently a duplicate of 'Distribution.Client.Config.postProcessRepo' but migrated to Parsec ParseResult. +postProcessRemoteRepo :: Position -> RemoteRepo -> ParseResult (Either LocalRepo RemoteRepo) +postProcessRemoteRepo pos repo = case uriScheme (remoteRepoURI repo) of + -- TODO: check that there are no authority, query or fragment + -- Note: the trailing colon is important + "file+noindex:" -> do + let uri = remoteRepoURI repo + return $ Left $ LocalRepo (remoteRepoName repo) (uriPath uri) (uriFragment uri == "#shared-cache") + _ -> do + when (remoteRepoKeyThreshold repo > length (remoteRepoRootKeys repo)) $ + warning $ + "'key-threshold' for repository " + ++ show (remoteRepoName repo) + ++ " higher than number of keys" + + when (not (null (remoteRepoRootKeys repo)) && remoteRepoSecure repo /= Just True) $ + warning $ + "'root-keys' for repository " + ++ show (remoteRepoName repo) + ++ " non-empty, but 'secure' not set to True." + + return $ Right repo + where + warning msg = parseWarning pos PWTOther msg + +parseRepoName :: Position -> [SectionArg Position] -> ParseResult (Maybe RepoName) +parseRepoName pos args = case args of + [SecArgName _ secName] -> parseName secName + [SecArgStr _ secName] -> parseName secName + [SecArgOther _ secName] -> parseName secName + _ -> return Nothing + where + parseName :: BS.ByteString -> ParseResult (Maybe RepoName) + parseName str = + let repoNameStr = fromUTF8BS str + in case eitherParsec repoNameStr of + Left _ -> do + parseFailure pos ("Invalid repository name" ++ repoNameStr) + return Nothing + Right name -> return $ Just name + +data PackageConfigTarget = AllPackages | SpecificPackage !PackageName parsePackageName :: Position -> [SectionArg Position] -> ParseResult (Maybe PackageConfigTarget) parsePackageName pos args = case args of [SecArgName _ secName] -> parseName secName [SecArgStr _ secName] -> parseName secName [SecArgOther _ secName] -> parseName secName - _ -> do - parseWarning pos PWTUnknownSection "target package name or * required" - return Nothing + _ -> return Nothing where parseName secName = case runParsecParser parser "" (fieldLineStreamFromBS secName) of - Left _ -> return Nothing + Left _ -> do + parseFailure pos ("Invalid package name" ++ fromUTF8BS secName) + return Nothing Right cfgTarget -> return $ pure cfgTarget parser :: ParsecParser PackageConfigTarget parser = P.choice [P.try (P.char '*' >> return AllPackages), SpecificPackage <$> parsec] --- | Decide whether to issue Warnings on unknown fields +-- | Decide whether to issue Warnings on unknown fields -- TODO 6101 why decide? document the decision here data WarnUnknownFields = Ignore | Warn -- | Parse fields of a program-options stanza. From dbab8c4e60e40c6d63dab3faf73b0a54aec0a1a2 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 26 Jul 2024 22:36:42 +0200 Subject: [PATCH 16/41] Fix RemoteRepo test --- .../src/Distribution/Client/ProjectConfig/Parsec.hs | 4 ++-- .../PackageTests/ProjectConfig/Parsec/cabal.test.hs | 6 +++--- .../ProjectConfig/Parsec/tests/remote-repos/cabal.project | 6 +++--- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index 2bd537c4e72..13dae49231c 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -266,8 +266,8 @@ parseSection programDb (MkSection (Name pos name) args secFields) remoteRepo <- lift $ parseFieldGrammar cabalSpec fields (remoteRepoGrammar repoName) remoteOrLocalRepo <- lift $ postProcessRemoteRepo pos remoteRepo case remoteOrLocalRepo of - Left local -> stateConfig . L.projectConfigShared %= (\pcs -> pcs{projectConfigLocalNoIndexRepos = (toNubList [local] <> projectConfigLocalNoIndexRepos pcs)}) - Right remote -> stateConfig . L.projectConfigShared %= (\pcs -> pcs{projectConfigRemoteRepos = (toNubList [remote] <> projectConfigRemoteRepos pcs)}) + Left local -> stateConfig . L.projectConfigShared %= (\pcs -> pcs{projectConfigLocalNoIndexRepos = (projectConfigLocalNoIndexRepos pcs <> toNubList [local])}) + Right remote -> stateConfig . L.projectConfigShared %= (\pcs -> pcs{projectConfigRemoteRepos = (projectConfigRemoteRepos pcs <> toNubList [remote])}) Nothing -> lift $ parseFailure pos "a 'repository' section requires the repository name as an argument" | name == "package" = do verifyNullSubsections diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs index 78805bf9c5f..56cf68ca0b7 100644 --- a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs @@ -260,16 +260,16 @@ testRemoteRepos = do , remoteRepoURI = fromJust $ parseURI "http://packages.example.org/" , remoteRepoSecure = pure True , remoteRepoRootKeys = ["21", "42"] - , remoteRepoKeyThreshold = 123 + , remoteRepoKeyThreshold = 2 , remoteRepoShouldTryHttps = False } morePackagesRepository = RemoteRepo { remoteRepoName = RepoName $ "more-packages.example.org" , remoteRepoURI = fromJust $ parseURI "https://more-packages.example.org/" - , remoteRepoSecure = pure False + , remoteRepoSecure = pure True , remoteRepoRootKeys = ["foo", "bar"] - , remoteRepoKeyThreshold = 42 + , remoteRepoKeyThreshold = 1 , remoteRepoShouldTryHttps = False } secureLocalRepository = diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/remote-repos/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/remote-repos/cabal.project index 7767a4541f1..819af437b03 100644 --- a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/remote-repos/cabal.project +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/remote-repos/cabal.project @@ -2,14 +2,14 @@ repository packages.example.org url: http://packages.example.org/ secure: True root-keys: 21, 42 - key-threshold: 123 + key-threshold: 2 repository more-packages.example.org url: https://more-packages.example.org/ - secure: False + secure: True root-keys: foo , bar - key-threshold: 42 + key-threshold: 1 repository my-secure-local-repository url: file:/path/to/secure/repo From 7b22c885c95e02fe5ea7715c25bf81390d50204b Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 26 Jul 2024 23:02:05 +0200 Subject: [PATCH 17/41] Improve stateConfig lense usage --- .../Distribution/Client/ProjectConfig/Lens.hs | 10 +++++++++- .../Client/ProjectConfig/Parsec.hs | 18 +++++++++--------- 2 files changed, 18 insertions(+), 10 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs index 1b10f0227a1..cebf2993ea2 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs @@ -7,7 +7,7 @@ import Distribution.Client.IndexUtils.ActiveRepos ( ActiveRepos ) import Distribution.Client.IndexUtils.IndexState (TotalIndexState) -import Distribution.Client.ProjectConfig.Types (MapMappend, PackageConfig, ProjectConfig (..), ProjectConfigBuildOnly (..), ProjectConfigProvenance, ProjectConfigShared) +import Distribution.Client.ProjectConfig.Types (MapLast, MapMappend, PackageConfig, ProjectConfig (..), ProjectConfigBuildOnly (..), ProjectConfigProvenance, ProjectConfigShared) import qualified Distribution.Client.ProjectConfig.Types as T import Distribution.Client.Targets (UserConstraint) import Distribution.Client.Types.AllowNewer (AllowNewer, AllowOlder) @@ -304,6 +304,14 @@ projectConfigMultiRepl :: Lens' ProjectConfigShared (Flag Bool) projectConfigMultiRepl f s = fmap (\x -> s{T.projectConfigMultiRepl = x}) (f (T.projectConfigMultiRepl s)) {-# INLINEABLE projectConfigMultiRepl #-} +packageConfigProgramPaths :: Lens' PackageConfig (MapLast String FilePath) +packageConfigProgramPaths f s = fmap (\x -> s{T.packageConfigProgramPaths = x}) (f (T.packageConfigProgramPaths s)) +{-# INLINEABLE packageConfigProgramPaths #-} + +packageConfigProgramArgs :: Lens' PackageConfig (MapMappend String [String]) +packageConfigProgramArgs f s = fmap (\x -> s{T.packageConfigProgramArgs = x}) (f (T.packageConfigProgramArgs s)) +{-# INLINEABLE packageConfigProgramArgs #-} + packageConfigProgramPathExtra :: Lens' PackageConfig (NubList FilePath) packageConfigProgramPathExtra f s = fmap (\x -> s{T.packageConfigProgramPathExtra = x}) (f (T.packageConfigProgramPathExtra s)) {-# INLINEABLE packageConfigProgramPathExtra #-} diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index 13dae49231c..7cfe70e79ee 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -247,17 +247,17 @@ parseSection programDb (MkSection (Name pos name) args secFields) verifyNullSubsections verifyNullSectionArgs srp <- lift $ parseFieldGrammar cabalSpec fields sourceRepositoryPackageGrammar - stateConfig . L.projectPackagesRepo %= (++ [srp]) + stateConfig . L.projectPackagesRepo %= (<> [srp]) | name == "program-options" = do verifyNullSubsections verifyNullSectionArgs - opts <- lift $ parseProgramArgs Warn programDb fields - stateConfig . L.projectConfigLocalPackages %= (\cfg -> cfg{packageConfigProgramArgs = (opts <> packageConfigProgramArgs cfg)}) + opts' <- lift $ parseProgramArgs Warn programDb fields + stateConfig . L.projectConfigLocalPackages . L.packageConfigProgramArgs %= (opts' <>) | name == "program-locations" = do verifyNullSubsections verifyNullSectionArgs - paths <- lift $ parseProgramPaths Warn programDb fields - stateConfig . L.projectConfigLocalPackages %= (\cfg -> cfg{packageConfigProgramPaths = (paths <> packageConfigProgramPaths cfg)}) + paths' <- lift $ parseProgramPaths Warn programDb fields + stateConfig . L.projectConfigLocalPackages . L.packageConfigProgramPaths %= (paths' <>) | name == "repository" = do verifyNullSubsections mRepoName <- lift $ parseRepoName pos args @@ -266,8 +266,8 @@ parseSection programDb (MkSection (Name pos name) args secFields) remoteRepo <- lift $ parseFieldGrammar cabalSpec fields (remoteRepoGrammar repoName) remoteOrLocalRepo <- lift $ postProcessRemoteRepo pos remoteRepo case remoteOrLocalRepo of - Left local -> stateConfig . L.projectConfigShared %= (\pcs -> pcs{projectConfigLocalNoIndexRepos = (projectConfigLocalNoIndexRepos pcs <> toNubList [local])}) - Right remote -> stateConfig . L.projectConfigShared %= (\pcs -> pcs{projectConfigRemoteRepos = (projectConfigRemoteRepos pcs <> toNubList [remote])}) + Left local -> stateConfig . L.projectConfigShared . L.projectConfigLocalNoIndexRepos %= (<> toNubList [local]) + Right remote -> stateConfig . L.projectConfigShared . L.projectConfigRemoteRepos %= (<> toNubList [remote]) Nothing -> lift $ parseFailure pos "a 'repository' section requires the repository name as an argument" | name == "package" = do verifyNullSubsections @@ -275,10 +275,10 @@ parseSection programDb (MkSection (Name pos name) args secFields) case package of Just AllPackages -> do packageCfg' <- parsePackageConfig - stateConfig . L.projectConfigAllPackages %= (\packageCfg -> packageCfg' <> packageCfg) + stateConfig . L.projectConfigAllPackages %= (packageCfg' <>) Just (SpecificPackage packageName) -> do packageCfg <- parsePackageConfig - stateConfig . L.projectConfigSpecificPackage %= (\spcs -> spcs <> MapMappend (Map.singleton packageName packageCfg)) + stateConfig . L.projectConfigSpecificPackage %= (<> MapMappend (Map.singleton packageName packageCfg)) Nothing -> do lift $ parseWarning pos PWTUnknownSection "target package name or * required" return () From bb6f939ea3d2626bb437b21eee350d1659c9d777 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 26 Jul 2024 23:36:24 +0200 Subject: [PATCH 18/41] Add filtering fields to parseProgramArgs/Paths --- .../Client/ProjectConfig/Parsec.hs | 29 ++++++++----------- 1 file changed, 12 insertions(+), 17 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index 7cfe70e79ee..f9f517cde0a 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -251,12 +251,12 @@ parseSection programDb (MkSection (Name pos name) args secFields) | name == "program-options" = do verifyNullSubsections verifyNullSectionArgs - opts' <- lift $ parseProgramArgs Warn programDb fields + opts' <- lift $ parseProgramArgs programDb fields stateConfig . L.projectConfigLocalPackages . L.packageConfigProgramArgs %= (opts' <>) | name == "program-locations" = do verifyNullSubsections verifyNullSectionArgs - paths' <- lift $ parseProgramPaths Warn programDb fields + paths' <- lift $ parseProgramPaths programDb fields stateConfig . L.projectConfigLocalPackages . L.packageConfigProgramPaths %= (paths' <>) | name == "repository" = do verifyNullSubsections @@ -292,8 +292,8 @@ parseSection programDb (MkSection (Name pos name) args secFields) verifyNullSectionArgs = unless (null args) (lift $ parseFailure pos $ "The section '" <> (show name) <> "' takes no arguments") parsePackageConfig = do packageCfg <- lift $ parseFieldGrammar cabalSpec fields (packageConfigFieldGrammar programNames) - args' <- lift $ parseProgramArgs Ignore programDb fields - paths <- lift $ parseProgramPaths Ignore programDb fields + args' <- lift $ parseProgramArgs programDb fields + paths <- lift $ parseProgramPaths programDb fields return packageCfg{packageConfigProgramPaths = paths, packageConfigProgramArgs = args'} -- | Currently a duplicate of 'Distribution.Client.Config.postProcessRepo' but migrated to Parsec ParseResult. @@ -355,37 +355,32 @@ parsePackageName pos args = case args of parser = P.choice [P.try (P.char '*' >> return AllPackages), SpecificPackage <$> parsec] --- | Decide whether to issue Warnings on unknown fields -- TODO 6101 why decide? document the decision here -data WarnUnknownFields = Ignore | Warn - -- | Parse fields of a program-options stanza. -parseProgramArgs :: WarnUnknownFields -> ProgramDb -> Fields Position -> ParseResult (MapMappend String [String]) -parseProgramArgs warnLevel programDb fields = foldM parseField mempty (Map.toList fields) +parseProgramArgs :: ProgramDb -> Fields Position -> ParseResult (MapMappend String [String]) +parseProgramArgs programDb fields = foldM parseField mempty (filter hasOptionsSuffix $ Map.toList fields) where parseField programArgs (fieldName, fieldLines) = do case readProgramName "-options" programDb fieldName of - Nothing -> case warnLevel of - Ignore -> return programArgs - Warn -> warnUnknownFields fieldName fieldLines >> return programArgs + Nothing -> warnUnknownFields fieldName fieldLines >> return programArgs Just program -> do args <- parseProgramArgsField fieldLines return $ programArgs <> MapMappend (Map.singleton program args) + hasOptionsSuffix (fieldName, _) = BS.isSuffixOf "-options" fieldName -- | Parse fields of a program-locations stanza. -parseProgramPaths :: WarnUnknownFields -> ProgramDb -> Fields Position -> ParseResult (MapLast String FilePath) -parseProgramPaths warnLevel programDb fields = foldM parseField mempty (Map.toList fields) +parseProgramPaths :: ProgramDb -> Fields Position -> ParseResult (MapLast String FilePath) +parseProgramPaths programDb fields = foldM parseField mempty (filter hasLocationSuffix $ Map.toList fields) where parseField paths (fieldName, fieldLines) = do case readProgramName "-location" programDb fieldName of - Nothing -> case warnLevel of - Ignore -> return paths - Warn -> warnUnknownFields fieldName fieldLines >> return paths + Nothing -> warnUnknownFields fieldName fieldLines >> return paths Just program -> do case fieldLines of (MkNamelessField pos lines') : _ -> do fp <- runFieldParser pos parsecFilePath cabalSpec lines' return $ paths <> MapLast (Map.singleton program fp) [] -> return mempty + hasLocationSuffix (fieldName, _) = BS.isSuffixOf "-location" fieldName -- | Parse all arguments to a single program in program-options stanza. -- By processing '[NamelessField Position]', we support multiple occurrences of the field, concatenating the arguments. From a0f82c03a16bec80cb30591a93fe7e1da000ef29 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Sun, 11 Aug 2024 22:25:42 +0200 Subject: [PATCH 19/41] Fix imports of test --- .../PackageTests/ProjectConfig/Parsec/cabal.test.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs index 56cf68ca0b7..3e619a5493c 100644 --- a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs @@ -2,10 +2,10 @@ {-# LANGUAGE RecordWildCards #-} import qualified Data.ByteString as BS -import Data.Either +import Data.Either (fromRight) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map as Map -import Data.Maybe +import Data.Maybe (fromJust) import qualified Data.Set as Set import Distribution.Client.BuildReports.Types (ReportLevel (..)) import Distribution.Client.CmdInstall.ClientInstallFlags (ClientInstallFlags (..)) @@ -55,8 +55,7 @@ import Distribution.Types.VersionRange.Internal (VersionRange (..)) import Distribution.Utils.NubList import Distribution.Verbosity import Network.URI (parseURI) -import System.Directory -import System.FilePath +import System.Directory (canonicalizePath, doesFileExist) import Test.Cabal.Prelude hiding (cabal) import qualified Test.Cabal.Prelude as P From 37d592c33b699d2d5cca0ec3ce0307563451ac61 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Sun, 11 Aug 2024 23:43:53 +0200 Subject: [PATCH 20/41] Add parsing of profiling-shared and use-unicode --- .../src/Distribution/Client/ProjectConfig/FieldGrammar.hs | 2 ++ .../src/Distribution/Client/ProjectConfig/Lens.hs | 8 ++++++++ .../PackageTests/ProjectConfig/Parsec/cabal.test.hs | 2 ++ .../tests/project-config-local-packages/cabal.project | 2 ++ 4 files changed, 14 insertions(+) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs index dcc888037f3..ab30818d2cf 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs @@ -121,6 +121,7 @@ packageConfigFieldGrammar knownPrograms = <*> optionalFieldDef "executable-static" L.packageConfigFullyStaticExe mempty <*> optionalFieldDef "profiling" L.packageConfigProf mempty <*> optionalFieldDef "library-profiling" L.packageConfigProfLib mempty + <*> optionalFieldDef "profiling-shared" L.packageConfigProfShared mempty <*> optionalFieldDef "executable-profiling" L.packageConfigProfExe mempty <*> optionalFieldDef "profiling-detail" L.packageConfigProfDetail mempty <*> optionalFieldDef "library-profiling-detail" L.packageConfigProfLibDetail mempty @@ -162,6 +163,7 @@ packageConfigFieldGrammar knownPrograms = <*> optionalFieldDefAla "haddock-base-url" (alaFlag Token) L.packageConfigHaddockBaseUrl mempty <*> optionalFieldDefAla "haddock-resources-dir" (alaFlag Token) L.packageConfigHaddockResourcesDir mempty <*> optionalFieldDefAla "haddock-output-dir" (alaFlag FilePathNT) L.packageConfigHaddockOutputDir mempty + <*> optionalFieldDef "haddock-use-unicode" L.packageConfigHaddockUseUnicode mempty <*> optionalFieldDef "haddock-for-hackage" L.packageConfigHaddockForHackage mempty <*> optionalFieldDef "test-log" L.packageConfigTestHumanLog mempty <*> optionalFieldDef "test-machine-log" L.packageConfigTestMachineLog mempty diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs index cebf2993ea2..cb6c2c60fa9 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs @@ -348,6 +348,10 @@ packageConfigProfLib :: Lens' PackageConfig (Flag Bool) packageConfigProfLib f s = fmap (\x -> s{T.packageConfigProfLib = x}) (f (T.packageConfigProfLib s)) {-# INLINEABLE packageConfigProfLib #-} +packageConfigProfShared :: Lens' PackageConfig (Flag Bool) +packageConfigProfShared f s = fmap (\x -> s{T.packageConfigProfShared = x}) (f (T.packageConfigProfShared s)) +{-# INLINEABLE packageConfigProfShared #-} + packageConfigProfExe :: Lens' PackageConfig (Flag Bool) packageConfigProfExe f s = fmap (\x -> s{T.packageConfigProfExe = x}) (f (T.packageConfigProfExe s)) {-# INLINEABLE packageConfigProfExe #-} @@ -512,6 +516,10 @@ packageConfigHaddockOutputDir :: Lens' PackageConfig (Flag FilePath) packageConfigHaddockOutputDir f s = fmap (\x -> s{T.packageConfigHaddockOutputDir = x}) (f (T.packageConfigHaddockOutputDir s)) {-# INLINEABLE packageConfigHaddockOutputDir #-} +packageConfigHaddockUseUnicode :: Lens' PackageConfig (Flag Bool) +packageConfigHaddockUseUnicode f s = fmap (\x -> s{T.packageConfigHaddockUseUnicode = x}) (f (T.packageConfigHaddockUseUnicode s)) +{-# INLINEABLE packageConfigHaddockUseUnicode #-} + packageConfigHaddockForHackage :: Lens' PackageConfig (Flag HaddockTarget) packageConfigHaddockForHackage f s = fmap (\x -> s{T.packageConfigHaddockForHackage = x}) (f (T.packageConfigHaddockForHackage s)) {-# INLINEABLE packageConfigHaddockForHackage #-} diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs index 3e619a5493c..869f7aee7d7 100644 --- a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs @@ -344,6 +344,7 @@ testProjectConfigLocalPackages = do packageConfigFullyStaticExe = Flag True packageConfigProf = Flag True packageConfigProfLib = Flag True + packageConfigProfShared = Flag False packageConfigProfExe = Flag True packageConfigProfDetail = Flag ProfDetailAllFunctions packageConfigProfLibDetail = Flag ProfDetailExportedFunctions @@ -386,6 +387,7 @@ testProjectConfigLocalPackages = do packageConfigHaddockBaseUrl = Flag "https://example.com/haddock-base-url" packageConfigHaddockResourcesDir = Flag "/haddock/static" packageConfigHaddockOutputDir = Flag "/haddock/output" + packageConfigHaddockUseUnicode = Flag False packageConfigHaddockForHackage = Flag ForHackage packageConfigTestHumanLog = Flag $ toPathTemplate "human-log.log" packageConfigTestMachineLog = Flag $ toPathTemplate "machine.log" diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-local-packages/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-local-packages/cabal.project index b173b3dc45e..77ffb93ff00 100644 --- a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-local-packages/cabal.project +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-local-packages/cabal.project @@ -15,6 +15,7 @@ executable-dynamic: True executable-static: True profiling: True library-profiling: True +profiling-shared: False executable-profiling: True profiling-detail: all-functions library-profiling-detail: exported-functions @@ -56,6 +57,7 @@ haddock-index-location: separately-generated/HTML/index haddock-base-url: https://example.com/haddock-base-url haddock-resources-dir: /haddock/static haddock-output-dir: /haddock/output +haddock-use-unicode: False haddock-for-hackage: for-hackage test-log: human-log.log From b727bd095239c7ab528176ca33d1130cdb70aa15 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Tue, 13 Aug 2024 15:43:55 +0200 Subject: [PATCH 21/41] Add changelog --- changelog.d/pr-8889 | 13 +++++++++++++ 1 file changed, 13 insertions(+) create mode 100644 changelog.d/pr-8889 diff --git a/changelog.d/pr-8889 b/changelog.d/pr-8889 new file mode 100644 index 00000000000..08d3370e86b --- /dev/null +++ b/changelog.d/pr-8889 @@ -0,0 +1,13 @@ +synopsis: Replace cabal project parsing with Parsec +packages: cabal-install Cabal Cabal-syntax +prs: #8889 +issues: #6101 #7748 + +description: { + +Replaced the legacy cabal.project parser with a new implementation based on Parsec. +The new parser replicates the grammar of the legacy parser, ensuring that it generates identical ProjectConfig values for the same input. +The implementation leverages existing Parsec infrastructure, including FieldGrammar and other utilities from the .cabal file parser. +Legacy parsing functions are still accessible but will be removed in the future. + +} From 55d576543dc2db5e97ead0ec6f875c1ee11b8602 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Thu, 22 Aug 2024 19:47:51 +0200 Subject: [PATCH 22/41] Migrate ParserTests to cabal-install/parser-tests --- cabal-install/cabal-install.cabal | 19 ++ cabal-install/parser-tests/Tests.hs | 7 + .../parser-tests/Tests/ParserTests.hs | 310 +++++++++--------- .../files}/all-packages-concat/cabal.project | 0 .../Tests/files}/empty/cabal.project | 0 .../Tests/files}/extra-packages/cabal.project | 0 .../Tests/files}/install-dirs/cabal.project | 0 .../files}/local-no-index-repos/cabal.project | 0 .../files}/optional-packages/cabal.project | 0 .../Tests/files}/packages/cabal.project | 0 .../program-locations-concat/cabal.project | 0 .../program-options-concat/cabal.project | 0 .../project-config-all-packages/cabal.project | 0 .../project-config-build-only/cabal.project | 0 .../cabal.project | 0 .../project-config-shared/cabal.project | 0 .../cabal.project | 0 .../Tests/files}/remote-repos/cabal.project | 0 .../source-repository-packages/cabal.project | 0 .../specific-packages-concat/cabal.project | 0 cabal-testsuite/cabal-testsuite.cabal | 3 - 21 files changed, 180 insertions(+), 159 deletions(-) create mode 100644 cabal-install/parser-tests/Tests.hs rename cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs => cabal-install/parser-tests/Tests/ParserTests.hs (73%) rename {cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests => cabal-install/parser-tests/Tests/files}/all-packages-concat/cabal.project (100%) rename {cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests => cabal-install/parser-tests/Tests/files}/empty/cabal.project (100%) rename {cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests => cabal-install/parser-tests/Tests/files}/extra-packages/cabal.project (100%) rename {cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests => cabal-install/parser-tests/Tests/files}/install-dirs/cabal.project (100%) rename {cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests => cabal-install/parser-tests/Tests/files}/local-no-index-repos/cabal.project (100%) rename {cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests => cabal-install/parser-tests/Tests/files}/optional-packages/cabal.project (100%) rename {cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests => cabal-install/parser-tests/Tests/files}/packages/cabal.project (100%) rename {cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests => cabal-install/parser-tests/Tests/files}/program-locations-concat/cabal.project (100%) rename {cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests => cabal-install/parser-tests/Tests/files}/program-options-concat/cabal.project (100%) rename {cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests => cabal-install/parser-tests/Tests/files}/project-config-all-packages/cabal.project (100%) rename {cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests => cabal-install/parser-tests/Tests/files}/project-config-build-only/cabal.project (100%) rename {cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests => cabal-install/parser-tests/Tests/files}/project-config-local-packages/cabal.project (100%) rename {cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests => cabal-install/parser-tests/Tests/files}/project-config-shared/cabal.project (100%) rename {cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests => cabal-install/parser-tests/Tests/files}/project-config-specific-packages/cabal.project (100%) rename {cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests => cabal-install/parser-tests/Tests/files}/remote-repos/cabal.project (100%) rename {cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests => cabal-install/parser-tests/Tests/files}/source-repository-packages/cabal.project (100%) rename {cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests => cabal-install/parser-tests/Tests/files}/specific-packages-concat/cabal.project (100%) diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 50c7a60c6bc..2d757e665be 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -370,6 +370,25 @@ test-suite unit-tests tree-diff, QuickCheck >= 2.14.3 && <2.16 +-- Tests for the project file parser +test-suite parser-tests + import: warnings, base-dep, cabal-dep, cabal-syntax-dep, cabal-install-solver-dep + default-language: Haskell2010 + ghc-options: -rtsopts -threaded + + type: exitcode-stdio-1.0 + main-is: Tests.hs + hs-source-dirs: parser-tests + build-depends: + cabal-install, + containers, + directory, + filepath, + network-uri >= 2.6.2.0 && <2.7, + tasty >= 1.2.3 && <1.6, + tasty-hunit >= 0.10, + other-modules: + Tests.ParserTests -- Tests to run with a limited stack and heap size -- The test suite name must be keep short cause a longer one diff --git a/cabal-install/parser-tests/Tests.hs b/cabal-install/parser-tests/Tests.hs new file mode 100644 index 00000000000..f5655ad5389 --- /dev/null +++ b/cabal-install/parser-tests/Tests.hs @@ -0,0 +1,7 @@ +module Main where + +import Test.Tasty (defaultMain) +import Tests.ParserTests (parserTests) + +main :: IO () +main = defaultMain parserTests diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs b/cabal-install/parser-tests/Tests/ParserTests.hs similarity index 73% rename from cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs rename to cabal-install/parser-tests/Tests/ParserTests.hs index 869f7aee7d7..fe00940a711 100644 --- a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -1,9 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -import qualified Data.ByteString as BS +-- | Tests for the project file parser +module Tests.ParserTests (parserTests) where + +import Control.Monad.IO.Class + ( MonadIO (liftIO) + ) import Data.Either (fromRight) -import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map as Map import Data.Maybe (fromJust) import qualified Data.Set as Set @@ -15,7 +19,6 @@ import Distribution.Client.HttpUtils import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepoEntry (..), ActiveRepos (..), CombineStrategy (..)) import Distribution.Client.IndexUtils.IndexState (RepoIndexState (..), headTotalIndexState, insertIndexState) import Distribution.Client.ProjectConfig -import Distribution.Client.ProjectConfig.Parsec import Distribution.Client.RebuildMonad (runRebuild) import Distribution.Client.Targets (readUserConstraint) import Distribution.Client.Types.AllowNewer (AllowNewer (..), AllowOlder (..), RelaxDepMod (..), RelaxDepScope (..), RelaxDepSubject (..), RelaxDeps (..), RelaxedDep (..)) @@ -25,12 +28,13 @@ import Distribution.Client.Types.Repo (LocalRepo (..), RemoteRepo (..)) import Distribution.Client.Types.RepoName (RepoName (..)) import Distribution.Client.Types.SourceRepo import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy (WriteGhcEnvironmentFilesPolicy (..)) +import Distribution.Compat.Prelude import Distribution.Compiler (CompilerFlavor (..)) import Distribution.Parsec (simpleParsec) import Distribution.Simple.Compiler (DebugInfoLevel (..), OptimisationLevel (..), PackageDB (..), ProfDetailLevel (..)) import Distribution.Simple.Flag import Distribution.Simple.InstallDirs (InstallDirs (..), toPathTemplate) -import Distribution.Simple.Setup (DumpBuildInfo (..), Flag, HaddockTarget (..), TestShowDetails (..)) +import Distribution.Simple.Setup (DumpBuildInfo (..), HaddockTarget (..), TestShowDetails (..)) import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) import Distribution.Solver.Types.ProjectConfigPath (ProjectConfigPath (..)) import Distribution.Solver.Types.Settings @@ -45,7 +49,7 @@ import Distribution.Solver.Types.Settings , StrongFlags (..) ) import Distribution.Types.CondTree (CondTree (..)) -import Distribution.Types.Flag (FlagAssignment (..), FlagName, mkFlagAssignment) +import Distribution.Types.Flag (mkFlagAssignment) import Distribution.Types.PackageId (PackageIdentifier (..)) import Distribution.Types.PackageName import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..)) @@ -56,81 +60,87 @@ import Distribution.Utils.NubList import Distribution.Verbosity import Network.URI (parseURI) import System.Directory (canonicalizePath, doesFileExist) +import System.FilePath (()) +import Prelude () -import Test.Cabal.Prelude hiding (cabal) -import qualified Test.Cabal.Prelude as P +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, testCase) -main = do - cabalTest' "read packages" testPackages - cabalTest' "read optional-packages" testOptionalPackages - cabalTest' "read extra-packages" testExtraPackages - cabalTest' "read source-repository-package" testSourceRepoList - cabalTest' "read project-config-build-only" testProjectConfigBuildOnly - cabalTest' "read project-config-shared" testProjectConfigShared - cabalTest' "read install-dirs" testInstallDirs - cabalTest' "read remote-repos" testRemoteRepos - cabalTest' "read local-no-index-repos" testLocalNoIndexRepos - cabalTest' "set explicit provenance" testProjectConfigProvenance - cabalTest' "read project-config-local-packages" testProjectConfigLocalPackages - cabalTest' "read project-config-all-packages" testProjectConfigAllPackages - cabalTest' "read project-config-specific-packages" testProjectConfigSpecificPackages - cabalTest' "test projectConfigAllPackages concatenation" testAllPackagesConcat - cabalTest' "test projectConfigSpecificPackages concatenation" testSpecificPackagesConcat - cabalTest' "test program-locations concatenation" testProgramLocationsConcat - cabalTest' "test program-options concatenation" testProgramOptionsConcat +parserTests :: TestTree +parserTests = + testGroup + "project files parsec tests" + [ testCase "read packages" testPackages + , testCase "read optional-packages" testOptionalPackages + , testCase "read extra-packages" testExtraPackages + , testCase "read source-repository-package" testSourceRepoList + , testCase "read project-config-build-only" testProjectConfigBuildOnly + , testCase "read project-config-shared" testProjectConfigShared + , testCase "read install-dirs" testInstallDirs + , testCase "read remote-repos" testRemoteRepos + , testCase "read local-no-index-repos" testLocalNoIndexRepos + , testCase "set explicit provenance" testProjectConfigProvenance + , testCase "read project-config-local-packages" testProjectConfigLocalPackages + , testCase "read project-config-all-packages" testProjectConfigAllPackages + , testCase "read project-config-specific-packages" testProjectConfigSpecificPackages + , testCase "test projectConfigAllPackages concatenation" testAllPackagesConcat + , testCase "test projectConfigSpecificPackages concatenation" testSpecificPackagesConcat + , testCase "test program-locations concatenation" testProgramLocationsConcat + , testCase "test program-options concatenation" testProgramOptionsConcat + ] -testPackages :: TestM () +testPackages :: Assertion testPackages = do let expected = [".", "packages/packages.cabal"] - -- Note that I currently also run the legacy parser to make sure my expected values - -- do not differ from the non-Parsec implementation, this will be removed in the future (config, legacy) <- readConfigDefault "packages" - assertConfig expected config legacy (projectPackages . condTreeData) + assertConfigEquals expected config legacy (projectPackages . condTreeData) -testOptionalPackages :: TestM () +testOptionalPackages :: Assertion testOptionalPackages = do let expected = [".", "packages/packages.cabal"] (config, legacy) <- readConfigDefault "optional-packages" - assertConfig expected config legacy (projectPackagesOptional . condTreeData) + assertConfigEquals expected config legacy (projectPackagesOptional . condTreeData) -testSourceRepoList :: TestM () +testSourceRepoList :: Assertion testSourceRepoList = do - let expected = - [ SourceRepositoryPackage - { srpType = KnownRepoType Git - , srpLocation = "https://example.com/Project.git" - , srpTag = Just "1234" - , srpBranch = Nothing - , srpSubdir = [] - , srpCommand = [] - } - , SourceRepositoryPackage - { srpType = KnownRepoType Git - , srpLocation = "https://example.com/example-dir/" - , srpTag = Just "12345" - , srpBranch = Nothing - , srpSubdir = ["subproject"] - , srpCommand = [] - } - ] (config, legacy) <- readConfigDefault "source-repository-packages" - assertConfig expected config legacy (projectPackagesRepo . condTreeData) + assertConfigEquals expected config legacy (projectPackagesRepo . condTreeData) + where + expected = + [ SourceRepositoryPackage + { srpType = KnownRepoType Git + , srpLocation = "https://example.com/Project.git" + , srpTag = Just "1234" + , srpBranch = Nothing + , srpSubdir = [] + , srpCommand = [] + } + , SourceRepositoryPackage + { srpType = KnownRepoType Git + , srpLocation = "https://example.com/example-dir/" + , srpTag = Just "12345" + , srpBranch = Nothing + , srpSubdir = ["subproject"] + , srpCommand = [] + } + ] -testExtraPackages :: TestM () +testExtraPackages :: Assertion testExtraPackages = do - let expected = - [ PackageVersionConstraint (mkPackageName "a") (OrLaterVersion (mkVersion [0])) - , PackageVersionConstraint (mkPackageName "b") (IntersectVersionRanges (OrLaterVersion (mkVersion [0, 7, 3])) (EarlierVersion (mkVersion [0, 9]))) - ] (config, legacy) <- readConfigDefault "extra-packages" - assertConfig expected config legacy (projectPackagesNamed . condTreeData) + assertConfigEquals expected config legacy (projectPackagesNamed . condTreeData) + where + expected = + [ PackageVersionConstraint (mkPackageName "a") (OrLaterVersion (mkVersion [0])) + , PackageVersionConstraint (mkPackageName "b") (IntersectVersionRanges (OrLaterVersion (mkVersion [0, 7, 3])) (EarlierVersion (mkVersion [0, 9]))) + ] -testProjectConfigBuildOnly :: TestM () +testProjectConfigBuildOnly :: Assertion testProjectConfigBuildOnly = do - let expected = ProjectConfigBuildOnly{..} (config, legacy) <- readConfigDefault "project-config-build-only" - assertConfig expected config legacy (projectConfigBuildOnly . condTreeData) + assertConfigEquals expected config legacy (projectConfigBuildOnly . condTreeData) where + expected = ProjectConfigBuildOnly{..} projectConfigVerbosity = toFlag (toEnum 2) projectConfigDryRun = mempty -- cli only projectConfigOnlyDeps = mempty -- cli only @@ -158,16 +168,12 @@ testProjectConfigBuildOnly = do , cinstInstalldir = Flag "path/to/installdir" } -testProjectConfigShared :: TestM () +testProjectConfigShared :: Assertion testProjectConfigShared = do - let rootFp = "project-config-shared" - testDir <- testDirInfo rootFp "cabal.project" - let - projectConfigConstraints = getProjectConfigConstraints (testDirProjectConfigFp testDir) - expected = ProjectConfigShared{..} - (config, legacy) <- readConfigDefault rootFp - assertConfig expected config legacy (projectConfigShared . condTreeData) + (config, legacy) <- readConfigDefault "project-config-shared" + assertConfigEquals expected config legacy (projectConfigShared . condTreeData) where + expected = ProjectConfigShared{..} projectConfigDistDir = toFlag "something" projectConfigConfigFile = mempty -- cli only projectConfigProjectDir = toFlag "my-project-dir" @@ -191,7 +197,7 @@ testProjectConfigShared = do in toFlag indexState'' projectConfigStoreDir = toFlag "a/store/dir/path" -- cli only - getProjectConfigConstraints projectFileFp = + projectConfigConstraints = let bar = fromRight (error "error parsing bar") $ readUserConstraint "bar == 2.1" barFlags = fromRight (error "error parsing bar flags") $ readUserConstraint "bar +foo -baz" @@ -218,11 +224,10 @@ testProjectConfigShared = do projectConfigProgPathExtra = toNubList ["/foo/bar", "/baz/quux"] projectConfigMultiRepl = toFlag True -testInstallDirs :: TestM () +testInstallDirs :: Assertion testInstallDirs = do - let rootFp = "install-dirs" - (config, legacy) <- readConfigDefault rootFp - assertConfig expected config legacy (projectConfigInstallDirs . projectConfigShared . condTreeData) + (config, legacy) <- readConfigDefault "install-dirs" + assertConfigEquals expected config legacy (projectConfigInstallDirs . projectConfigShared . condTreeData) where expected = InstallDirs @@ -244,13 +249,12 @@ testInstallDirs = do , sysconfdir = Flag $ toPathTemplate "sys/conf/dir" } -testRemoteRepos :: TestM () +testRemoteRepos :: Assertion testRemoteRepos = do - let rootFp = "remote-repos" - (config, legacy) <- readConfigDefault rootFp + (config, legacy) <- readConfigDefault "remote-repos" let actualRemoteRepos = (fromNubList . projectConfigRemoteRepos . projectConfigShared . condTreeData) config assertBool "Expected RemoteRepos do not match parsed values" $ compareLists expected actualRemoteRepos compareRemoteRepos - assertConfig mempty config legacy (projectConfigLocalNoIndexRepos . projectConfigShared . condTreeData) + assertConfigEquals mempty config legacy (projectConfigLocalNoIndexRepos . projectConfigShared . condTreeData) where expected = [packagesRepository, morePackagesRepository, secureLocalRepository] packagesRepository = @@ -281,22 +285,12 @@ testRemoteRepos = do , remoteRepoShouldTryHttps = False } --- We do not parse remoteRepoShouldTryHttps, so we skip it -compareRemoteRepos :: RemoteRepo -> RemoteRepo -> Bool -compareRemoteRepos repo1 repo2 = - remoteRepoName repo1 == remoteRepoName repo2 - && remoteRepoURI repo1 == remoteRepoURI repo2 - && remoteRepoSecure repo1 == remoteRepoSecure repo2 - && remoteRepoRootKeys repo1 == remoteRepoRootKeys repo2 - && remoteRepoKeyThreshold repo1 == remoteRepoKeyThreshold repo2 - -testLocalNoIndexRepos :: TestM () +testLocalNoIndexRepos :: Assertion testLocalNoIndexRepos = do - let rootFp = "local-no-index-repos" - (config, legacy) <- readConfigDefault rootFp + (config, legacy) <- readConfigDefault "local-no-index-repos" let actualLocalRepos = (fromNubList . projectConfigLocalNoIndexRepos . projectConfigShared . condTreeData) config assertBool "Expected LocalNoIndexRepos do not match parsed values" $ compareLists expected actualLocalRepos compareLocalRepos - assertConfig mempty config legacy (projectConfigRemoteRepos . projectConfigShared . condTreeData) + assertConfigEquals mempty config legacy (projectConfigRemoteRepos . projectConfigShared . condTreeData) where expected = [myRepository, mySecureRepository] myRepository = @@ -312,27 +306,18 @@ testLocalNoIndexRepos = do , localRepoSharedCache = False } --- We do not parse localRepoSharedCache, so we skip it -compareLocalRepos :: LocalRepo -> LocalRepo -> Bool -compareLocalRepos repo1 repo2 = - localRepoName repo1 == localRepoName repo2 - && localRepoPath repo1 == localRepoPath repo2 - -testProjectConfigProvenance :: TestM () +testProjectConfigProvenance :: Assertion testProjectConfigProvenance = do - let rootFp = "empty" - let - expected = Set.singleton (Explicit (ProjectConfigPath $ "cabal.project" :| [])) - (config, legacy) <- readConfigDefault rootFp - assertConfig expected config legacy (projectConfigProvenance . condTreeData) + let expected = Set.singleton (Explicit (ProjectConfigPath $ "cabal.project" :| [])) + (config, legacy) <- readConfigDefault "empty" + assertConfigEquals expected config legacy (projectConfigProvenance . condTreeData) -testProjectConfigLocalPackages :: TestM () +testProjectConfigLocalPackages :: Assertion testProjectConfigLocalPackages = do - let rootFp = "project-config-local-packages" - let expected = PackageConfig{..} - (config, legacy) <- readConfigDefault rootFp - assertConfig expected config legacy (projectConfigLocalPackages . condTreeData) + (config, legacy) <- readConfigDefault "project-config-local-packages" + assertConfigEquals expected config legacy (projectConfigLocalPackages . condTreeData) where + expected = PackageConfig{..} packageConfigProgramPaths = MapLast $ Map.fromList [("ghc", "/tmp/bin/ghc"), ("gcc", "/tmp/bin/gcc")] packageConfigProgramArgs = MapMappend $ Map.fromList [("ghc", ["-fno-state-hack", "-foo"]), ("gcc", ["-baz", "-quux"])] packageConfigProgramPathExtra = toNubList ["/tmp/bin/extra", "/usr/local/bin"] @@ -398,11 +383,10 @@ testProjectConfigLocalPackages = do packageConfigTestTestOptions = [toPathTemplate "--some-option", toPathTemplate "42"] packageConfigBenchmarkOptions = [toPathTemplate "--some-benchmark-option", toPathTemplate "--another-option"] -testProjectConfigAllPackages :: TestM () +testProjectConfigAllPackages :: Assertion testProjectConfigAllPackages = do - let rootFp = "project-config-all-packages" - (config, legacy) <- readConfigDefault rootFp - assertConfig expected config legacy (projectConfigAllPackages . condTreeData) + (config, legacy) <- readConfigDefault "project-config-all-packages" + assertConfigEquals expected config legacy (projectConfigAllPackages . condTreeData) where expected :: PackageConfig expected = @@ -411,11 +395,10 @@ testProjectConfigAllPackages = do , packageConfigProfLibDetail = Flag ProfDetailExportedFunctions } -testProjectConfigSpecificPackages :: TestM () +testProjectConfigSpecificPackages :: Assertion testProjectConfigSpecificPackages = do - let rootFp = "project-config-specific-packages" - (config, legacy) <- readConfigDefault rootFp - assertConfig expected config legacy (projectConfigSpecificPackage . condTreeData) + (config, legacy) <- readConfigDefault "project-config-specific-packages" + assertConfigEquals expected config legacy (projectConfigSpecificPackage . condTreeData) where expected = MapMappend $ Map.fromList [("foo", expectedFoo), ("bar", expectedBar), ("baz", expectedBaz)] expectedFoo :: PackageConfig @@ -438,11 +421,10 @@ testProjectConfigSpecificPackages = do { packageConfigSharedLib = Flag True } -testAllPackagesConcat :: TestM () +testAllPackagesConcat :: Assertion testAllPackagesConcat = do - let rootFp = "all-packages-concat" - (config, legacy) <- readConfigDefault rootFp - assertConfig expected config legacy (projectConfigAllPackages . condTreeData) + (config, legacy) <- readConfigDefault "all-packages-concat" + assertConfigEquals expected config legacy (projectConfigAllPackages . condTreeData) where expected :: PackageConfig expected = @@ -452,11 +434,10 @@ testAllPackagesConcat = do , packageConfigProgramArgs = MapMappend $ Map.fromList [("ghc", ["-fwarn-tabs", "-Wall"])] } -testSpecificPackagesConcat :: TestM () +testSpecificPackagesConcat :: Assertion testSpecificPackagesConcat = do - let rootFp = "specific-packages-concat" - (config, legacy) <- readConfigDefault rootFp - assertConfig expected config legacy (projectConfigSpecificPackage . condTreeData) + (config, legacy) <- readConfigDefault "specific-packages-concat" + assertConfigEquals expected config legacy (projectConfigSpecificPackage . condTreeData) where expected = MapMappend $ Map.fromList [("foo", expectedFoo)] expectedFoo :: PackageConfig @@ -467,11 +448,10 @@ testSpecificPackagesConcat = do , packageConfigProgramArgs = MapMappend $ Map.fromList [("ghc", ["-fno-state-hack", "-threaded"])] } -testProgramLocationsConcat :: TestM () +testProgramLocationsConcat :: Assertion testProgramLocationsConcat = do - let rootFp = "program-locations-concat" - (config, legacy) <- readConfigDefault rootFp - assertConfig expected config legacy (projectConfigLocalPackages . condTreeData) + (config, legacy) <- readConfigDefault "program-locations-concat" + assertConfigEquals expected config legacy (projectConfigLocalPackages . condTreeData) where expected :: PackageConfig expected = @@ -479,11 +459,10 @@ testProgramLocationsConcat = do { packageConfigProgramPaths = MapLast $ Map.fromList [("gcc", "/tmp/bin/gcc"), ("ghc", "/tmp/bin/ghc")] } -testProgramOptionsConcat :: TestM () +testProgramOptionsConcat :: Assertion testProgramOptionsConcat = do - let rootFp = "program-options-concat" - (config, legacy) <- readConfigDefault rootFp - assertConfig expected config legacy (projectConfigLocalPackages . condTreeData) + (config, legacy) <- readConfigDefault "program-options-concat" + assertConfigEquals expected config legacy (projectConfigLocalPackages . condTreeData) where expected :: PackageConfig expected = @@ -491,10 +470,19 @@ testProgramOptionsConcat = do { packageConfigProgramArgs = MapMappend $ Map.fromList [("ghc", ["-threaded", "-Wall", "-fno-state-hack"]), ("gcc", ["-baz", "-foo", "-bar"])] } -readConfigDefault :: FilePath -> TestM (ProjectConfigSkeleton, ProjectConfigSkeleton) +------------------------------------------------------------------------------- +-- Test Utilities +------------------------------------------------------------------------------- +baseDir :: FilePath +baseDir = "parser-tests" "Tests" "files" + +verbosity :: Verbosity +verbosity = normal + +readConfigDefault :: FilePath -> IO (ProjectConfigSkeleton, ProjectConfigSkeleton) readConfigDefault testSubDir = readConfig testSubDir "cabal.project" -readConfig :: FilePath -> FilePath -> TestM (ProjectConfigSkeleton, ProjectConfigSkeleton) +readConfig :: FilePath -> FilePath -> IO (ProjectConfigSkeleton, ProjectConfigSkeleton) readConfig testSubDir projectFileName = do (TestDir testRootFp projectConfigFp distDirLayout) <- testDirInfo testSubDir projectFileName exists <- liftIO $ doesFileExist projectConfigFp @@ -512,38 +500,48 @@ readConfig testSubDir projectFileName = do readProjectFileSkeletonLegacy verbosity httpTransport distDirLayout extensionName extensionDescription return (parsec, legacy) +assertConfigEquals :: (Eq a, Show a) => a -> ProjectConfigSkeleton -> ProjectConfigSkeleton -> (ProjectConfigSkeleton -> a) -> Assertion +assertConfigEquals expected config configLegacy access = do + assertEqual "Expectation does not match result of Legacy parser" expected actualLegacy + assertEqual "Parsed Config does not match expected" expected actual + where + actual = access config + actualLegacy = access configLegacy + +-- | Represents the directory structure and associated file paths for a test data TestDir = TestDir - { testDirTestRootFp :: FilePath - -- ^ Every test has its own root in ./tests/ - , testDirProjectConfigFp :: FilePath + { _testDirTestRootFp :: FilePath + -- ^ Every test has a root directory in ./files/ + , _testDirProjectConfigFp :: FilePath -- ^ Every test has a project config in testDirTestRootFp/cabal.project - , testDirDistDirLayout :: DistDirLayout + , _testDirDistDirLayout :: DistDirLayout } -testDirInfo :: FilePath -> FilePath -> TestM TestDir +testDirInfo :: FilePath -> FilePath -> IO TestDir testDirInfo testSubDir projectFileName = do - testEnv <- getTestEnv - testRootFp <- liftIO $ canonicalizePath (testCurrentDir testEnv "tests" testSubDir) + projectRootDir <- canonicalizePath (baseDir testSubDir) let - projectRoot = ProjectRootExplicit testRootFp projectFileName + projectRoot = ProjectRootExplicit projectRootDir projectFileName distDirLayout = defaultDistDirLayout projectRoot Nothing Nothing extensionName = "" projectConfigFp = distProjectFile distDirLayout extensionName - return $ TestDir testRootFp projectConfigFp distDirLayout - where - extensionName = "" + return $ TestDir projectRootDir projectConfigFp distDirLayout -assertConfig :: (Eq a, Show a) => a -> ProjectConfigSkeleton -> ProjectConfigSkeleton -> (ProjectConfigSkeleton -> a) -> TestM () -assertConfig expected config configLegacy access = do - assertEqual "Expectation does not match result of Legacy parser" expected actualLegacy - assertEqual "Parsed Config does not match expected" expected actual - where - actual = access config - actualLegacy = access configLegacy +-- | Compares two lists element-wise using a comparison function. +compareLists :: [a] -> [a] -> (a -> a -> Bool) -> Bool +compareLists xs ys compare' = length xs == length ys && all (uncurry compare') (zip xs ys) --- | Test Utilities -verbosity :: Verbosity -verbosity = normal -- minBound --normal --verbose --maxBound --minBound +-- | Compares LocalRepos ignoring field 'localRepoSharedCache' because we do not parse it. +compareLocalRepos :: LocalRepo -> LocalRepo -> Bool +compareLocalRepos repo1 repo2 = + localRepoName repo1 == localRepoName repo2 + && localRepoPath repo1 == localRepoPath repo2 -compareLists :: [a] -> [a] -> (a -> a -> Bool) -> Bool -compareLists xs ys compare = length xs == length ys && all (uncurry compare) (zip xs ys) +-- | Compares RemoteRepos ignoring field 'remoteRepoShouldTryHttps' because we do not parse it. +compareRemoteRepos :: RemoteRepo -> RemoteRepo -> Bool +compareRemoteRepos repo1 repo2 = + remoteRepoName repo1 == remoteRepoName repo2 + && remoteRepoURI repo1 == remoteRepoURI repo2 + && remoteRepoSecure repo1 == remoteRepoSecure repo2 + && remoteRepoRootKeys repo1 == remoteRepoRootKeys repo2 + && remoteRepoKeyThreshold repo1 == remoteRepoKeyThreshold repo2 diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/all-packages-concat/cabal.project b/cabal-install/parser-tests/Tests/files/all-packages-concat/cabal.project similarity index 100% rename from cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/all-packages-concat/cabal.project rename to cabal-install/parser-tests/Tests/files/all-packages-concat/cabal.project diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/empty/cabal.project b/cabal-install/parser-tests/Tests/files/empty/cabal.project similarity index 100% rename from cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/empty/cabal.project rename to cabal-install/parser-tests/Tests/files/empty/cabal.project diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/extra-packages/cabal.project b/cabal-install/parser-tests/Tests/files/extra-packages/cabal.project similarity index 100% rename from cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/extra-packages/cabal.project rename to cabal-install/parser-tests/Tests/files/extra-packages/cabal.project diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/install-dirs/cabal.project b/cabal-install/parser-tests/Tests/files/install-dirs/cabal.project similarity index 100% rename from cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/install-dirs/cabal.project rename to cabal-install/parser-tests/Tests/files/install-dirs/cabal.project diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/local-no-index-repos/cabal.project b/cabal-install/parser-tests/Tests/files/local-no-index-repos/cabal.project similarity index 100% rename from cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/local-no-index-repos/cabal.project rename to cabal-install/parser-tests/Tests/files/local-no-index-repos/cabal.project diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/optional-packages/cabal.project b/cabal-install/parser-tests/Tests/files/optional-packages/cabal.project similarity index 100% rename from cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/optional-packages/cabal.project rename to cabal-install/parser-tests/Tests/files/optional-packages/cabal.project diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/packages/cabal.project b/cabal-install/parser-tests/Tests/files/packages/cabal.project similarity index 100% rename from cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/packages/cabal.project rename to cabal-install/parser-tests/Tests/files/packages/cabal.project diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/program-locations-concat/cabal.project b/cabal-install/parser-tests/Tests/files/program-locations-concat/cabal.project similarity index 100% rename from cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/program-locations-concat/cabal.project rename to cabal-install/parser-tests/Tests/files/program-locations-concat/cabal.project diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/program-options-concat/cabal.project b/cabal-install/parser-tests/Tests/files/program-options-concat/cabal.project similarity index 100% rename from cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/program-options-concat/cabal.project rename to cabal-install/parser-tests/Tests/files/program-options-concat/cabal.project diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-all-packages/cabal.project b/cabal-install/parser-tests/Tests/files/project-config-all-packages/cabal.project similarity index 100% rename from cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-all-packages/cabal.project rename to cabal-install/parser-tests/Tests/files/project-config-all-packages/cabal.project diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-build-only/cabal.project b/cabal-install/parser-tests/Tests/files/project-config-build-only/cabal.project similarity index 100% rename from cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-build-only/cabal.project rename to cabal-install/parser-tests/Tests/files/project-config-build-only/cabal.project diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-local-packages/cabal.project b/cabal-install/parser-tests/Tests/files/project-config-local-packages/cabal.project similarity index 100% rename from cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-local-packages/cabal.project rename to cabal-install/parser-tests/Tests/files/project-config-local-packages/cabal.project diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-shared/cabal.project b/cabal-install/parser-tests/Tests/files/project-config-shared/cabal.project similarity index 100% rename from cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-shared/cabal.project rename to cabal-install/parser-tests/Tests/files/project-config-shared/cabal.project diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-specific-packages/cabal.project b/cabal-install/parser-tests/Tests/files/project-config-specific-packages/cabal.project similarity index 100% rename from cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/project-config-specific-packages/cabal.project rename to cabal-install/parser-tests/Tests/files/project-config-specific-packages/cabal.project diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/remote-repos/cabal.project b/cabal-install/parser-tests/Tests/files/remote-repos/cabal.project similarity index 100% rename from cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/remote-repos/cabal.project rename to cabal-install/parser-tests/Tests/files/remote-repos/cabal.project diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/source-repository-packages/cabal.project b/cabal-install/parser-tests/Tests/files/source-repository-packages/cabal.project similarity index 100% rename from cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/source-repository-packages/cabal.project rename to cabal-install/parser-tests/Tests/files/source-repository-packages/cabal.project diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/specific-packages-concat/cabal.project b/cabal-install/parser-tests/Tests/files/specific-packages-concat/cabal.project similarity index 100% rename from cabal-testsuite/PackageTests/ProjectConfig/Parsec/tests/specific-packages-concat/cabal.project rename to cabal-install/parser-tests/Tests/files/specific-packages-concat/cabal.project diff --git a/cabal-testsuite/cabal-testsuite.cabal b/cabal-testsuite/cabal-testsuite.cabal index c877f960b4f..4e31b87d254 100644 --- a/cabal-testsuite/cabal-testsuite.cabal +++ b/cabal-testsuite/cabal-testsuite.cabal @@ -131,8 +131,6 @@ executable test-runtime-deps build-depends: , Cabal , Cabal-syntax - , cabal-install - , cabal-install-solver , Cabal-hooks , base , bytestring @@ -141,7 +139,6 @@ executable test-runtime-deps , directory , exceptions , filepath - , network-uri , process , time , transformers From 5959febc52c5e4a0a79ff6cc01f108116d0ce682 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Thu, 22 Aug 2024 22:24:24 +0200 Subject: [PATCH 23/41] Add monoidal parsing of AllowNewer and AllowOlder --- .../parser-tests/Tests/ParserTests.hs | 26 ++++++++++ .../files/relax-deps-concat/cabal.project | 7 +++ .../Client/ProjectConfig/FieldGrammar.hs | 4 +- .../src/Distribution/Client/Utils/Newtypes.hs | 47 ++++++++++++++----- 4 files changed, 70 insertions(+), 14 deletions(-) create mode 100644 cabal-install/parser-tests/Tests/files/relax-deps-concat/cabal.project diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index fe00940a711..06d3f8ebf45 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -87,6 +87,7 @@ parserTests = , testCase "test projectConfigSpecificPackages concatenation" testSpecificPackagesConcat , testCase "test program-locations concatenation" testProgramLocationsConcat , testCase "test program-options concatenation" testProgramOptionsConcat + , testCase "test allow-newer and allow-older concatenation" testRelaxDepsConcat ] testPackages :: Assertion @@ -470,6 +471,31 @@ testProgramOptionsConcat = do { packageConfigProgramArgs = MapMappend $ Map.fromList [("ghc", ["-threaded", "-Wall", "-fno-state-hack"]), ("gcc", ["-baz", "-foo", "-bar"])] } +testRelaxDepsConcat :: Assertion +testRelaxDepsConcat = do + (config, legacy) <- readConfigDefault "relax-deps-concat" + assertConfigEquals expectedAllowNewer config legacy (projectConfigAllowNewer . projectConfigShared . condTreeData) + assertConfigEquals expectedAllowOlder config legacy (projectConfigAllowOlder . projectConfigShared . condTreeData) + where + expectedAllowNewer :: Maybe AllowNewer + expectedAllowNewer = + pure $ + AllowNewer $ + RelaxDepsSome + [ RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "cassava") (mkVersion [0, 5, 2, 0]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "base")) + , RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "vector-th-unbox") (mkVersion [0, 2, 1, 7]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "base")) + , RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "vector-th-unbox") (mkVersion [0, 2, 1, 7]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "template-haskell")) + ] + expectedAllowOlder :: Maybe AllowOlder + expectedAllowOlder = + pure $ + AllowOlder $ + RelaxDepsSome + [ RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "mtl") (mkVersion [2, 3, 1]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "base")) + , RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "aeson") (mkVersion [2, 2, 3, 0]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "bytestring")) + , RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "containers") (mkVersion [0, 7]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "array")) + ] + ------------------------------------------------------------------------------- -- Test Utilities ------------------------------------------------------------------------------- diff --git a/cabal-install/parser-tests/Tests/files/relax-deps-concat/cabal.project b/cabal-install/parser-tests/Tests/files/relax-deps-concat/cabal.project new file mode 100644 index 00000000000..8e328432b64 --- /dev/null +++ b/cabal-install/parser-tests/Tests/files/relax-deps-concat/cabal.project @@ -0,0 +1,7 @@ +-- allow-newer: parallel-3.2.2.0:base +allow-newer: cassava-0.5.2.0:base +allow-newer: vector-th-unbox-0.2.1.7:base +allow-newer: vector-th-unbox-0.2.1.7:template-haskell + +allow-older: mtl-2.3.1:base, aeson-2.2.3.0:bytestring +allow-older: containers-0.7:array diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs index ab30818d2cf..fd5bd2fec90 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs @@ -90,8 +90,8 @@ projectConfigSharedFieldGrammar source = <*> monoidalFieldAla "preferences" formatPackageVersionConstraints L.projectConfigPreferences <*> optionalFieldDef "cabal-lib-version" L.projectConfigCabalVersion mempty <*> optionalFieldDef "solver" L.projectConfigSolver mempty - <*> optionalField "allow-older" L.projectConfigAllowOlder - <*> optionalField "allow-newer" L.projectConfigAllowNewer + <*> monoidalFieldAla "allow-older" AllowOlderNT L.projectConfigAllowOlder + <*> monoidalFieldAla "allow-newer" AllowNewerNT L.projectConfigAllowNewer <*> optionalFieldDef "write-ghc-environment-files" L.projectConfigWriteGhcEnvironmentFilesPolicy mempty <*> optionalFieldDefAla "max-backjumps" (alaFlag MaxBackjumps) L.projectConfigMaxBackjumps mempty <*> optionalFieldDef "reorder-goals" L.projectConfigReorderGoals mempty diff --git a/cabal-install/src/Distribution/Client/Utils/Newtypes.hs b/cabal-install/src/Distribution/Client/Utils/Newtypes.hs index 69db368d048..976c08c1d1b 100644 --- a/cabal-install/src/Distribution/Client/Utils/Newtypes.hs +++ b/cabal-install/src/Distribution/Client/Utils/Newtypes.hs @@ -6,6 +6,8 @@ module Distribution.Client.Utils.Newtypes ( NumJobs (..) , PackageDBNT (..) + , AllowNewerNT (..) + , AllowOlderNT (..) , ProjectConstraints (..) , MaxBackjumps (..) , URI_NT (..) @@ -15,6 +17,7 @@ where import Distribution.Client.Compat.Prelude import Distribution.Client.Targets (UserConstraint) +import Distribution.Client.Types.AllowNewer (AllowNewer (..), AllowOlder (..)) import Distribution.Compat.CharParsing import Distribution.Compat.Newtype import Distribution.Parsec @@ -39,6 +42,18 @@ instance Newtype (Maybe Int) NumJobs instance Parsec NumJobs where parsec = parsecNumJobs +parsecNumJobs :: CabalParsing m => m NumJobs +parsecNumJobs = ncpus <|> numJobs + where + ncpus = string "$ncpus" >> return (NumJobs Nothing) + numJobs = do + num <- integral + if num < (1 :: Int) + then do + parsecWarning PWTOther "The number of jobs should be 1 or more." + return (NumJobs Nothing) + else return (NumJobs $ Just num) + newtype URI_NT = URI_NT {getURI_NT :: URI} instance Newtype (URI) URI_NT @@ -60,18 +75,6 @@ instance Newtype Int KeyThreshold instance Parsec KeyThreshold where parsec = KeyThreshold <$> integral -parsecNumJobs :: CabalParsing m => m NumJobs -parsecNumJobs = ncpus <|> numJobs - where - ncpus = string "$ncpus" >> return (NumJobs Nothing) - numJobs = do - num <- integral - if num < (1 :: Int) - then do - parsecWarning PWTOther "The number of jobs should be 1 or more." - return (NumJobs Nothing) - else return (NumJobs $ Just num) - newtype ProjectConstraints = ProjectConstraints {getProjectConstraints :: (UserConstraint, ConstraintSource)} instance Newtype (UserConstraint, ConstraintSource) ProjectConstraints @@ -95,3 +98,23 @@ instance Parsec MaxBackjumps where parseMaxBackjumps :: CabalParsing m => m MaxBackjumps parseMaxBackjumps = MaxBackjumps <$> integral + +newtype AllowNewerNT = AllowNewerNT {getAllowNewerNT :: Maybe AllowNewer} + +instance Newtype (Maybe AllowNewer) AllowNewerNT + +instance Parsec AllowNewerNT where + parsec = parsecAllowNewer + +parsecAllowNewer :: CabalParsing m => m AllowNewerNT +parsecAllowNewer = AllowNewerNT . Just <$> parsec + +newtype AllowOlderNT = AllowOlderNT {getAllowOlderNT :: Maybe AllowOlder} + +instance Newtype (Maybe AllowOlder) AllowOlderNT + +instance Parsec AllowOlderNT where + parsec = parsecAllowOlder + +parsecAllowOlder :: CabalParsing m => m AllowOlderNT +parsecAllowOlder = AllowOlderNT . Just <$> parsec From 32de2a3a44b9aa21bb2a14e0902c8f0d8a4b1054 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Sun, 25 Aug 2024 01:11:34 +0200 Subject: [PATCH 24/41] Fix order of programArgs parsing --- cabal-install/parser-tests/Tests/ParserTests.hs | 6 +++++- .../Tests/files/all-packages-concat/cabal.project | 5 +++-- .../src/Distribution/Client/ProjectConfig/Parsec.hs | 2 +- 3 files changed, 9 insertions(+), 4 deletions(-) diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index 06d3f8ebf45..097db3f8be5 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -432,7 +432,11 @@ testAllPackagesConcat = do mempty { packageConfigSharedLib = Flag True , packageConfigStaticLib = Flag True - , packageConfigProgramArgs = MapMappend $ Map.fromList [("ghc", ["-fwarn-tabs", "-Wall"])] + , packageConfigProgramArgs = + MapMappend $ + Map.fromList + [ ("ghc", ["-fwarn-tabs", "-optc-fno-builtin-malloc", "-Wall", "-optc-fno-builtin-realloc", "-fwrite-ide-info"]) + ] } testSpecificPackagesConcat :: Assertion diff --git a/cabal-install/parser-tests/Tests/files/all-packages-concat/cabal.project b/cabal-install/parser-tests/Tests/files/all-packages-concat/cabal.project index c6ea2f56eb6..a85e19b9868 100644 --- a/cabal-install/parser-tests/Tests/files/all-packages-concat/cabal.project +++ b/cabal-install/parser-tests/Tests/files/all-packages-concat/cabal.project @@ -1,7 +1,8 @@ package * static: True - ghc-options: -Wall + ghc-options: -fwrite-ide-info + ghc-options: -Wall -optc-fno-builtin-realloc package * shared: True - ghc-options: -fwarn-tabs + ghc-options: -fwarn-tabs -optc-fno-builtin-malloc diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index f9f517cde0a..0c1e7abd655 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -363,7 +363,7 @@ parseProgramArgs programDb fields = foldM parseField mempty (filter hasOptionsSu case readProgramName "-options" programDb fieldName of Nothing -> warnUnknownFields fieldName fieldLines >> return programArgs Just program -> do - args <- parseProgramArgsField fieldLines + args <- parseProgramArgsField $ reverse fieldLines return $ programArgs <> MapMappend (Map.singleton program args) hasOptionsSuffix (fieldName, _) = BS.isSuffixOf "-options" fieldName From b5e69e3d7e2ca57e186be8712b4ae980cf6a24a8 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Sun, 25 Aug 2024 01:46:50 +0200 Subject: [PATCH 25/41] Fix parsing of commas in programArgs --- cabal-install/parser-tests/Tests/ParserTests.hs | 8 +++++++- .../Tests/files/program-options-concat/cabal.project | 1 + .../src/Distribution/Client/ProjectConfig/Parsec.hs | 4 ++-- 3 files changed, 10 insertions(+), 3 deletions(-) diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index 097db3f8be5..85f8f7a45df 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -472,7 +472,13 @@ testProgramOptionsConcat = do expected :: PackageConfig expected = mempty - { packageConfigProgramArgs = MapMappend $ Map.fromList [("ghc", ["-threaded", "-Wall", "-fno-state-hack"]), ("gcc", ["-baz", "-foo", "-bar"])] + { packageConfigProgramArgs = + MapMappend $ + Map.fromList + [ ("ghc", ["-threaded", "-Wall", "-fno-state-hack"]) + , ("gcc", ["-baz", "-foo", "-bar"]) + , ("ld", ["-Wl,--gc-sections"]) + ] } testRelaxDepsConcat :: Assertion diff --git a/cabal-install/parser-tests/Tests/files/program-options-concat/cabal.project b/cabal-install/parser-tests/Tests/files/program-options-concat/cabal.project index d880c442874..558a5e45a65 100644 --- a/cabal-install/parser-tests/Tests/files/program-options-concat/cabal.project +++ b/cabal-install/parser-tests/Tests/files/program-options-concat/cabal.project @@ -5,3 +5,4 @@ program-options program-options ghc-options: -threaded -Wall gcc-options: -baz + ld-options: -Wl,--gc-sections diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index 0c1e7abd655..bb60645f58b 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -41,7 +41,7 @@ import Distribution.Solver.Types.ProjectConfigPath import Distribution.Fields (Field (..), FieldLine (..), FieldName, Name (..), SectionArg (..), readFields', showPWarning) import Distribution.Fields.LexerMonad (toPWarnings) -import Distribution.Parsec (CabalParsing, PError (..), ParsecParser, eitherParsec, parsec, parsecFilePath, parsecToken, runParsecParser) +import Distribution.Parsec (CabalParsing, PError (..), ParsecParser, eitherParsec, parsec, parsecFilePath, parsecToken', runParsecParser) import Distribution.Parsec.Position (Position (..), zeroPos) import Distribution.Parsec.Warning (PWarnType (..)) import Distribution.Simple.Program.Db (ProgramDb, defaultProgramDb, knownPrograms, lookupKnownProgram) @@ -393,7 +393,7 @@ parseProgramArgsFieldLines :: Position -> [FieldLine Position] -> ParseResult [S parseProgramArgsFieldLines pos = runFieldParser pos programArgsFieldParser cabalSpec programArgsFieldParser :: CabalParsing m => m [String] -programArgsFieldParser = parseSep (Proxy :: Proxy FSep) parsecToken +programArgsFieldParser = parseSep (Proxy :: Proxy NoCommaFSep) parsecToken' type FieldSuffix = String From 7e5df6a03d9129006d467babd91d51a2d86ec097 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Thu, 12 Sep 2024 16:08:40 +0200 Subject: [PATCH 26/41] Add quotes in programOptions test --- cabal-install/parser-tests/Tests/ParserTests.hs | 1 + .../Tests/files/program-options-concat/cabal.project | 1 + 2 files changed, 2 insertions(+) diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index 85f8f7a45df..9eaea4c1d0a 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -477,6 +477,7 @@ testProgramOptionsConcat = do Map.fromList [ ("ghc", ["-threaded", "-Wall", "-fno-state-hack"]) , ("gcc", ["-baz", "-foo", "-bar"]) + , ("haddock", ["--optghc=-optP -P"]) , ("ld", ["-Wl,--gc-sections"]) ] } diff --git a/cabal-install/parser-tests/Tests/files/program-options-concat/cabal.project b/cabal-install/parser-tests/Tests/files/program-options-concat/cabal.project index 558a5e45a65..a418091c0d5 100644 --- a/cabal-install/parser-tests/Tests/files/program-options-concat/cabal.project +++ b/cabal-install/parser-tests/Tests/files/program-options-concat/cabal.project @@ -1,6 +1,7 @@ program-options ghc-options: -fno-state-hack gcc-options: -foo -bar + haddock-options: --optghc="-optP -P" program-options ghc-options: -threaded -Wall From 5cb80adbac67bb8f3cd1171142f29333951962b6 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 13 Sep 2024 16:00:08 +0200 Subject: [PATCH 27/41] Update programArgs parser to allow Quotes --- .../src/Distribution/Client/ProjectConfig/Parsec.hs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index bb60645f58b..5b8f6ee3b63 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -46,7 +46,7 @@ import Distribution.Parsec.Position (Position (..), zeroPos) import Distribution.Parsec.Warning (PWarnType (..)) import Distribution.Simple.Program.Db (ProgramDb, defaultProgramDb, knownPrograms, lookupKnownProgram) import Distribution.Simple.Program.Types (programName) -import Distribution.Simple.Setup (Flag (..)) +import Distribution.Simple.Setup (Flag (..), splitArgs) import Distribution.Types.CondTree (CondBranch (..), CondTree (..)) import Distribution.Types.ConfVar (ConfVar (..)) import Distribution.Types.PackageName (PackageName) @@ -386,14 +386,13 @@ parseProgramPaths programDb fields = foldM parseField mempty (filter hasLocation -- By processing '[NamelessField Position]', we support multiple occurrences of the field, concatenating the arguments. parseProgramArgsField :: [NamelessField Position] -> ParseResult ([String]) parseProgramArgsField fieldLines = - concat <$> mapM (\(MkNamelessField pos lines') -> parseProgramArgsFieldLines pos lines') fieldLines + concat <$> mapM (\(MkNamelessField _ lines') -> parseProgramArgsFieldLines lines') fieldLines -- | Parse all fieldLines of a single field occurrence in a program-options stanza. -parseProgramArgsFieldLines :: Position -> [FieldLine Position] -> ParseResult [String] -parseProgramArgsFieldLines pos = runFieldParser pos programArgsFieldParser cabalSpec - -programArgsFieldParser :: CabalParsing m => m [String] -programArgsFieldParser = parseSep (Proxy :: Proxy NoCommaFSep) parsecToken' +parseProgramArgsFieldLines :: [FieldLine Position] -> ParseResult [String] +parseProgramArgsFieldLines lines' = return $ splitArgs strLines + where + strLines = fieldLinesToString lines' type FieldSuffix = String From 6919f7268c467d56ea994706a1f5a5e5110bf38c Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 13 Sep 2024 16:00:42 +0200 Subject: [PATCH 28/41] Fix order of imports --- .../Client/ProjectConfig/Parsec.hs | 34 +++++++++---------- 1 file changed, 16 insertions(+), 18 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index 5b8f6ee3b63..80a1ad788ef 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -13,49 +13,47 @@ module Distribution.Client.ProjectConfig.Parsec , runParseResult ) where -import Network.URI (parseURI, uriFragment, uriPath, uriScheme) - -import Control.Monad.State.Strict (StateT, execStateT, lift) -import qualified Data.Map.Strict as Map import Distribution.CabalSpecVersion import Distribution.Client.HttpUtils +import Distribution.Client.ProjectConfig.FieldGrammar (packageConfigFieldGrammar, projectConfigFieldGrammar) +import Distribution.Client.ProjectConfig.Legacy (ProjectConfigSkeleton) +import qualified Distribution.Client.ProjectConfig.Lens as L +import Distribution.Client.ProjectConfig.Types (MapLast (..), MapMappend (..), PackageConfig (..), ProjectConfig (..), ProjectConfigShared (..), ProjectConfigToParse (..)) import Distribution.Client.Types.Repo hiding (repoName) import Distribution.Client.Types.RepoName (RepoName (..)) +import Distribution.Client.Types.SourceRepo (sourceRepositoryPackageGrammar) import Distribution.Client.Utils.Parsec import Distribution.Compat.Lens import Distribution.Compat.Prelude import Distribution.FieldGrammar import Distribution.FieldGrammar.Parsec (NamelessField (..), namelessFieldAnn) -import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS) -import Distribution.Simple.Utils (debug, warn) -import Distribution.Verbosity - -import Distribution.Client.ProjectConfig.FieldGrammar (packageConfigFieldGrammar, projectConfigFieldGrammar) -import Distribution.Client.ProjectConfig.Legacy (ProjectConfigSkeleton) -import qualified Distribution.Client.ProjectConfig.Lens as L -import Distribution.Client.ProjectConfig.Types (MapLast (..), MapMappend (..), PackageConfig (..), ProjectConfig (..), ProjectConfigShared (..), ProjectConfigToParse (..)) -import Distribution.Client.Types.SourceRepo (sourceRepositoryPackageGrammar) -import Distribution.Fields.ConfVar (parseConditionConfVar) -import Distribution.Fields.ParseResult -import Distribution.Solver.Types.ProjectConfigPath - import Distribution.Fields (Field (..), FieldLine (..), FieldName, Name (..), SectionArg (..), readFields', showPWarning) +import Distribution.Fields.ConfVar (parseConditionConfVar) +import Distribution.Fields.Field (fieldLinesToString) import Distribution.Fields.LexerMonad (toPWarnings) -import Distribution.Parsec (CabalParsing, PError (..), ParsecParser, eitherParsec, parsec, parsecFilePath, parsecToken', runParsecParser) +import Distribution.Fields.ParseResult +import Distribution.Parsec (PError (..), ParsecParser, eitherParsec, parsec, parsecFilePath, runParsecParser) +import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS) import Distribution.Parsec.Position (Position (..), zeroPos) import Distribution.Parsec.Warning (PWarnType (..)) import Distribution.Simple.Program.Db (ProgramDb, defaultProgramDb, knownPrograms, lookupKnownProgram) import Distribution.Simple.Program.Types (programName) import Distribution.Simple.Setup (Flag (..), splitArgs) +import Distribution.Simple.Utils (debug, warn) +import Distribution.Solver.Types.ProjectConfigPath import Distribution.Types.CondTree (CondBranch (..), CondTree (..)) import Distribution.Types.ConfVar (ConfVar (..)) import Distribution.Types.PackageName (PackageName) import Distribution.Utils.Generic (fromUTF8BS, toUTF8BS, validateUTF8) import Distribution.Utils.NubList (toNubList) +import Distribution.Verbosity +import Control.Monad.State.Strict (StateT, execStateT, lift) import qualified Data.ByteString as BS import Data.Coerce (coerce) +import qualified Data.Map.Strict as Map import qualified Distribution.Compat.CharParsing as P +import Network.URI (parseURI, uriFragment, uriPath, uriScheme) import System.Directory (createDirectoryIfMissing, makeAbsolute) import System.FilePath (isAbsolute, isPathSeparator, makeValid, splitFileName, ()) import qualified Text.Parsec From 7d25cbd2a43da49ea48ace95b411685e24182e43 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 13 Sep 2024 16:53:48 +0200 Subject: [PATCH 29/41] Update PackageDBNT to use PackageDBCWD --- .../src/Distribution/Client/ProjectConfig/Lens.hs | 4 ++-- cabal-install/src/Distribution/Client/Utils/Newtypes.hs | 8 ++++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs index cb6c2c60fa9..03e05835cd6 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs @@ -26,7 +26,7 @@ import Distribution.PackageDescription import Distribution.Simple.Compiler ( DebugInfoLevel (..) , OptimisationLevel (..) - , PackageDB + , PackageDBCWD , ProfDetailLevel ) import Distribution.Simple.InstallDirs @@ -212,7 +212,7 @@ projectConfigInstallDirs :: Lens' ProjectConfigShared (InstallDirs (Flag PathTem projectConfigInstallDirs f s = fmap (\x -> s{T.projectConfigInstallDirs = x}) (f (T.projectConfigInstallDirs s)) {-# INLINEABLE projectConfigInstallDirs #-} -projectConfigPackageDBs :: Lens' ProjectConfigShared [Maybe PackageDB] +projectConfigPackageDBs :: Lens' ProjectConfigShared [Maybe PackageDBCWD] projectConfigPackageDBs f s = fmap (\x -> s{T.projectConfigPackageDBs = x}) (f (T.projectConfigPackageDBs s)) {-# INLINEABLE projectConfigPackageDBs #-} diff --git a/cabal-install/src/Distribution/Client/Utils/Newtypes.hs b/cabal-install/src/Distribution/Client/Utils/Newtypes.hs index 976c08c1d1b..aa60eea697c 100644 --- a/cabal-install/src/Distribution/Client/Utils/Newtypes.hs +++ b/cabal-install/src/Distribution/Client/Utils/Newtypes.hs @@ -21,19 +21,19 @@ import Distribution.Client.Types.AllowNewer (AllowNewer (..), AllowOlder (..)) import Distribution.Compat.CharParsing import Distribution.Compat.Newtype import Distribution.Parsec -import Distribution.Simple.Compiler (PackageDB (..), readPackageDb) +import Distribution.Simple.Compiler (PackageDBCWD, interpretPackageDB, readPackageDb) import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) import Network.URI (URI, parseURI) -newtype PackageDBNT = PackageDBNT {getPackageDBNT :: Maybe PackageDB} +newtype PackageDBNT = PackageDBNT {getPackageDBNT :: Maybe PackageDBCWD} -instance Newtype (Maybe PackageDB) PackageDBNT +instance Newtype (Maybe PackageDBCWD) PackageDBNT instance Parsec PackageDBNT where parsec = parsecPackageDB parsecPackageDB :: CabalParsing m => m PackageDBNT -parsecPackageDB = PackageDBNT . readPackageDb <$> parsecToken +parsecPackageDB = PackageDBNT . fmap (interpretPackageDB Nothing) . readPackageDb <$> parsecToken newtype NumJobs = NumJobs {getNumJobs :: Maybe Int} From d9c616a626e8ddf905b2c85eea30ee456c4d049c Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 13 Sep 2024 18:11:50 +0200 Subject: [PATCH 30/41] Fix ParserTests to use PackageDBX --- cabal-install/parser-tests/Tests/ParserTests.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index 9eaea4c1d0a..c60a153eafa 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -31,7 +31,7 @@ import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy (WriteGhcEnviron import Distribution.Compat.Prelude import Distribution.Compiler (CompilerFlavor (..)) import Distribution.Parsec (simpleParsec) -import Distribution.Simple.Compiler (DebugInfoLevel (..), OptimisationLevel (..), PackageDB (..), ProfDetailLevel (..)) +import Distribution.Simple.Compiler (DebugInfoLevel (..), OptimisationLevel (..), PackageDBX (..), ProfDetailLevel (..)) import Distribution.Simple.Flag import Distribution.Simple.InstallDirs (InstallDirs (..), toPathTemplate) import Distribution.Simple.Setup (DumpBuildInfo (..), HaddockTarget (..), TestShowDetails (..)) From 146d907759a60c766fa4baff0f81d2dce9bc2c5e Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 13 Sep 2024 21:19:23 +0200 Subject: [PATCH 31/41] Fix TOCTOU --- .../src/Distribution/Client/ProjectConfig.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index ce8d2bd140f..5b4bcd24e26 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -216,7 +216,7 @@ import qualified Codec.Archive.Tar.Entry as Tar import qualified Distribution.Client.GZipUtils as GZipUtils import qualified Distribution.Client.Tar as Tar -import Control.Exception (handle) +import Control.Exception (handle, tryJust) import Control.Monad.Trans (liftIO) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS @@ -245,6 +245,9 @@ import System.IO ( IOMode (ReadMode) , withBinaryFile ) +import System.IO.Error + ( isDoesNotExistError + ) import Distribution.Solver.Types.ProjectConfigPath @@ -854,12 +857,10 @@ readAndParseFile -> FilePath -> IO a readAndParseFile parser verbosity fpath = do - exists <- doesFileExist fpath - unless exists $ - dieWithException verbosity $ - ErrorParsingFileDoesntExist fpath - bs <- BS.readFile fpath - parseString parser verbosity fpath bs + result <- tryJust (guard . isDoesNotExistError) (BS.readFile fpath) + case result of + Right bs -> parseString parser verbosity fpath bs + Left _ -> dieWithException verbosity $ ErrorParsingFileDoesntExist fpath parseString :: ( BS.ByteString From e2d6e2db3f6ebdd70f7a7a2d078ba9a335742df0 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 1 Nov 2024 14:21:08 +0100 Subject: [PATCH 32/41] Add library-coverage test --- cabal-install/parser-tests/Tests/ParserTests.hs | 6 ++++++ .../parser-tests/Tests/files/library-coverage/cabal.project | 2 ++ .../src/Distribution/Client/ProjectConfig/FieldGrammar.hs | 4 ++-- 3 files changed, 10 insertions(+), 2 deletions(-) create mode 100644 cabal-install/parser-tests/Tests/files/library-coverage/cabal.project diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index c60a153eafa..1a7b9b558a9 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -88,6 +88,7 @@ parserTests = , testCase "test program-locations concatenation" testProgramLocationsConcat , testCase "test program-options concatenation" testProgramOptionsConcat , testCase "test allow-newer and allow-older concatenation" testRelaxDepsConcat + , testCase "test library-coverage overwrites coverage" testLibraryCoverage ] testPackages :: Assertion @@ -507,6 +508,11 @@ testRelaxDepsConcat = do , RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "containers") (mkVersion [0, 7]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "array")) ] +-- | Tests that if both library-coverage and coverage flags are specified, library-coverage is used. +testLibraryCoverage :: Assertion +testLibraryCoverage = do + (config, legacy) <- readConfigDefault "library-coverage" + assertConfigEquals (Flag False) config legacy (packageConfigCoverage . projectConfigLocalPackages . condTreeData) ------------------------------------------------------------------------------- -- Test Utilities ------------------------------------------------------------------------------- diff --git a/cabal-install/parser-tests/Tests/files/library-coverage/cabal.project b/cabal-install/parser-tests/Tests/files/library-coverage/cabal.project new file mode 100644 index 00000000000..074a06e7731 --- /dev/null +++ b/cabal-install/parser-tests/Tests/files/library-coverage/cabal.project @@ -0,0 +1,2 @@ +library-coverage: False +coverage: True diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs index fd5bd2fec90..65b26f16e2e 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs @@ -181,6 +181,6 @@ packageConfigFieldGrammar knownPrograms = packageConfigCoverageGrammar :: ParsecFieldGrammar PackageConfig (Distribution.Simple.Flag.Flag Bool) packageConfigCoverageGrammar = (<>) - <$> optionalFieldDef "library-coverage" L.packageConfigCoverage mempty + <$> optionalFieldDef "coverage" L.packageConfigCoverage mempty + <*> optionalFieldDef "library-coverage" L.packageConfigCoverage mempty ^^^ deprecatedSince CabalSpecV1_22 "Please use 'coverage' field instead." - <*> optionalFieldDef "coverage" L.packageConfigCoverage mempty From 051d2e5d93f9d525e0c1c612a794322a24eba675 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 1 Nov 2024 19:25:06 +0100 Subject: [PATCH 33/41] Add parsing of haddock-all flag --- .../parser-tests/Tests/ParserTests.hs | 29 +++++++ .../haddock-all-overwrite-false/cabal.project | 2 + .../haddock-all-overwrite-true/cabal.project | 2 + .../Tests/files/haddock-all/cabal.project | 1 + .../Client/ProjectConfig/FieldGrammar.hs | 82 ++++++++++++++++++- 5 files changed, 114 insertions(+), 2 deletions(-) create mode 100644 cabal-install/parser-tests/Tests/files/haddock-all-overwrite-false/cabal.project create mode 100644 cabal-install/parser-tests/Tests/files/haddock-all-overwrite-true/cabal.project create mode 100644 cabal-install/parser-tests/Tests/files/haddock-all/cabal.project diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index 1a7b9b558a9..840b5ca0e06 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -89,6 +89,9 @@ parserTests = , testCase "test program-options concatenation" testProgramOptionsConcat , testCase "test allow-newer and allow-older concatenation" testRelaxDepsConcat , testCase "test library-coverage overwrites coverage" testLibraryCoverage + , testCase "test haddock-all flag" testHaddockAll + , testCase "test override haddock-all: True" testHaddockAllOverwriteTrue + , testCase "test override haddock-all: False" testHaddockAllOverwriteFalse ] testPackages :: Assertion @@ -513,6 +516,32 @@ testLibraryCoverage :: Assertion testLibraryCoverage = do (config, legacy) <- readConfigDefault "library-coverage" assertConfigEquals (Flag False) config legacy (packageConfigCoverage . projectConfigLocalPackages . condTreeData) + +testHaddockAll :: Assertion +testHaddockAll = do + (config, legacy) <- readConfigDefault "haddock-all" + assertConfigEquals (Flag True) config legacy (packageConfigHaddockExecutables . projectConfigLocalPackages . condTreeData) + assertConfigEquals (Flag True) config legacy (packageConfigHaddockTestSuites . projectConfigLocalPackages . condTreeData) + assertConfigEquals (Flag True) config legacy (packageConfigHaddockBenchmarks . projectConfigLocalPackages . condTreeData) + assertConfigEquals (Flag True) config legacy (packageConfigHaddockForeignLibs . projectConfigLocalPackages . condTreeData) + +-- | Tests that an explicitly set field can override a value inherited from haddock-all. +testHaddockAllOverwriteTrue :: Assertion +testHaddockAllOverwriteTrue = do + (config, legacy) <- readConfigDefault "haddock-all-overwrite-true" + assertConfigEquals (Flag True) config legacy (packageConfigHaddockExecutables . projectConfigLocalPackages . condTreeData) + assertConfigEquals (Flag True) config legacy (packageConfigHaddockTestSuites . projectConfigLocalPackages . condTreeData) + assertConfigEquals (Flag True) config legacy (packageConfigHaddockBenchmarks . projectConfigLocalPackages . condTreeData) + assertConfigEquals (Flag False) config legacy (packageConfigHaddockForeignLibs . projectConfigLocalPackages . condTreeData) + +testHaddockAllOverwriteFalse :: Assertion +testHaddockAllOverwriteFalse = do + (config, legacy) <- readConfigDefault "haddock-all-overwrite-false" + assertConfigEquals (Flag True) config legacy (packageConfigHaddockExecutables . projectConfigLocalPackages . condTreeData) + assertConfigEquals (Flag False) config legacy (packageConfigHaddockTestSuites . projectConfigLocalPackages . condTreeData) + assertConfigEquals (Flag False) config legacy (packageConfigHaddockBenchmarks . projectConfigLocalPackages . condTreeData) + assertConfigEquals (Flag False) config legacy (packageConfigHaddockForeignLibs . projectConfigLocalPackages . condTreeData) + ------------------------------------------------------------------------------- -- Test Utilities ------------------------------------------------------------------------------- diff --git a/cabal-install/parser-tests/Tests/files/haddock-all-overwrite-false/cabal.project b/cabal-install/parser-tests/Tests/files/haddock-all-overwrite-false/cabal.project new file mode 100644 index 00000000000..c0c044081b6 --- /dev/null +++ b/cabal-install/parser-tests/Tests/files/haddock-all-overwrite-false/cabal.project @@ -0,0 +1,2 @@ +haddock-all: False +haddock-executables: True diff --git a/cabal-install/parser-tests/Tests/files/haddock-all-overwrite-true/cabal.project b/cabal-install/parser-tests/Tests/files/haddock-all-overwrite-true/cabal.project new file mode 100644 index 00000000000..c591d86a961 --- /dev/null +++ b/cabal-install/parser-tests/Tests/files/haddock-all-overwrite-true/cabal.project @@ -0,0 +1,2 @@ +haddock-all: True +haddock-foreign-libraries: False diff --git a/cabal-install/parser-tests/Tests/files/haddock-all/cabal.project b/cabal-install/parser-tests/Tests/files/haddock-all/cabal.project new file mode 100644 index 00000000000..275c4539524 --- /dev/null +++ b/cabal-install/parser-tests/Tests/files/haddock-all/cabal.project @@ -0,0 +1 @@ +haddock-all: True diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs index 65b26f16e2e..1f8f468b1ec 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | 'ProjectConfig' Field descriptions module Distribution.Client.ProjectConfig.FieldGrammar @@ -109,8 +110,10 @@ projectConfigSharedFieldGrammar source = packageConfigFieldGrammar :: [String] -> ParsecFieldGrammar' PackageConfig packageConfigFieldGrammar knownPrograms = - PackageConfig - <$> pure mempty -- program-options stanza + mkPackageConfig + <$> optionalFieldDef "haddock-all" noopLens mempty + ^^^ hiddenField + <*> pure mempty -- program-options stanza <*> pure mempty -- program-locations stanza <*> monoidalFieldAla "extra-prog-path" (alaNubList' FSep FilePathNT) L.packageConfigProgramPathExtra <*> monoidalField "flags" L.packageConfigFlagAssignment @@ -177,6 +180,81 @@ packageConfigFieldGrammar knownPrograms = -- When declared at top level (packageConfigLocalPackages), the PackageConfig must contain a program-options stanza/program-locations for these fields. <* traverse_ (knownField . BS.pack . (<> "-options")) knownPrograms <* traverse_ (knownField . BS.pack . (<> "-location")) knownPrograms + where + noopLens f s = s <$ f mempty + mkPackageConfig + haddockAll + packageConfigProgramPaths + packageConfigProgramArgs + packageConfigProgramPathExtra + packageConfigFlagAssignment + packageConfigVanillaLib + packageConfigSharedLib + packageConfigStaticLib + packageConfigDynExe + packageConfigFullyStaticExe + packageConfigProf + packageConfigProfLib + packageConfigProfShared + packageConfigProfExe + packageConfigProfDetail + packageConfigProfLibDetail + packageConfigConfigureArgs + packageConfigOptimization + packageConfigProgPrefix + packageConfigProgSuffix + packageConfigExtraLibDirs + packageConfigExtraLibDirsStatic + packageConfigExtraFrameworkDirs + packageConfigExtraIncludeDirs + packageConfigGHCiLib + packageConfigSplitSections + packageConfigSplitObjs + packageConfigStripExes + packageConfigStripLibs + packageConfigTests + packageConfigBenchmarks + packageConfigCoverage + packageConfigRelocatable + packageConfigDebugInfo + packageConfigDumpBuildInfo + packageConfigRunTests + packageConfigDocumentation + packageConfigHaddockHoogle + packageConfigHaddockHtml + packageConfigHaddockHtmlLocation + packageConfigHaddockForeignLibs' + packageConfigHaddockExecutables' + packageConfigHaddockTestSuites' + packageConfigHaddockBenchmarks' + packageConfigHaddockInternal + packageConfigHaddockCss + packageConfigHaddockLinkedSource + packageConfigHaddockQuickJump + packageConfigHaddockHscolourCss + packageConfigHaddockContents + packageConfigHaddockIndex + packageConfigHaddockBaseUrl + packageConfigHaddockResourcesDir + packageConfigHaddockOutputDir + packageConfigHaddockUseUnicode + packageConfigHaddockForHackage + packageConfigTestHumanLog + packageConfigTestMachineLog + packageConfigTestShowDetails + packageConfigTestKeepTix + packageConfigTestWrapper + packageConfigTestFailWhenNoTestSuites + packageConfigTestTestOptions + packageConfigBenchmarkOptions = + PackageConfig + { -- The haddock-al` field provides a default value, but explicit declarations can override it + packageConfigHaddockForeignLibs = haddockAll <> packageConfigHaddockForeignLibs' + , packageConfigHaddockExecutables = haddockAll <> packageConfigHaddockExecutables' + , packageConfigHaddockTestSuites = haddockAll <> packageConfigHaddockTestSuites' + , packageConfigHaddockBenchmarks = haddockAll <> packageConfigHaddockBenchmarks' + , .. + } packageConfigCoverageGrammar :: ParsecFieldGrammar PackageConfig (Distribution.Simple.Flag.Flag Bool) packageConfigCoverageGrammar = From 0df304152d65d7939beb116ac0e039dcafae36d1 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 1 Nov 2024 21:50:49 +0100 Subject: [PATCH 34/41] Renamed LiftParseResult, pure composition --- Cabal-syntax/src/Distribution/Fields/ParseResult.hs | 6 +++--- Cabal/src/Distribution/Simple/Compiler.hs | 2 +- .../src/Distribution/Client/ProjectConfig/Parsec.hs | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/Cabal-syntax/src/Distribution/Fields/ParseResult.hs b/Cabal-syntax/src/Distribution/Fields/ParseResult.hs index c08611f8424..a4f160d4696 100644 --- a/Cabal-syntax/src/Distribution/Fields/ParseResult.hs +++ b/Cabal-syntax/src/Distribution/Fields/ParseResult.hs @@ -16,7 +16,7 @@ module Distribution.Fields.ParseResult , getCabalSpecVersion , setCabalSpecVersion , withoutWarnings - , liftPR + , liftParseResult ) where import Distribution.Compat.Prelude @@ -64,8 +64,8 @@ runParseResult pr = unPR pr emptyPRState failure success success (PRState warns (err : errs) v) _ = (warns, Left (v, err :| errs)) -- | Chain parsing operations that involve 'IO' actions. -liftPR :: (a -> IO (ParseResult b)) -> ParseResult a -> IO (ParseResult b) -liftPR f pr = unPR pr emptyPRState failure success +liftParseResult :: (a -> IO (ParseResult b)) -> ParseResult a -> IO (ParseResult b) +liftParseResult f pr = unPR pr emptyPRState failure success where failure s = return $ PR $ \s' failure' _ -> failure' (concatPRState s s') success s a = do diff --git a/Cabal/src/Distribution/Simple/Compiler.hs b/Cabal/src/Distribution/Simple/Compiler.hs index 5764874465f..b2129e80846 100644 --- a/Cabal/src/Distribution/Simple/Compiler.hs +++ b/Cabal/src/Distribution/Simple/Compiler.hs @@ -355,7 +355,7 @@ instance Parsec DebugInfoLevel where parsec = parsecDebugInfoLevel parsecDebugInfoLevel :: CabalParsing m => m DebugInfoLevel -parsecDebugInfoLevel = flagToDebugInfoLevel <$> pure <$> parsecToken +parsecDebugInfoLevel = flagToDebugInfoLevel . pure <$> parsecToken flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel flagToDebugInfoLevel Nothing = NormalDebugInfo diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index 80a1ad788ef..65f7ff47794 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -107,12 +107,12 @@ parseProjectSkeleton -> ProjectConfigToParse -- ^ The contents of the file to parse -> IO (ParseResult ProjectConfigSkeleton) -parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (ProjectConfigToParse bs) = (sanityWalkPCS False =<<) <$> liftPR (go []) (readPreprocessFields bs) +parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (ProjectConfigToParse bs) = (sanityWalkPCS False =<<) <$> liftParseResult (go []) (readPreprocessFields bs) where go :: [Field Position] -> [Field Position] -> IO (ParseResult ProjectConfigSkeleton) go acc (x : xs) = case x of (Field (Name pos name) importLines) | name == "import" -> do - liftPR + liftParseResult ( \importLoc -> do let importLocPath = importLoc `consProjectConfigPath` source From 91f6317965a603deaa1623d113bf707897ce709c Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Mon, 4 Nov 2024 14:40:06 +0100 Subject: [PATCH 35/41] Fix intToOptimisationLevel dynamic bounds --- Cabal/src/Distribution/Simple/Compiler.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Compiler.hs b/Cabal/src/Distribution/Simple/Compiler.hs index b2129e80846..0dc5cc3b3b3 100644 --- a/Cabal/src/Distribution/Simple/Compiler.hs +++ b/Cabal/src/Distribution/Simple/Compiler.hs @@ -323,14 +323,18 @@ flagToOptimisationLevel (Just s) = case reads s of intToOptimisationLevel :: Int -> OptimisationLevel intToOptimisationLevel i - | i >= fromEnum (minBound :: OptimisationLevel) - && i <= fromEnum (maxBound :: OptimisationLevel) = - toEnum i + | i >= minLevel && i <= maxLevel = toEnum i | otherwise = error $ "Bad optimisation level: " ++ show i - ++ ". Valid values are 0..2" + ++ ". Valid values are " + ++ show minLevel + ++ ".." + ++ show maxLevel + where + minLevel = fromEnum (minBound :: OptimisationLevel) + maxLevel = i <= fromEnum (maxBound :: OptimisationLevel) -- ------------------------------------------------------------ From 126597524051803961f7280b1ed61b334fb63a23 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Mon, 4 Nov 2024 15:00:27 +0100 Subject: [PATCH 36/41] Add cabal-install:parser-tests to cabal-validate --- cabal-validate/src/Main.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/cabal-validate/src/Main.hs b/cabal-validate/src/Main.hs index 7164f3f8cc4..902b73b7ade 100644 --- a/cabal-validate/src/Main.hs +++ b/cabal-validate/src/Main.hs @@ -359,6 +359,14 @@ cliTests opts = do ++ tastyArgs opts ) + timedCabalBin + opts + "cabal-install" + "test:parser-tests" + ( jobsArgs opts + ++ tastyArgs opts + ) + timedCabalBin opts "cabal-install" From 5b0c35a8301900801d1c4beb4cc565ea8d309357 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Mon, 4 Nov 2024 15:11:13 +0100 Subject: [PATCH 37/41] Fix maxLevel comparison --- Cabal/src/Distribution/Simple/Compiler.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Cabal/src/Distribution/Simple/Compiler.hs b/Cabal/src/Distribution/Simple/Compiler.hs index 0dc5cc3b3b3..175a2a589a8 100644 --- a/Cabal/src/Distribution/Simple/Compiler.hs +++ b/Cabal/src/Distribution/Simple/Compiler.hs @@ -334,7 +334,7 @@ intToOptimisationLevel i ++ show maxLevel where minLevel = fromEnum (minBound :: OptimisationLevel) - maxLevel = i <= fromEnum (maxBound :: OptimisationLevel) + maxLevel = fromEnum (maxBound :: OptimisationLevel) -- ------------------------------------------------------------ From 7d7707f21f9d23fb58c61683d9ae3831be350a4a Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Tue, 7 Jan 2025 19:04:55 +0100 Subject: [PATCH 38/41] Fix regression test and issue url --- .../src/Distribution/Client/CmdInstall/ClientInstallFlags.hs | 2 +- cabal-testsuite/PackageTests/Regression/T5213/cabal.out | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs b/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs index 7c26b8f02a9..317d7133acc 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs @@ -77,7 +77,7 @@ clientInstallOptions _ = [] ["lib"] ( "Install libraries rather than executables from the target package " - <> "(provisional, see https://github.com/haskell/cabal/issues\/6481 for more information)." + <> "(provisional, see https://github.com/haskell/cabal/issues/6481 for more information)." ) cinstInstallLibs (\v flags -> flags{cinstInstallLibs = v}) diff --git a/cabal-testsuite/PackageTests/Regression/T5213/cabal.out b/cabal-testsuite/PackageTests/Regression/T5213/cabal.out index b6be4708e0d..f6822f77978 100644 --- a/cabal-testsuite/PackageTests/Regression/T5213/cabal.out +++ b/cabal-testsuite/PackageTests/Regression/T5213/cabal.out @@ -1,4 +1,6 @@ # cabal new-test +Configuration is affected by the following files: +- cabal.project Warning: /cabal.project:4:3: The field "library-coverage" is deprecated in the Cabal specification version 1.22. Please use 'coverage' field instead. Resolving dependencies... Build profile: -w ghc- -O1 From b641acdd669129cad7c999c2267a4f628549f679 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Tue, 7 Jan 2025 19:30:09 +0100 Subject: [PATCH 39/41] Fix exports in ProjectConfig --- cabal-install/src/Distribution/Client/ProjectConfig.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index 5b4bcd24e26..29bcb76055b 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -37,6 +37,10 @@ module Distribution.Client.ProjectConfig , writeProjectLocalFreezeConfig , writeProjectConfigFile , commandLineFlagsToProjectConfig + , onlyTopLevelProvenance + , readSourcePackageCabalFile + , readSourcePackageCabalFile' + , CabalFileParseError (..) , readProjectFileSkeleton , readProjectFileSkeletonLegacy From 462a345ae31d05de125b5e185b3a034dfadc93fe Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 10 Jan 2025 21:57:19 +0100 Subject: [PATCH 40/41] Add Parsec Subsection Warning to test Expects Invalid subsection warning by the Parsec ProjectConfig parser. Currently the warning is issued twice: First warning: "Warning: /else.project, else.project: Unrecognized section '_' on line 3" is issued by the legacy parser, Second warning: "Warning: dir-else/else.config:3:5: Invalid subsection "_"" by Parsec Parser. When we remove executing the legacy parser, we can remove the duplicate warning. --- .../PackageTests/ProjectImport/ParseErrorProvenance/cabal.out | 1 + 1 file changed, 1 insertion(+) diff --git a/cabal-testsuite/PackageTests/ProjectImport/ParseErrorProvenance/cabal.out b/cabal-testsuite/PackageTests/ProjectImport/ParseErrorProvenance/cabal.out index a3143ff9ffd..23df1a04ee4 100644 --- a/cabal-testsuite/PackageTests/ProjectImport/ParseErrorProvenance/cabal.out +++ b/cabal-testsuite/PackageTests/ProjectImport/ParseErrorProvenance/cabal.out @@ -1,5 +1,6 @@ # cabal v2-build Warning: /else.project, else.project: Unrecognized section '_' on line 3 +Warning: dir-else/else.config:3:5: Invalid subsection "_" # Multiline string marking: # ^When using configuration from:$ # ^ - else.project$ From eededa4b618f71645d080c67d02bd1cf306cef2d Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 10 Jan 2025 22:36:40 +0100 Subject: [PATCH 41/41] Fix T5213 cabal.out warning order --- cabal-testsuite/PackageTests/Regression/T5213/cabal.out | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal-testsuite/PackageTests/Regression/T5213/cabal.out b/cabal-testsuite/PackageTests/Regression/T5213/cabal.out index f6822f77978..aa24fa632ca 100644 --- a/cabal-testsuite/PackageTests/Regression/T5213/cabal.out +++ b/cabal-testsuite/PackageTests/Regression/T5213/cabal.out @@ -1,7 +1,7 @@ # cabal new-test +Warning: /cabal.project:4:3: The field "library-coverage" is deprecated in the Cabal specification version 1.22. Please use 'coverage' field instead. Configuration is affected by the following files: - cabal.project -Warning: /cabal.project:4:3: The field "library-coverage" is deprecated in the Cabal specification version 1.22. Please use 'coverage' field instead. Resolving dependencies... Build profile: -w ghc- -O1 In order, the following will be built: