From 1da944fc4fa7be7d00955f6ff1b3c316d6ead11e Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Tue, 21 Jul 2026 14:19:13 -0400 Subject: [PATCH 01/37] Add parseProjectConfig --- .../Client/ProjectConfig/Parsec.hs | 30 +++++++++++-------- .../Distribution/Client/ProjectConfig.hs | 1 + 2 files changed, 19 insertions(+), 12 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index 7893e03300a..c7477837a62 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -4,6 +4,7 @@ module Distribution.Client.ProjectConfig.Parsec ( -- * Package configuration parseProject + , parseProjectConfig , ProjectConfig (..) -- ** Parsing @@ -174,18 +175,6 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project parseImport :: Position -> [FieldLine Position] -> ParseResult ProjectFileSource 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 ProjectFileSource ProjectConfig - fieldsToConfig sourceConfigPath xs = do - let (fs, sectionGroups) = partitionFields xs - sections = concat sectionGroups - config <- parseFieldGrammarCheckingStanzas cabalSpec fs (projectConfigFieldGrammar sourceConfigPath (knownProgramNames programDb)) stanzas - config' <- view stateConfig <$> execStateT (goSections programDb sections) (SectionS config) - return config' modifiesCompiler :: ProjectConfig -> Bool modifiesCompiler pc = isSet projectConfigHcFlavor || isSet projectConfigHcPath || isSet projectConfigHcPkg where @@ -199,8 +188,25 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project sanityWalkBranch :: CondBranch ConfVar ([(Maybe URI, ProjectConfigPath)], ProjectConfig) -> ParseResult ProjectFileSource () sanityWalkBranch (CondBranch _c t f) = traverse_ (sanityWalkPCS True) f >> sanityWalkPCS True t >> pure () +-- 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 ProjectFileSource ProjectConfig +fieldsToConfig sourceConfigPath xs = do + let (fs, sectionGroups) = partitionFields xs + sections = concat sectionGroups + config <- parseFieldGrammarCheckingStanzas cabalSpec fs (projectConfigFieldGrammar sourceConfigPath (knownProgramNames programDb)) stanzas + config' <- view stateConfig <$> execStateT (goSections programDb sections) (SectionS config) + return config' + where programDb = defaultProgramDb +parseProjectConfig :: FilePath -> BS.ByteString -> ParseResult ProjectFileSource ProjectConfig +parseProjectConfig rootConfig bs = + fieldsToConfig (ProjectConfigPath $ rootConfig :| []) =<< readPreprocessFields bs + startOfSection :: Position -> [SectionArg Position] -> Position -- The case where we have no args is the start of the section startOfSection defaultPos [] = defaultPos diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 5b581437f82..3109d18fa62 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -49,6 +49,7 @@ import Distribution.Solver.Types.Settings import Distribution.Client.ProjectConfig import Distribution.Client.ProjectConfig.Legacy +import Distribution.Client.ProjectConfig.Parsec import UnitTests.Distribution.Client.ArbitraryInstances import UnitTests.Distribution.Client.TreeDiffInstances () From 88ec28ed27c9259c4b3f3cd993dc08ff03c9fdf0 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Tue, 21 Jul 2026 14:20:02 -0400 Subject: [PATCH 02/37] Update test to use parseProjectConfig --- .../tests/UnitTests/Distribution/Client/ProjectConfig.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 3109d18fa62..d0c54f9f7d4 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -18,7 +18,6 @@ import System.Directory (canonicalizePath, withCurrentDirectory) import System.FilePath import System.IO.Unsafe (unsafePerformIO) -import Distribution.Deprecated.ParseUtils import qualified Distribution.Deprecated.ReadP as Parse import Distribution.Package @@ -261,11 +260,11 @@ prop_roundtrip_legacytypes_specific config = roundtrip_printparse :: ProjectConfig -> Property roundtrip_printparse config = - case fmap convertLegacyProjectConfig (parseLegacyProjectConfig "unused" (toUTF8BS str)) of - ParseOk _ x -> + case runParseResult $ parseProjectConfig "unused" (toUTF8BS str) of + (_, Right x) -> counterexample ("shown:\n" ++ str) $ x `ediffEq` config{projectConfigProvenance = mempty} - ParseFailed err -> counterexample ("shown:\n" ++ str ++ "\nERROR: " ++ show err) False + (_, Left err) -> counterexample ("shown:\n" ++ str ++ "\nERROR: " ++ show err) False where str :: String str = showLegacyProjectConfig (convertToLegacyProjectConfig config) From 18ccaadc784728bd7e4dc263740882eb56831c9e Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Tue, 21 Jul 2026 15:59:21 -0400 Subject: [PATCH 03/37] Add more specific test names --- .../UnitTests/Distribution/Client/ProjectConfig.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index d0c54f9f7d4..2b6e158df4f 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -79,12 +79,12 @@ tests = ] , testGroup "ProjectConfig printing/parsing round trip" - [ testProperty "packages" prop_roundtrip_printparse_packages - , testProperty "buildonly" prop_roundtrip_printparse_buildonly - , testProperty "shared" prop_roundtrip_printparse_shared - , testProperty "local" prop_roundtrip_printparse_local - , testProperty "specific" prop_roundtrip_printparse_specific - , testProperty "all" prop_roundtrip_printparse_all + [ testProperty "round trip packages" prop_roundtrip_printparse_packages + , testProperty "round trip buildonly" prop_roundtrip_printparse_buildonly + , testProperty "round trip shared" prop_roundtrip_printparse_shared + , testProperty "round trip local" prop_roundtrip_printparse_local + , testProperty "round trip specific" prop_roundtrip_printparse_specific + , testProperty "round trip all" prop_roundtrip_printparse_all ] , testGetProjectRootUsability , testFindProjectRoot From 6c7cbd0ec27d0a534044a9d64b2d49a3a4495b46 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Tue, 21 Jul 2026 16:15:40 -0400 Subject: [PATCH 04/37] Clear provenance before comparison --- .../tests/UnitTests/Distribution/Client/ProjectConfig.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 2b6e158df4f..335ec9dbe78 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -261,9 +261,11 @@ prop_roundtrip_legacytypes_specific config = roundtrip_printparse :: ProjectConfig -> Property roundtrip_printparse config = case runParseResult $ parseProjectConfig "unused" (toUTF8BS str) of - (_, Right x) -> + (_, Right result) -> counterexample ("shown:\n" ++ str) $ - x `ediffEq` config{projectConfigProvenance = mempty} + ediffEq + result{projectConfigProvenance = mempty} + config{projectConfigProvenance = mempty} (_, Left err) -> counterexample ("shown:\n" ++ str ++ "\nERROR: " ++ show err) False where str :: String From 6ddcb9294a339ffb80a4f90cd675e47366f49dd6 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Wed, 22 Jul 2026 10:14:57 -0400 Subject: [PATCH 05/37] Add boolean parsing for debug info - Add haddocks for flagToDebugInfoLevel --- Cabal/src/Distribution/Simple/Compiler.hs | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/Cabal/src/Distribution/Simple/Compiler.hs b/Cabal/src/Distribution/Simple/Compiler.hs index 507de08a172..2966d4140ea 100644 --- a/Cabal/src/Distribution/Simple/Compiler.hs +++ b/Cabal/src/Distribution/Simple/Compiler.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Distribution.Simple.Compiler @@ -454,6 +455,20 @@ parsecDebugInfoLevel = boolParser <|> intParser boolParser = bool NoDebugInfo NormalDebugInfo <$> parsec intParser = intToEnum "debug info level" <$> integral +-- | Converts a string to a 'DebugInfoLevel'. The string can be either a boolean +-- or 0-based integer for that enum. Evaluates to the default of 'NoDebugInfo' +-- when there's no string or when the string is "False". When the string is +-- "True", the level is 'NormalDebugInfo'. These string comparisons are +-- case-insensitive. +-- +-- >>> [flagToDebugInfoLevel (Just $ show n) | n <- [0 .. 3]] +-- [NoDebugInfo,MinimalDebugInfo,NormalDebugInfo,MaximalDebugInfo] +-- +-- >>> nub $ flagToDebugInfoLevel . Just <$> ["0", "False", "false"] +-- [NoDebugInfo] +-- +-- >>> nub $ flagToDebugInfoLevel <$> Nothing : (Just <$> ["2", "True", "true"]) +-- [NormalDebugInfo] flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel flagToDebugInfoLevel Nothing = NormalDebugInfo flagToDebugInfoLevel (Just s) From 17aefe5e07212ea32a7c8fd21d2cfe1efac662cb Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Wed, 22 Jul 2026 10:20:09 -0400 Subject: [PATCH 06/37] Add haddocks to default and enabled levels --- Cabal/src/Distribution/Simple/Compiler.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Cabal/src/Distribution/Simple/Compiler.hs b/Cabal/src/Distribution/Simple/Compiler.hs index 2966d4140ea..2b7f5c4c495 100644 --- a/Cabal/src/Distribution/Simple/Compiler.hs +++ b/Cabal/src/Distribution/Simple/Compiler.hs @@ -437,8 +437,10 @@ flagToOptimisationLevel (Just s) -- level they do support. data DebugInfoLevel = NoDebugInfo + -- ^ The default and disabled level. Disabled by @--disable-debug-info@ or @debug-info: False@. | MinimalDebugInfo | NormalDebugInfo + -- ^ The enabled level when enabled by @--enable-debug-info@ or @debug-info: True@. | MaximalDebugInfo deriving (Bounded, Enum, Eq, Generic, Read, Show) From 0bb1f762d6440f68e64afc41212b0efb3102cac2 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Wed, 22 Jul 2026 10:52:50 -0400 Subject: [PATCH 07/37] Add parsing debug-info test --- .../PackageTests/ProjectConfig/DebugInfo/cabal.project | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 cabal-testsuite/PackageTests/ProjectConfig/DebugInfo/cabal.project diff --git a/cabal-testsuite/PackageTests/ProjectConfig/DebugInfo/cabal.project b/cabal-testsuite/PackageTests/ProjectConfig/DebugInfo/cabal.project new file mode 100644 index 00000000000..ba2822430f8 --- /dev/null +++ b/cabal-testsuite/PackageTests/ProjectConfig/DebugInfo/cabal.project @@ -0,0 +1,2 @@ +optional-packages: . +debug-info: True From 1c904f8f86917b291271b1ac3b282e94a2e7890f Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Tue, 28 Jul 2026 10:17:24 -0400 Subject: [PATCH 08/37] WIP --- Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs | 6 ++++++ cabal-install/parser-tests/Tests/ParserTests.hs | 10 +++++++++- .../Tests/files/packages/cabal.comma-separated.project | 5 +++++ .../parser-tests/Tests/files/packages/cabal.project | 1 + .../src/Distribution/Client/ProjectConfig/Legacy.hs | 7 +++++++ 5 files changed, 28 insertions(+), 1 deletion(-) create mode 100644 cabal-install/parser-tests/Tests/files/packages/cabal.comma-separated.project diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs index b99805f1e06..f6407023240 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs @@ -140,6 +140,12 @@ newtype List sep b a = List {_getList :: [a]} -- -- >>> :t alaList' FSep Token -- alaList' FSep Token :: [Text] -> List FSep Token Text +-- +-- >>> unpack' (alaList' FSep Token) <$> eitherParsec "foo bar foo" +-- Right ["foo","bar","foo"] +-- +-- >>> unpack' (alaList' FSep Token) <$> eitherParsec "xL{4,IE-,eK<}fE?e" +-- Right ["xL{4","IE-","eK<}fE?e"] alaList :: sep -> [a] -> List sep (Identity a) a alaList _ = List diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index 36c54be6849..17c60be52f9 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -73,6 +73,7 @@ parserTests = testGroup "project files parsec tests" [ testCase "read packages" testPackages + , testCase "read packages comma separated" testPackagesCommaSeparated , testCase "read optional-packages" testOptionalPackages , testCase "read extra-packages" testExtraPackages , testCase "read source-repository-package" testSourceRepoList @@ -98,10 +99,17 @@ parserTests = testPackages :: Assertion testPackages = do - let expected = [".", "packages/packages.cabal"] + let expected = [".", "packages/packages.cabal","a","b"] (config, legacy) <- readConfigDefault "packages" assertConfigEquals expected config legacy (projectPackages . snd . condTreeData) +testPackagesCommaSeparated :: Assertion +testPackagesCommaSeparated = do + let expected = ["xL{4,IE-,eK<}fE?e"] + --let expected = ["xL{4","IE-","eK<}fE?e"] + (config, legacy) <- readConfig "packages" "cabal.comma-separated.project" + assertConfigEquals expected config legacy (projectPackages . snd . condTreeData) + testOptionalPackages :: Assertion testOptionalPackages = do let expected = [".", "packages/packages.cabal"] diff --git a/cabal-install/parser-tests/Tests/files/packages/cabal.comma-separated.project b/cabal-install/parser-tests/Tests/files/packages/cabal.comma-separated.project new file mode 100644 index 00000000000..9b96d57edd5 --- /dev/null +++ b/cabal-install/parser-tests/Tests/files/packages/cabal.comma-separated.project @@ -0,0 +1,5 @@ +-- This example was generated for the property test "round trip packages" and +-- resulted in this reported difference: +-- projectPackages = [-"xL{4", -"IE-", -"eK<}fE?e", +"xL{4,IE-,eK<}fE?e"] +-- projectPackages = [-"7{u", -"{h", -"{=n}}}", +"7{u,{h,{=n}}}"] +packages: xL{4,IE-,eK<}fE?e diff --git a/cabal-install/parser-tests/Tests/files/packages/cabal.project b/cabal-install/parser-tests/Tests/files/packages/cabal.project index 6d9d4728a55..2fec31f920a 100644 --- a/cabal-install/parser-tests/Tests/files/packages/cabal.project +++ b/cabal-install/parser-tests/Tests/files/packages/cabal.project @@ -1 +1,2 @@ packages: . packages/packages.cabal +packages: a,b diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index 099c0ea5c34..a6d4f064c7f 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -1267,6 +1267,13 @@ showLegacyProjectConfig config = -- but requires re-work of how we annotate provenance. constraintSrc = ConstraintSourceProjectConfig nullProjectConfigPath +-- | +-- +-- :{ +-- fields <- readFields "packages: foo" +-- parseFieldsAndSections (legacyProjectConfigFieldDescrs ConstraintSourceUnknown fields) mempty +-- :} +-- legacyProjectConfigFieldDescrs :: ConstraintSource -> [FieldDescr LegacyProjectConfig] legacyProjectConfigFieldDescrs constraintSrc = [ newLineListField From 9b5ffca149b7acfdfc2321ced7fc7afb992d882d Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Tue, 28 Jul 2026 10:46:58 -0400 Subject: [PATCH 09/37] Add doctests for parsing legacy packages --- .../Client/ProjectConfig/Legacy.hs | 25 ++++++++++++++++--- 1 file changed, 21 insertions(+), 4 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index a6d4f064c7f..7a68d7a32cc 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -1242,6 +1242,13 @@ convertToLegacyPerPackageConfig PackageConfig{..} = parseLegacyProjectConfigFields :: ProjectConfigPath -> [ParseUtils.Field] -> ParseResult LegacyProjectConfig parseLegacyProjectConfigFields (ConstraintSourceProjectConfig -> constraintSrc) = + parseLegacyProjectConfigFieldsWithConstraintSource constraintSrc + +parseLegacyProjectConfigFieldsWithConstraintSource + :: ConstraintSource + -> [ParseUtils.Field] + -> ParseResult LegacyProjectConfig +parseLegacyProjectConfigFieldsWithConstraintSource constraintSrc = parseFieldsAndSections (legacyProjectConfigFieldDescrs constraintSrc) legacyPackageConfigSectionDescrs @@ -1268,12 +1275,14 @@ showLegacyProjectConfig config = constraintSrc = ConstraintSourceProjectConfig nullProjectConfigPath -- | +-- >>> parseLegacyPackages "foo" +-- ParseOk [] ["foo"] -- --- :{ --- fields <- readFields "packages: foo" --- parseFieldsAndSections (legacyProjectConfigFieldDescrs ConstraintSourceUnknown fields) mempty --- :} +-- >>> parseLegacyPackages "xL{4,IE-,eK<}fE?e" +-- ParseOk [] ["xL{4,IE-,eK<}fE?e"] -- +-- >>> parseLegacyPackages "7{u,{h,{=n}}}" +-- ParseOk [] ["7{u,{h,{=n}}}"] legacyProjectConfigFieldDescrs :: ConstraintSource -> [FieldDescr LegacyProjectConfig] legacyProjectConfigFieldDescrs constraintSrc = [ newLineListField @@ -2063,3 +2072,11 @@ showTokenQ "" = Disp.empty showTokenQ x@('-' : '-' : _) = Disp.text (show x) showTokenQ x@['.'] = Disp.text (show x) showTokenQ x = showToken x + +-- $setup +-- >>> :{ +-- parseLegacyPackages s = legacyPackages <$> +-- parseLegacyProjectConfigFieldsWithConstraintSource +-- ConstraintSourceUnknown +-- [ParseUtils.F 1 "packages" s] +-- :} From eec798ac039297512d7e7c7a31e0f612ede052a8 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Tue, 28 Jul 2026 11:06:26 -0400 Subject: [PATCH 10/37] Add packages glob parser test --- cabal-install/parser-tests/Tests/ParserTests.hs | 7 +++++++ .../parser-tests/Tests/files/packages/cabal.glob.project | 3 +++ 2 files changed, 10 insertions(+) create mode 100644 cabal-install/parser-tests/Tests/files/packages/cabal.glob.project diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index 17c60be52f9..563205fa9d5 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -73,6 +73,7 @@ parserTests = testGroup "project files parsec tests" [ testCase "read packages" testPackages + , testCase "read packages glob" testPackagesGlob , testCase "read packages comma separated" testPackagesCommaSeparated , testCase "read optional-packages" testOptionalPackages , testCase "read extra-packages" testExtraPackages @@ -103,6 +104,12 @@ testPackages = do (config, legacy) <- readConfigDefault "packages" assertConfigEquals expected config legacy (projectPackages . snd . condTreeData) +testPackagesGlob :: Assertion +testPackagesGlob = do + let expected = ["*/*.cabal", "../{foo,bar}/"] + (config, legacy) <- readConfig "packages" "cabal.glob.project" + assertConfigEquals expected config legacy (projectPackages . snd . condTreeData) + testPackagesCommaSeparated :: Assertion testPackagesCommaSeparated = do let expected = ["xL{4,IE-,eK<}fE?e"] diff --git a/cabal-install/parser-tests/Tests/files/packages/cabal.glob.project b/cabal-install/parser-tests/Tests/files/packages/cabal.glob.project new file mode 100644 index 00000000000..e66b0a05bab --- /dev/null +++ b/cabal-install/parser-tests/Tests/files/packages/cabal.glob.project @@ -0,0 +1,3 @@ +-- The glob pattern syntax example from the users guide. +-- https://github.com/haskell/cabal/blob/d8c1b6f68df0a736c32a15ae85db9ffaf002ecb8/doc/cabal-project-description-file.rst?plain=1#L146 +packages: */*.cabal ../{foo,bar}/ From 06dab732842627c91075258564a4115e1e0b45b0 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Tue, 28 Jul 2026 12:32:38 -0400 Subject: [PATCH 11/37] Add a glob test for optional packages --- cabal-install/parser-tests/Tests/ParserTests.hs | 7 +++++++ .../Tests/files/optional-packages/cabal.glob.project | 3 +++ 2 files changed, 10 insertions(+) create mode 100644 cabal-install/parser-tests/Tests/files/optional-packages/cabal.glob.project diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index 563205fa9d5..ff06921093b 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -76,6 +76,7 @@ parserTests = , testCase "read packages glob" testPackagesGlob , testCase "read packages comma separated" testPackagesCommaSeparated , testCase "read optional-packages" testOptionalPackages + , testCase "read optional-packages glob" testOptionalPackagesGlob , testCase "read extra-packages" testExtraPackages , testCase "read source-repository-package" testSourceRepoList , testCase "read project-config-build-only" testProjectConfigBuildOnly @@ -123,6 +124,12 @@ testOptionalPackages = do (config, legacy) <- readConfigDefault "optional-packages" assertConfigEquals expected config legacy (projectPackagesOptional . snd . condTreeData) +testOptionalPackagesGlob :: Assertion +testOptionalPackagesGlob = do + let expected = ["*/*.cabal", "../{foo,bar}/"] + (config, legacy) <- readConfig "optional-packages" "cabal.glob.project" + assertConfigEquals expected config legacy (projectPackagesOptional . snd . condTreeData) + testSourceRepoList :: Assertion testSourceRepoList = do (config, legacy) <- readConfigDefault "source-repository-packages" diff --git a/cabal-install/parser-tests/Tests/files/optional-packages/cabal.glob.project b/cabal-install/parser-tests/Tests/files/optional-packages/cabal.glob.project new file mode 100644 index 00000000000..fbd2bd4aafe --- /dev/null +++ b/cabal-install/parser-tests/Tests/files/optional-packages/cabal.glob.project @@ -0,0 +1,3 @@ +-- The glob pattern syntax example from the users guide. +-- https://github.com/haskell/cabal/blob/d8c1b6f68df0a736c32a15ae85db9ffaf002ecb8/doc/cabal-project-description-file.rst?plain=1#L146 +optional-packages: */*.cabal ../{foo,bar}/ From 48542322afcacba32e2be035721a92dd0bd2fb32 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Tue, 28 Jul 2026 12:35:34 -0400 Subject: [PATCH 12/37] Add a glob parser for package location --- .../Client/ProjectConfig/FieldGrammar.hs | 53 ++++++++++++++++++- 1 file changed, 51 insertions(+), 2 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs index 9ba089bca17..d4be973e3e9 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs @@ -15,19 +15,24 @@ import Distribution.Client.CmdInstall.ClientInstallFlags (clientInstallFlagsGram import qualified Distribution.Client.ProjectConfig.Lens as L import Distribution.Client.ProjectConfig.Types (PackageConfig (..), ProjectConfig (..), ProjectConfigBuildOnly (..), ProjectConfigProvenance (..), ProjectConfigShared (..)) import Distribution.Client.Utils.Parsec +import qualified Distribution.Compat.CharParsing as P +import Distribution.Compat.Newtype (Newtype) import Distribution.Compat.Prelude import Distribution.FieldGrammar +import Distribution.Parsec (CabalParsing, Parsec (..), parsecHaskellString) +import Distribution.Pretty (Pretty (..)) import Distribution.Simple.Flag import Distribution.Simple.InstallDirs import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) import Distribution.Solver.Types.ProjectConfigPath import Distribution.Solver.Types.Settings (PreferVersion (..)) import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..)) +import qualified Text.PrettyPrint as PP projectConfigFieldGrammar :: ProjectConfigPath -> [String] -> ParsecFieldGrammar' ProjectConfig projectConfigFieldGrammar source knownPrograms = do - projectPackages <- monoidalFieldAla "packages" (alaList' FSep Token) L.projectPackages - projectPackagesOptional <- monoidalFieldAla "optional-packages" (alaList' FSep Token) L.projectPackagesOptional + projectPackages <- monoidalFieldAla "packages" (alaList' FSep PackageLocationToken) L.projectPackages + projectPackagesOptional <- monoidalFieldAla "optional-packages" (alaList' FSep PackageLocationToken) L.projectPackagesOptional let projectPackagesRepo = mempty projectPackagesNamed <- monoidalFieldAla "extra-packages" formatPackageVersionConstraints L.projectPackagesNamed projectConfigBuildOnly <- blurFieldGrammar L.projectConfigBuildOnly projectConfigBuildOnlyFieldGrammar @@ -38,6 +43,50 @@ projectConfigFieldGrammar source knownPrograms = do projectConfigLocalPackages <- blurFieldGrammar L.projectConfigLocalPackages (packageConfigFieldGrammar knownPrograms) pure ProjectConfig{..} +newtype PackageLocationToken = PackageLocationToken {getPackageLocationToken :: String} + +instance Newtype String PackageLocationToken + +instance Parsec PackageLocationToken where + parsec = PackageLocationToken <$> parsePackageLocationTokenQ + +instance Pretty PackageLocationToken where + pretty = PP.text . renderPackageLocationToken . getPackageLocationToken + +-- | This matches legacy parsing for @packages@ and @optional-packages@: +-- supports quoted strings, and for unquoted tokens allows commas only inside +-- balanced braces (e.g. ../{foo,bar}/). +parsePackageLocationTokenQ :: CabalParsing m => m String +parsePackageLocationTokenQ = parsecHaskellString <|> parsePackageLocationToken + where + parsePackageLocationToken = concat <$> some outerTerm + outerTerm = outerToken <|> braces innerTerm + innerTerm = concat <$> many (innerToken <|> braces innerTerm) + outerToken = P.munch1 outerChar + innerToken = P.munch1 innerChar + outerChar c = not (isSpace c || c == '{' || c == '}' || c == ',') + innerChar c = not (isSpace c || c == '{' || c == '}') + braces p = ("{" <>) . (<> "}") <$> P.between (P.char '{') (P.char '}') p + +renderPackageLocationToken :: String -> String +renderPackageLocationToken s + | needsQuoting = show s + | otherwise = s + where + needsQuoting = + not (ok 0 s) + || s == "." -- . on its own on a line has special meaning + || take 2 s == "--" -- on its own line is comment syntax + ok :: Int -> String -> Bool + ok n [] = n == 0 + ok _ ('"' : _) = False + ok n ('{' : cs) = ok (n + 1) cs + ok n ('}' : cs) = ok (n - 1) cs + ok n (',' : cs) = (n > 0) && ok n cs + ok _ (c : _) + | isSpace c = False + ok n (_ : cs) = ok n cs + formatPackageVersionConstraints :: [PackageVersionConstraint] -> List CommaVCat (Identity PackageVersionConstraint) PackageVersionConstraint formatPackageVersionConstraints = alaList CommaVCat From d28d44100dc1043a493e4615706136550db1df55 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Tue, 28 Jul 2026 12:43:23 -0400 Subject: [PATCH 13/37] Avoid the use of Newtype --- .../Client/ProjectConfig/FieldGrammar.hs | 25 ++++++++++++------- 1 file changed, 16 insertions(+), 9 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs index d4be973e3e9..96e2f78d444 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs @@ -16,7 +16,7 @@ import qualified Distribution.Client.ProjectConfig.Lens as L import Distribution.Client.ProjectConfig.Types (PackageConfig (..), ProjectConfig (..), ProjectConfigBuildOnly (..), ProjectConfigProvenance (..), ProjectConfigShared (..)) import Distribution.Client.Utils.Parsec import qualified Distribution.Compat.CharParsing as P -import Distribution.Compat.Newtype (Newtype) +import Distribution.Compat.Lens (Lens') import Distribution.Compat.Prelude import Distribution.FieldGrammar import Distribution.Parsec (CabalParsing, Parsec (..), parsecHaskellString) @@ -31,8 +31,8 @@ import qualified Text.PrettyPrint as PP projectConfigFieldGrammar :: ProjectConfigPath -> [String] -> ParsecFieldGrammar' ProjectConfig projectConfigFieldGrammar source knownPrograms = do - projectPackages <- monoidalFieldAla "packages" (alaList' FSep PackageLocationToken) L.projectPackages - projectPackagesOptional <- monoidalFieldAla "optional-packages" (alaList' FSep PackageLocationToken) L.projectPackagesOptional + projectPackages <- getPackageLocationTokens <$> monoidalField "packages" ignoredLens + projectPackagesOptional <- getPackageLocationTokens <$> monoidalField "optional-packages" ignoredLens let projectPackagesRepo = mempty projectPackagesNamed <- monoidalFieldAla "extra-packages" formatPackageVersionConstraints L.projectPackagesNamed projectConfigBuildOnly <- blurFieldGrammar L.projectConfigBuildOnly projectConfigBuildOnlyFieldGrammar @@ -43,15 +43,22 @@ projectConfigFieldGrammar source knownPrograms = do projectConfigLocalPackages <- blurFieldGrammar L.projectConfigLocalPackages (packageConfigFieldGrammar knownPrograms) pure ProjectConfig{..} -newtype PackageLocationToken = PackageLocationToken {getPackageLocationToken :: String} +newtype PackageLocationTokens = PackageLocationTokens {getPackageLocationTokens :: [String]} -instance Newtype String PackageLocationToken +instance Semigroup PackageLocationTokens where + PackageLocationTokens a <> PackageLocationTokens b = PackageLocationTokens (a <> b) -instance Parsec PackageLocationToken where - parsec = PackageLocationToken <$> parsePackageLocationTokenQ +instance Monoid PackageLocationTokens where + mempty = PackageLocationTokens mempty -instance Pretty PackageLocationToken where - pretty = PP.text . renderPackageLocationToken . getPackageLocationToken +instance Parsec PackageLocationTokens where + parsec = PackageLocationTokens <$> parseSep (Proxy :: Proxy FSep) parsePackageLocationTokenQ + +instance Pretty PackageLocationTokens where + pretty = prettySep (Proxy :: Proxy FSep) . map (PP.text . renderPackageLocationToken) . getPackageLocationTokens + +ignoredLens :: Lens' ProjectConfig PackageLocationTokens +ignoredLens f s = s <$ f mempty -- | This matches legacy parsing for @packages@ and @optional-packages@: -- supports quoted strings, and for unquoted tokens allows commas only inside From d1f9d50b9dd93fcd23e9ecab8e7dea5d30f96d38 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Thu, 30 Jul 2026 10:56:25 -0400 Subject: [PATCH 14/37] For roundtripping, show delimited lines too --- .../tests/UnitTests/Distribution/Client/ProjectConfig.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 335ec9dbe78..8d6343f207e 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -259,17 +259,19 @@ prop_roundtrip_legacytypes_specific config = -- roundtrip_printparse :: ProjectConfig -> Property -roundtrip_printparse config = +roundtrip_printparse config = countering $ case runParseResult $ parseProjectConfig "unused" (toUTF8BS str) of (_, Right result) -> - counterexample ("shown:\n" ++ str) $ ediffEq result{projectConfigProvenance = mempty} config{projectConfigProvenance = mempty} - (_, Left err) -> counterexample ("shown:\n" ++ str ++ "\nERROR: " ++ show err) False + (_, Left err) -> counterexample ("ERROR: " ++ show err) False where str :: String str = showLegacyProjectConfig (convertToLegacyProjectConfig config) + countering = + counterexample ("shown:\n" ++ str) . + counterexample ("shown by line:\n" ++ unlines (map (\s -> "'" ++ s ++ "'") (lines str))) prop_roundtrip_printparse_all :: ProjectConfig -> Property prop_roundtrip_printparse_all config = From a264f03dde9fa6934dc5764dfc39f54eeaaa569d Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Thu, 30 Jul 2026 10:56:53 -0400 Subject: [PATCH 15/37] Add doctests for project parsers --- .../Client/ProjectConfig/Legacy.hs | 34 +++++++++++++++--- .../Client/ProjectConfig/Parsec.hs | 36 +++++++++++++++++++ 2 files changed, 65 insertions(+), 5 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index 7a68d7a32cc..a06849b5de3 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -1275,14 +1275,29 @@ showLegacyProjectConfig config = constraintSrc = ConstraintSourceProjectConfig nullProjectConfigPath -- | --- >>> parseLegacyPackages "foo" +-- >>> parseLegacyConvert projectPackages "packages" "foo" -- ParseOk [] ["foo"] -- --- >>> parseLegacyPackages "xL{4,IE-,eK<}fE?e" +-- >>> parseLegacyConvert projectPackages "packages" "xL{4,IE-,eK<}fE?e" -- ParseOk [] ["xL{4,IE-,eK<}fE?e"] -- --- >>> parseLegacyPackages "7{u,{h,{=n}}}" +-- >>> parseLegacyConvert projectPackages "packages" "7{u,{h,{=n}}}" -- ParseOk [] ["7{u,{h,{=n}}}"] +-- +-- >>> parseLegacyConvert (packageConfigTestHumanLog . projectConfigAllPackages) "test-log" "" +-- ParseOk [] (Last {getLast = Nothing}) +-- +-- >>> parseLegacyConvert (packageConfigTestHumanLog . projectConfigAllPackages) "test-log" " " +-- ParseOk [] (Last {getLast = Nothing}) +-- +-- >>> parseLegacyConvert (packageConfigTestHumanLog . projectConfigAllPackages) "test-log" " \n" +-- ParseOk [] (Last {getLast = Nothing}) +-- +-- >>> parseLegacyConvert (packageConfigHaddockHtmlLocation . projectConfigAllPackages) "haddock-html-location" "" +-- ParseOk [] (Last {getLast = Nothing}) +-- +-- >>> parseLegacyConvert (packageConfigHaddockHtmlLocation . projectConfigAllPackages) "haddock-html-location" " " +-- ParseOk [] (Last {getLast = Nothing}) legacyProjectConfigFieldDescrs :: ConstraintSource -> [FieldDescr LegacyProjectConfig] legacyProjectConfigFieldDescrs constraintSrc = [ newLineListField @@ -2075,8 +2090,17 @@ showTokenQ x = showToken x -- $setup -- >>> :{ --- parseLegacyPackages s = legacyPackages <$> +-- parseLegacy :: (LegacyProjectConfig -> a) -> String -> String -> ParseResult a +-- parseLegacy f field s = f <$> +-- parseLegacyProjectConfigFieldsWithConstraintSource +-- ConstraintSourceUnknown +-- [ParseUtils.F 1 field s] +-- :} +-- +-- >>> :{ +-- parseLegacyConvert :: (ProjectConfig -> a) -> String -> String -> ParseResult a +-- parseLegacyConvert f field s = (f . convertLegacyProjectConfig) <$> -- parseLegacyProjectConfigFieldsWithConstraintSource -- ConstraintSourceUnknown --- [ParseUtils.F 1 "packages" s] +-- [ParseUtils.F 1 field s] -- :} diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index c7477837a62..179272d1fef 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -203,6 +203,30 @@ fieldsToConfig sourceConfigPath xs = do where programDb = defaultProgramDb +-- | +-- >>> parseParsec projectPackages "packages" "foo" +-- ([],Right ["foo"]) +-- +-- >>> parseParsec projectPackages "packages" "xL{4,IE-,eK<}fE?e" +-- ([],Right ["xL{4,IE-,eK<}fE?e"]) +-- +-- >>> parseParsec projectPackages "packages" "7{u,{h,{=n}}}" +-- ([],Right ["7{u,{h,{=n}}}"]) +-- +-- >>> parseParsec projectPackages "test-log" "" +-- ([],Right []) +-- +-- >>> parseParsec (packageConfigTestHumanLog . projectConfigAllPackages) "test-log" " " +-- ([],Right (Last {getLast = Nothing})) +-- +-- >>> parseParsec (packageConfigTestHumanLog . projectConfigAllPackages) "test-log" " \n" +-- ([],Right (Last {getLast = Nothing})) + +-- >>> parseParsec (packageConfigHaddockHtmlLocation . projectConfigAllPackages) "haddock-html-location" "" +-- ([],Right (Last {getLast = Nothing})) + +-- >>> parseParsec (packageConfigHaddockHtmlLocation . projectConfigAllPackages) "haddock-html-location" " " +-- ([],Right (Last {getLast = Nothing})) parseProjectConfig :: FilePath -> BS.ByteString -> ParseResult ProjectFileSource ProjectConfig parseProjectConfig rootConfig bs = fieldsToConfig (ProjectConfigPath $ rootConfig :| []) =<< readPreprocessFields bs @@ -415,3 +439,15 @@ warnUnknownFields fieldName fieldLines = for_ fieldLines (\field -> parseWarning cabalSpec :: CabalSpecVersion cabalSpec = cabalSpecLatest + +-- $setup +-- >>> :set -XViewPatterns +-- >>> instance (Show a, Show b) => Show (ParseResult a b) where show = show . runParseResult +-- +-- >>> :{ +-- parseParsec :: (ProjectConfig -> a) -> String -> String -> ParseResult ProjectFileSource a +-- parseParsec f (toUTF8BS -> field) (toUTF8BS -> s) = f <$> +-- fieldsToConfig +-- nullProjectConfigPath +-- [Field (Name zeroPos field) [FieldLine zeroPos s]] +-- :} From a018d81fec3240023f9f7f177176d6573004a111 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Thu, 30 Jul 2026 10:57:19 -0400 Subject: [PATCH 16/37] Add empty string local parser test --- cabal-install/parser-tests/Tests/ParserTests.hs | 9 +++++++++ .../cabal.empty-string.project | 1 + 2 files changed, 10 insertions(+) create mode 100644 cabal-install/parser-tests/Tests/files/project-config-local-packages/cabal.empty-string.project diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index ff06921093b..12c0e4fb86f 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -86,6 +86,7 @@ parserTests = , testCase "read local-no-index-repos" testLocalNoIndexRepos , testCase "set explicit provenance" testProjectConfigProvenance , testCase "read project-config-local-packages" testProjectConfigLocalPackages + , testCase "read project-config-local-packages-empty-string" testProjectConfigLocalPackagesEmptyString , testCase "read project-config-all-packages" testProjectConfigAllPackages , testCase "read project-config-specific-packages" testProjectConfigSpecificPackages , testCase "test projectConfigAllPackages concatenation" testAllPackagesConcat @@ -419,6 +420,14 @@ testProjectConfigLocalPackages = do packageConfigTestTestOptions = [toPathTemplate "--some-option", toPathTemplate "42"] packageConfigBenchmarkOptions = [toPathTemplate "--some-benchmark-option", toPathTemplate "--another-option"] +testProjectConfigLocalPackagesEmptyString :: Assertion +testProjectConfigLocalPackagesEmptyString = do + (config, legacy) <- readConfig "project-config-local-packages" "cabal.empty-string.project" + assertConfigEquals expected config legacy (field . projectConfigLocalPackages . snd . condTreeData) + where + field = packageConfigTestHumanLog + expected = NoFlag + testProjectConfigAllPackages :: Assertion testProjectConfigAllPackages = do (config, legacy) <- readConfigDefault "project-config-all-packages" diff --git a/cabal-install/parser-tests/Tests/files/project-config-local-packages/cabal.empty-string.project b/cabal-install/parser-tests/Tests/files/project-config-local-packages/cabal.empty-string.project new file mode 100644 index 00000000000..3a9ccdbc3b6 --- /dev/null +++ b/cabal-install/parser-tests/Tests/files/project-config-local-packages/cabal.empty-string.project @@ -0,0 +1 @@ +test-log: From fa5ac105608b64201d816c3524ea6fa6644b22c7 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Wed, 23 Sep 2026 13:29:54 -0400 Subject: [PATCH 17/37] Satisfy fix-whitespace --- .../project-config-local-packages/cabal.empty-string.project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal-install/parser-tests/Tests/files/project-config-local-packages/cabal.empty-string.project b/cabal-install/parser-tests/Tests/files/project-config-local-packages/cabal.empty-string.project index 3a9ccdbc3b6..94079d00450 100644 --- a/cabal-install/parser-tests/Tests/files/project-config-local-packages/cabal.empty-string.project +++ b/cabal-install/parser-tests/Tests/files/project-config-local-packages/cabal.empty-string.project @@ -1 +1 @@ -test-log: +test-log: From c87aa698f2fc9d40dc76cecd1a6ace98c6cb72a7 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Wed, 23 Sep 2026 13:31:45 -0400 Subject: [PATCH 18/37] Satisfy fourmolu --- Cabal/src/Distribution/Simple/Compiler.hs | 8 ++++---- cabal-install/parser-tests/Tests/ParserTests.hs | 4 ++-- .../UnitTests/Distribution/Client/ProjectConfig.hs | 10 +++++----- 3 files changed, 11 insertions(+), 11 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Compiler.hs b/Cabal/src/Distribution/Simple/Compiler.hs index 2b7f5c4c495..bdf32eb3fa6 100644 --- a/Cabal/src/Distribution/Simple/Compiler.hs +++ b/Cabal/src/Distribution/Simple/Compiler.hs @@ -436,11 +436,11 @@ flagToOptimisationLevel (Just s) -- levels. For compilers that do not the level is just capped to the -- level they do support. data DebugInfoLevel - = NoDebugInfo - -- ^ The default and disabled level. Disabled by @--disable-debug-info@ or @debug-info: False@. + = -- | The default and disabled level. Disabled by @--disable-debug-info@ or @debug-info: False@. + NoDebugInfo | MinimalDebugInfo - | NormalDebugInfo - -- ^ The enabled level when enabled by @--enable-debug-info@ or @debug-info: True@. + | -- | The enabled level when enabled by @--enable-debug-info@ or @debug-info: True@. + NormalDebugInfo | MaximalDebugInfo deriving (Bounded, Enum, Eq, Generic, Read, Show) diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index 12c0e4fb86f..52b92dc267a 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -102,7 +102,7 @@ parserTests = testPackages :: Assertion testPackages = do - let expected = [".", "packages/packages.cabal","a","b"] + let expected = [".", "packages/packages.cabal", "a", "b"] (config, legacy) <- readConfigDefault "packages" assertConfigEquals expected config legacy (projectPackages . snd . condTreeData) @@ -115,7 +115,7 @@ testPackagesGlob = do testPackagesCommaSeparated :: Assertion testPackagesCommaSeparated = do let expected = ["xL{4,IE-,eK<}fE?e"] - --let expected = ["xL{4","IE-","eK<}fE?e"] + -- let expected = ["xL{4","IE-","eK<}fE?e"] (config, legacy) <- readConfig "packages" "cabal.comma-separated.project" assertConfigEquals expected config legacy (projectPackages . snd . condTreeData) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 8d6343f207e..e6bbb18e38a 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -262,16 +262,16 @@ roundtrip_printparse :: ProjectConfig -> Property roundtrip_printparse config = countering $ case runParseResult $ parseProjectConfig "unused" (toUTF8BS str) of (_, Right result) -> - ediffEq - result{projectConfigProvenance = mempty} - config{projectConfigProvenance = mempty} + ediffEq + result{projectConfigProvenance = mempty} + config{projectConfigProvenance = mempty} (_, Left err) -> counterexample ("ERROR: " ++ show err) False where str :: String str = showLegacyProjectConfig (convertToLegacyProjectConfig config) countering = - counterexample ("shown:\n" ++ str) . - counterexample ("shown by line:\n" ++ unlines (map (\s -> "'" ++ s ++ "'") (lines str))) + counterexample ("shown:\n" ++ str) + . counterexample ("shown by line:\n" ++ unlines (map (\s -> "'" ++ s ++ "'") (lines str))) prop_roundtrip_printparse_all :: ProjectConfig -> Property prop_roundtrip_printparse_all config = From 1b6058eeebd0dfcea7683f8d13a6ab512a24b649 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Wed, 23 Sep 2026 13:55:40 -0400 Subject: [PATCH 19/37] Use alternative for removed unpack' --- Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs index f6407023240..ac4b2f31add 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs @@ -141,10 +141,10 @@ newtype List sep b a = List {_getList :: [a]} -- >>> :t alaList' FSep Token -- alaList' FSep Token :: [Text] -> List FSep Token Text -- --- >>> unpack' (alaList' FSep Token) <$> eitherParsec "foo bar foo" +-- >>> _getList <$> (eitherParsec "foo bar foo" :: Either String (List FSep Token String)) -- Right ["foo","bar","foo"] -- --- >>> unpack' (alaList' FSep Token) <$> eitherParsec "xL{4,IE-,eK<}fE?e" +-- >>> _getList <$> (eitherParsec "xL{4,IE-,eK<}fE?e" :: Either String (List FSep Token String)) -- Right ["xL{4","IE-","eK<}fE?e"] alaList :: sep -> [a] -> List sep (Identity a) a alaList _ = List From 46437a62905cd9771c47bda21289c3e305030fd7 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Wed, 23 Sep 2026 14:23:18 -0400 Subject: [PATCH 20/37] Grammar disallows parser setting in project --- .../tests/UnitTests/Distribution/Client/ProjectConfig.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index e6bbb18e38a..4115b00b456 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -593,7 +593,9 @@ instance Arbitrary ProjectConfigShared where projectConfigConfigFile <- arbitraryFlag arbitraryShortToken projectConfigProjectDir <- arbitraryFlag arbitraryShortToken projectConfigProjectFile <- arbitraryFlag arbitraryShortToken - projectConfigProjectFileParser <- arbitraryFlag arbitrary + -- The parser can only be chosen on the command line, not in a project + -- file, so the parsec parser never reads it back. + let projectConfigProjectFileParser = mempty projectConfigIgnoreProject <- arbitrary projectConfigHcFlavor <- arbitrary projectConfigHcPath <- arbitraryFlag arbitraryShortToken From 333cfa8a77f3ee8d156c1513abacf15b338a8b37 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Wed, 23 Sep 2026 14:29:16 -0400 Subject: [PATCH 21/37] Expect negative for max-backjumps --- .../src/Distribution/Client/Utils/Newtypes.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/cabal-install/src/Distribution/Client/Utils/Newtypes.hs b/cabal-install/src/Distribution/Client/Utils/Newtypes.hs index 6bde1e986d1..2dc2393703c 100644 --- a/cabal-install/src/Distribution/Client/Utils/Newtypes.hs +++ b/cabal-install/src/Distribution/Client/Utils/Newtypes.hs @@ -80,8 +80,16 @@ newtype MaxBackjumps = MaxBackjumps {getMaxBackjumps :: Int} instance Parsec MaxBackjumps where parsec = parseMaxBackjumps +-- | A negative number means unlimited backtracking, the same as the +-- @--max-backjumps@ option allows. +-- +-- >>> getMaxBackjumps <$> eitherParsec "4000" +-- Right 4000 +-- +-- >>> getMaxBackjumps <$> eitherParsec "-1" +-- Right (-1) parseMaxBackjumps :: CabalParsing m => m MaxBackjumps -parseMaxBackjumps = MaxBackjumps <$> integral +parseMaxBackjumps = MaxBackjumps <$> signedIntegral newtype AllowNewerNT = AllowNewerNT {getAllowNewerNT :: Maybe AllowNewer} From 6a2f8422176f47c6f9a744171a1eeb90d2e7a811 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Wed, 23 Sep 2026 14:40:15 -0400 Subject: [PATCH 22/37] Avoid empty and whitespace tokens - Legacy parser gave Flag "" - Parsec parser gives NoFlag --- .../Distribution/Client/ArbitraryInstances.hs | 15 ++++++++++----- .../Distribution/Client/ProjectConfig.hs | 14 +++++++------- 2 files changed, 17 insertions(+), 12 deletions(-) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs index 50f41e3eff1..fea9e5694e4 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs @@ -146,17 +146,22 @@ newtype ShortToken = ShortToken {getShortToken :: String} instance Arbitrary ShortToken where arbitrary = ShortToken - <$> ( shortListOf1 5 (choose ('#', '~')) - `suchThat` all (`notElem` "{}") - `suchThat` (not . ("[]" `isPrefixOf`)) - ) + <$> (shortListOf1 5 (choose ('#', '~')) `suchThat` isShortToken) -- TODO: [code cleanup] need to replace parseHaskellString impl to stop -- accepting Haskell list syntax [], ['a'] etc, just allow String syntax. -- Workaround, don't generate [] as this does not round trip. + -- Shrinking a 'Char' can produce a space, so filter shrinks back to what + -- the generator would have produced. shrink (ShortToken cs) = - [ShortToken cs' | cs' <- shrink cs, not (null cs')] + [ShortToken cs' | cs' <- shrink cs, not (null cs'), isShortToken cs'] + +-- | The strings that the 'ShortToken' generator produces. +isShortToken :: String -> Bool +isShortToken cs = + all (\c -> c >= '#' && c <= '~' && c `notElem` "{}") cs + && not ("[]" `isPrefixOf` cs) arbitraryShortToken :: Gen String arbitraryShortToken = getShortToken <$> arbitrary diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 4115b00b456..30170930cb5 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -638,15 +638,15 @@ instance Arbitrary ProjectConfigShared where shrink ProjectConfigShared{..} = runShrinker $ ProjectConfigShared - <$> shrinker projectConfigDistDir - <*> shrinker projectConfigConfigFile - <*> shrinker projectConfigProjectDir - <*> shrinker projectConfigProjectFile + <$> shrinkerAla (fmap ShortToken) projectConfigDistDir + <*> shrinkerAla (fmap ShortToken) projectConfigConfigFile + <*> shrinkerAla (fmap ShortToken) projectConfigProjectDir + <*> shrinkerAla (fmap ShortToken) projectConfigProjectFile <*> shrinker projectConfigProjectFileParser <*> shrinker projectConfigIgnoreProject <*> shrinker projectConfigHcFlavor - <*> shrinkerAla (fmap NonEmpty) projectConfigHcPath - <*> shrinkerAla (fmap NonEmpty) projectConfigHcPkg + <*> shrinkerAla (fmap ShortToken) projectConfigHcPath + <*> shrinkerAla (fmap ShortToken) projectConfigHcPkg <*> shrinker projectConfigHaddockIndex <*> shrinker projectConfigInstallDirs <*> shrinker projectConfigPackageDBs @@ -654,7 +654,7 @@ instance Arbitrary ProjectConfigShared where <*> shrinker projectConfigLocalNoIndexRepos <*> shrinker projectConfigActiveRepos <*> shrinker projectConfigIndexState - <*> shrinker projectConfigStoreDir + <*> shrinkerAla (fmap ShortToken) projectConfigStoreDir <*> shrinkerPP preShrink_Constraints postShrink_Constraints projectConfigConstraints <*> shrinker projectConfigPreferences <*> shrinker projectConfigCabalVersion From 96d34c7d33af1360fa7ab4ce62b66c6c68a972a3 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Wed, 23 Sep 2026 15:04:38 -0400 Subject: [PATCH 23/37] Don't generate commas for single-value fields --- Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs | 4 +++- .../tests/UnitTests/Distribution/Client/ArbitraryInstances.hs | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs b/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs index b661d169a1e..1504aa2cd74 100644 --- a/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs +++ b/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs @@ -476,8 +476,10 @@ shortListOf1 bound gen = sized $ \n -> do k <- choose (1, 1 `max` ((n `div` 2) `min` bound)) vectorOf k gen +-- | The parsec parser reads a single-value field as one token, stopping at a +-- comma, whereas the legacy parser took the rest of the line. arbitraryShortToken :: Gen String -arbitraryShortToken = arbitraryShortStringWithout "{}[]" +arbitraryShortToken = arbitraryShortStringWithout "{}[]," arbitraryShortPath :: Gen String arbitraryShortPath = arbitraryShortStringWithout "{}[],<>:|*?" `suchThat` (not . winDevice) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs index fea9e5694e4..82107f37642 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs @@ -160,7 +160,7 @@ instance Arbitrary ShortToken where -- | The strings that the 'ShortToken' generator produces. isShortToken :: String -> Bool isShortToken cs = - all (\c -> c >= '#' && c <= '~' && c `notElem` "{}") cs + all (\c -> c >= '#' && c <= '~' && c `notElem` "{},") cs && not ("[]" `isPrefixOf` cs) arbitraryShortToken :: Gen String From 26a675bce2d8876a845ff20cd301b46a6187690d Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Wed, 23 Sep 2026 16:03:32 -0400 Subject: [PATCH 24/37] Document & test that legacy sets empty fields to "" --- .../parser-tests/Tests/ParserTests.hs | 10 +++-- .../Client/ProjectConfig/Legacy.hs | 40 +++++++++---------- .../Client/ProjectConfig/Parsec.hs | 28 +++++++------ 3 files changed, 42 insertions(+), 36 deletions(-) diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index 52b92dc267a..7ab769f7501 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -420,13 +420,17 @@ testProjectConfigLocalPackages = do packageConfigTestTestOptions = [toPathTemplate "--some-option", toPathTemplate "42"] packageConfigBenchmarkOptions = [toPathTemplate "--some-benchmark-option", toPathTemplate "--another-option"] +-- | The parsers differ on a field with an empty value. The legacy parser +-- passes the empty rest of the line to the option's reader and so sets the +-- field to the empty string. The parsec parser sees a field with no lines and +-- leaves it unset, which is the better behaviour. testProjectConfigLocalPackagesEmptyString :: Assertion testProjectConfigLocalPackagesEmptyString = do (config, legacy) <- readConfig "project-config-local-packages" "cabal.empty-string.project" - assertConfigEquals expected config legacy (field . projectConfigLocalPackages . snd . condTreeData) + assertEqual "Legacy parser sets the empty string" (toFlag (toPathTemplate "")) (field legacy) + assertEqual "Parsec parser leaves the field unset" NoFlag (field config) where - field = packageConfigTestHumanLog - expected = NoFlag + field = packageConfigTestHumanLog . projectConfigLocalPackages . snd . condTreeData testProjectConfigAllPackages :: Assertion testProjectConfigAllPackages = do diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index a06849b5de3..a4005a4b7f3 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -1284,20 +1284,25 @@ showLegacyProjectConfig config = -- >>> parseLegacyConvert projectPackages "packages" "7{u,{h,{=n}}}" -- ParseOk [] ["7{u,{h,{=n}}}"] -- --- >>> parseLegacyConvert (packageConfigTestHumanLog . projectConfigAllPackages) "test-log" "" --- ParseOk [] (Last {getLast = Nothing}) +-- A top-level package field lands in the local packages, not in all packages. -- --- >>> parseLegacyConvert (packageConfigTestHumanLog . projectConfigAllPackages) "test-log" " " +-- >>> parseLegacyConvert (packageConfigTestHumanLog . projectConfigAllPackages) "test-log" "foo" -- ParseOk [] (Last {getLast = Nothing}) -- --- >>> parseLegacyConvert (packageConfigTestHumanLog . projectConfigAllPackages) "test-log" " \n" --- ParseOk [] (Last {getLast = Nothing}) +-- >>> parseLegacyConvert (packageConfigTestHumanLog . projectConfigLocalPackages) "test-log" "foo" +-- ParseOk [] (Last {getLast = Just "foo"}) -- --- >>> parseLegacyConvert (packageConfigHaddockHtmlLocation . projectConfigAllPackages) "haddock-html-location" "" --- ParseOk [] (Last {getLast = Nothing}) +-- An empty value sets the field to the empty string, where the parsec parser +-- would leave it unset, see 'Distribution.Client.ProjectConfig.Parsec.parseProjectConfig'. -- --- >>> parseLegacyConvert (packageConfigHaddockHtmlLocation . projectConfigAllPackages) "haddock-html-location" " " --- ParseOk [] (Last {getLast = Nothing}) +-- >>> parseLegacyConvert (packageConfigTestHumanLog . projectConfigLocalPackages) "test-log" "" +-- ParseOk [] (Last {getLast = Just ""}) +-- +-- >>> parseLegacyConvert (packageConfigTestHumanLog . projectConfigLocalPackages) "test-log" " " +-- ParseOk [] (Last {getLast = Just ""}) +-- +-- >>> parseLegacyConvert (packageConfigHaddockHtmlLocation . projectConfigLocalPackages) "haddock-html-location" "" +-- ParseOk [] (Last {getLast = Just ""}) legacyProjectConfigFieldDescrs :: ConstraintSource -> [FieldDescr LegacyProjectConfig] legacyProjectConfigFieldDescrs constraintSrc = [ newLineListField @@ -2089,18 +2094,13 @@ showTokenQ x@['.'] = Disp.text (show x) showTokenQ x = showToken x -- $setup --- >>> :{ --- parseLegacy :: (LegacyProjectConfig -> a) -> String -> String -> ParseResult a --- parseLegacy f field s = f <$> --- parseLegacyProjectConfigFieldsWithConstraintSource --- ConstraintSourceUnknown --- [ParseUtils.F 1 field s] --- :} +-- >>> import Distribution.Utils.Generic (toUTF8BS) +-- +-- Parses a project file of one field, going through the lexer as a real +-- project file would. -- -- >>> :{ -- parseLegacyConvert :: (ProjectConfig -> a) -> String -> String -> ParseResult a --- parseLegacyConvert f field s = (f . convertLegacyProjectConfig) <$> --- parseLegacyProjectConfigFieldsWithConstraintSource --- ConstraintSourceUnknown --- [ParseUtils.F 1 field s] +-- parseLegacyConvert f field s = (f . convertLegacyProjectConfig) <$> +-- parseLegacyProjectConfig "" (toUTF8BS (field ++ ": " ++ s)) -- :} diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index 179272d1fef..c1adcb9aa14 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -213,19 +213,22 @@ fieldsToConfig sourceConfigPath xs = do -- >>> parseParsec projectPackages "packages" "7{u,{h,{=n}}}" -- ([],Right ["7{u,{h,{=n}}}"]) -- --- >>> parseParsec projectPackages "test-log" "" +-- >>> parseParsec projectPackages "packages" "" -- ([],Right []) -- --- >>> parseParsec (packageConfigTestHumanLog . projectConfigAllPackages) "test-log" " " --- ([],Right (Last {getLast = Nothing})) +-- >>> parseParsec (packageConfigTestHumanLog . projectConfigLocalPackages) "test-log" "foo" +-- ([],Right (Last {getLast = Just "foo"})) +-- +-- An empty value leaves the field unset, where the legacy parser would set it +-- to the empty string, see 'Distribution.Client.ProjectConfig.Legacy.legacyProjectConfigFieldDescrs'. -- --- >>> parseParsec (packageConfigTestHumanLog . projectConfigAllPackages) "test-log" " \n" +-- >>> parseParsec (packageConfigTestHumanLog . projectConfigLocalPackages) "test-log" "" -- ([],Right (Last {getLast = Nothing})) - --- >>> parseParsec (packageConfigHaddockHtmlLocation . projectConfigAllPackages) "haddock-html-location" "" +-- +-- >>> parseParsec (packageConfigTestHumanLog . projectConfigLocalPackages) "test-log" " " -- ([],Right (Last {getLast = Nothing})) - --- >>> parseParsec (packageConfigHaddockHtmlLocation . projectConfigAllPackages) "haddock-html-location" " " +-- +-- >>> parseParsec (packageConfigHaddockHtmlLocation . projectConfigLocalPackages) "haddock-html-location" "" -- ([],Right (Last {getLast = Nothing})) parseProjectConfig :: FilePath -> BS.ByteString -> ParseResult ProjectFileSource ProjectConfig parseProjectConfig rootConfig bs = @@ -441,13 +444,12 @@ cabalSpec :: CabalSpecVersion cabalSpec = cabalSpecLatest -- $setup --- >>> :set -XViewPatterns -- >>> instance (Show a, Show b) => Show (ParseResult a b) where show = show . runParseResult -- +-- Parses a project file of one field, going through the lexer as a real +-- project file would. +-- -- >>> :{ -- parseParsec :: (ProjectConfig -> a) -> String -> String -> ParseResult ProjectFileSource a --- parseParsec f (toUTF8BS -> field) (toUTF8BS -> s) = f <$> --- fieldsToConfig --- nullProjectConfigPath --- [Field (Name zeroPos field) [FieldLine zeroPos s]] +-- parseParsec f field s = f <$> parseProjectConfig "" (toUTF8BS (field ++ ": " ++ s)) -- :} From 943c15e4963ff13eff44ce9ad291a9b228872fe3 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Wed, 23 Sep 2026 16:08:45 -0400 Subject: [PATCH 25/37] Get rid of top level function only used by doctest --- .../src/Distribution/Client/ProjectConfig/Legacy.hs | 7 ------- 1 file changed, 7 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index a4005a4b7f3..08fff60bfce 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -1242,13 +1242,6 @@ convertToLegacyPerPackageConfig PackageConfig{..} = parseLegacyProjectConfigFields :: ProjectConfigPath -> [ParseUtils.Field] -> ParseResult LegacyProjectConfig parseLegacyProjectConfigFields (ConstraintSourceProjectConfig -> constraintSrc) = - parseLegacyProjectConfigFieldsWithConstraintSource constraintSrc - -parseLegacyProjectConfigFieldsWithConstraintSource - :: ConstraintSource - -> [ParseUtils.Field] - -> ParseResult LegacyProjectConfig -parseLegacyProjectConfigFieldsWithConstraintSource constraintSrc = parseFieldsAndSections (legacyProjectConfigFieldDescrs constraintSrc) legacyPackageConfigSectionDescrs From febf7eeda4e8f8c828291b41355a8579a8afa7a7 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Wed, 23 Sep 2026 16:15:58 -0400 Subject: [PATCH 26/37] Add a changelog entry --- changelog.d/pr-12139.md | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) create mode 100644 changelog.d/pr-12139.md diff --git a/changelog.d/pr-12139.md b/changelog.d/pr-12139.md new file mode 100644 index 00000000000..29986ccd87d --- /dev/null +++ b/changelog.d/pr-12139.md @@ -0,0 +1,19 @@ +--- +synopsis: Fix parsec project parser roundtrip failures +packages: [Cabal, cabal-install] +prs: 12139 +--- + +The parsec parser for project files now accepts three things that only the +legacy parser accepted before: + +- `debug-info: True` and `debug-info: False`, case insensitively, as well as + the levels `0` to `3`. This also applies to `--enable-debug-info=True` on the + command line. +- A negative `max-backjumps`, such as `max-backjumps: -1` for unlimited + backtracking, matching `--max-backjumps`. +- Package locations in `packages` and `optional-packages` with commas inside + braces, such as `packages: ../{foo,bar}/`. + +The round trip property tests for project configuration now print with the +legacy printer and parse with the parsec parser. From 744a41509f3a057c932a50dfa8e627e21bf73fa3 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Thu, 24 Sep 2026 12:38:43 -0400 Subject: [PATCH 27/37] Use normalise when reading --- .../src/Distribution/Client/ProjectConfig/Parsec.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index c1adcb9aa14..03968a601a8 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -40,7 +40,6 @@ import Distribution.Simple.Program.Types (programName) import Distribution.Simple.Setup import Distribution.Simple.Utils (debug, noticeDoc) import Distribution.Solver.Types.ProjectConfigPath -import Distribution.System (buildOS) import Distribution.Types.CondTree (CondBranch (..), CondTree (..)) import Distribution.Types.ConfVar (ConfVar (..)) import Distribution.Types.PackageName (PackageName) @@ -57,7 +56,7 @@ import Distribution.Client.Errors.Parser (ProjectFileSource (..)) import qualified Distribution.Compat.CharParsing as P import Network.URI (URI, uriFragment, uriPath, uriScheme) import System.Directory (makeAbsolute) -import System.FilePath (splitFileName) +import System.FilePath (normalise, splitFileName) import qualified Text.Parsec import Text.PrettyPrint (render) import qualified Text.PrettyPrint as Disp @@ -322,8 +321,8 @@ 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 = normaliseFileNoIndexURI buildOS $ remoteRepoURI repo - return $ Left $ LocalRepo (remoteRepoName repo) (uriPath uri) (uriFragment uri == "#shared-cache") + let uri = remoteRepoURI repo + return $ Left $ LocalRepo (remoteRepoName repo) (normalise (uriPath uri)) (uriFragment uri == "#shared-cache") _ -> do when (remoteRepoKeyThreshold repo > length (remoteRepoRootKeys repo)) $ warning $ From 869cfe4ff0ff81696c30340c83dca104c8c623d7 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Thu, 24 Sep 2026 12:49:32 -0400 Subject: [PATCH 28/37] Add fileNoIndexURIPath, haddocks and doctests --- .../src/Distribution/Client/Config.hs | 7 +-- .../Client/ProjectConfig/Parsec.hs | 13 +++-- .../src/Distribution/Client/Types/Repo.hs | 50 +++++++++++++++++++ 3 files changed, 64 insertions(+), 6 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs index 533add81cfb..03264316db5 100644 --- a/cabal-install/src/Distribution/Client/Config.hs +++ b/cabal-install/src/Distribution/Client/Config.hs @@ -94,6 +94,7 @@ import Distribution.Client.Types , RemoteRepo (..) , RepoName (..) , emptyRemoteRepo + , fileNoIndexURIPath , isRelaxDeps , unRepoName ) @@ -208,6 +209,7 @@ import Distribution.Simple.Utils , writeFileAtomic ) import Distribution.Solver.Types.ConstraintSource +import Distribution.System (buildOS) import Distribution.Utils.Path (getSymbolicPath, unsafeMakeSymbolicPath) import Distribution.Verbosity ( normal @@ -229,8 +231,7 @@ import System.Directory , renameFile ) import System.FilePath - ( normalise - , takeDirectory + ( takeDirectory , () ) import System.IO.Error @@ -1690,7 +1691,7 @@ postProcessRepo lineno reponameStr repo0 = do Left $ LocalRepo reponame - (normalise (uriPath uri)) + (fileNoIndexURIPath buildOS uri) (uriFragment uri == "#shared-cache") _ -> do let repo = repo0{remoteRepoName = reponame} diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index 03968a601a8..7b51f18b805 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -40,6 +40,7 @@ import Distribution.Simple.Program.Types (programName) import Distribution.Simple.Setup import Distribution.Simple.Utils (debug, noticeDoc) import Distribution.Solver.Types.ProjectConfigPath +import Distribution.System (buildOS) import Distribution.Types.CondTree (CondBranch (..), CondTree (..)) import Distribution.Types.ConfVar (ConfVar (..)) import Distribution.Types.PackageName (PackageName) @@ -54,9 +55,9 @@ import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Distribution.Client.Errors.Parser (ProjectFileSource (..)) import qualified Distribution.Compat.CharParsing as P -import Network.URI (URI, uriFragment, uriPath, uriScheme) +import Network.URI (URI, uriFragment, uriScheme) import System.Directory (makeAbsolute) -import System.FilePath (normalise, splitFileName) +import System.FilePath (splitFileName) import qualified Text.Parsec import Text.PrettyPrint (render) import qualified Text.PrettyPrint as Disp @@ -316,13 +317,19 @@ stanzas :: Set BS.ByteString stanzas = Set.fromList ["source-repository-package", "program-options", "program-locations", "repository", "package"] -- | Currently a duplicate of 'Distribution.Client.Config.postProcessRepo' but migrated to Parsec ParseResult. +-- +-- A @file+noindex:@ repository is local and its path is read back as a +-- native path with 'fileNoIndexURIPath', the reading direction. The legacy +-- printer writes that path with 'normaliseFileNoIndexURI', the writing +-- direction, so the two must stay inverses of each other for a project file +-- to round trip. postProcessRemoteRepo :: Position -> RemoteRepo -> ParseResult src (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) (normalise (uriPath uri)) (uriFragment uri == "#shared-cache") + return $ Left $ LocalRepo (remoteRepoName repo) (fileNoIndexURIPath buildOS uri) (uriFragment uri == "#shared-cache") _ -> do when (remoteRepoKeyThreshold repo > length (remoteRepoRootKeys repo)) $ warning $ diff --git a/cabal-install/src/Distribution/Client/Types/Repo.hs b/cabal-install/src/Distribution/Client/Types/Repo.hs index 4954b840c8a..74400e6fcda 100644 --- a/cabal-install/src/Distribution/Client/Types/Repo.hs +++ b/cabal-install/src/Distribution/Client/Types/Repo.hs @@ -21,6 +21,7 @@ module Distribution.Client.Types.Repo -- * Windows , asPosixPath , normaliseFileNoIndexURI + , fileNoIndexURIPath ) where import Distribution.Client.Compat.Prelude @@ -230,10 +231,23 @@ repoName (RepoSecure r _) = remoteRepoName r -- | When on Windows, we need to convert the paths in URIs to be POSIX-style. -- +-- This is the writing direction, from the native 'localRepoPath' of a +-- 'LocalRepo' to the @url@ of a @repository@ section. Use it when printing +-- or building a @file+noindex:@ URI. For the reading direction, from that URI +-- back to a native path, use 'fileNoIndexURIPath' instead. +-- -- >>> import Network.URI -- >>> normaliseFileNoIndexURI Windows (URI "file+noindex:" (Just nullURIAuth) "C:\\dev\\foo" "" "") -- file+noindex:C:/dev/foo -- +-- Elsewhere, and for other schemes, the URI is left as it is. +-- +-- >>> import Distribution.System (OS (..)) +-- >>> normaliseFileNoIndexURI Linux (URI "file+noindex:" Nothing "/dev/foo" "" "") +-- file+noindex:/dev/foo +-- >>> normaliseFileNoIndexURI Windows (URI "file:" Nothing "C:\\dev\\foo" "" "") +-- file:C:\dev\foo +-- -- Other formats of file paths are not understood by @network-uri@: -- -- >>> import Network.URI @@ -255,7 +269,43 @@ normaliseFileNoIndexURI os uri@(URI scheme _auth path query fragment) URI scheme Nothing (asPosixPath path) query fragment | otherwise = uri +-- | The path of a @file+noindex:@ URI as a native path, for the +-- 'localRepoPath' of a 'LocalRepo'. +-- +-- This is the reading direction, the inverse of 'normaliseFileNoIndexURI'. +-- Use it when parsing a @repository@ section. Both the legacy and parsec +-- project file parsers read the path this way. Reading it with +-- 'normaliseFileNoIndexURI' instead would keep the POSIX-style slashes on +-- Windows and the two parsers would disagree with each other and with the +-- path the URI was written from. +-- +-- On Windows the path is normalised to backslashes, whether it was written +-- POSIX-style by 'normaliseFileNoIndexURI' or with backslashes by hand. +-- +-- >>> import Network.URI +-- >>> import Distribution.System (OS (..)) +-- >>> fileNoIndexURIPath Windows (URI "file+noindex:" Nothing "C:/dev/foo" "" "") +-- "C:\\dev\\foo" +-- >>> fileNoIndexURIPath Windows (URI "file+noindex:" Nothing "C:\\dev\\foo" "" "") +-- "C:\\dev\\foo" +-- >>> fileNoIndexURIPath Linux (URI "file+noindex:" Nothing "/dev/foo" "" "") +-- "/dev/foo" +-- +-- Writing a native path and reading it back gives the native path again. +-- +-- >>> let uri = normaliseFileNoIndexURI Windows (URI "file+noindex:" Nothing "C:\\dev\\foo" "" "") +-- >>> (uri, fileNoIndexURIPath Windows uri) +-- (file+noindex:C:/dev/foo,"C:\\dev\\foo") +fileNoIndexURIPath :: OS -> URI -> FilePath +fileNoIndexURIPath Windows = Windows.normalise . uriPath +fileNoIndexURIPath _ = Posix.normalise . uriPath + -- | Convert a path to POSIX-style. +-- +-- >>> asPosixPath "C:\\dev\\foo" +-- "C:/dev/foo" +-- >>> asPosixPath "/dev/foo" +-- "/dev/foo" asPosixPath :: FilePath -> FilePath asPosixPath p = -- We don't use 'isPathSeparator' because @Windows.isPathSeparator From fce41fb06d676b36cd2e566c217c69d104f75f6b Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Thu, 24 Sep 2026 15:24:16 -0400 Subject: [PATCH 29/37] Expect native local repo paths in the parser test --- cabal-install/parser-tests/Tests/ParserTests.hs | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index 7ab769f7501..83a306ec215 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -24,7 +24,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 (..), asPosixPath) +import Distribution.Client.Types.Repo (LocalRepo (..), RemoteRepo (..)) import Distribution.Client.Types.RepoName (RepoName (..)) import Distribution.Client.Types.SourceRepo import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy (WriteGhcEnvironmentFilesPolicy (..)) @@ -48,7 +48,6 @@ import Distribution.Solver.Types.Settings , ReorderGoals (..) , StrongFlags (..) ) -import Distribution.System (OS (..), buildOS) import Distribution.Types.CondTree (CondTree (..)) import Distribution.Types.Flag (mkFlagAssignment) import Distribution.Types.PackageId (PackageIdentifier (..)) @@ -62,7 +61,7 @@ import Distribution.Verbosity import GHC.Stack (HasCallStack) import Network.URI (parseURI) import System.Directory (canonicalizePath, doesFileExist) -import System.FilePath (()) +import System.FilePath (normalise, ()) import Prelude () import Test.Tasty (TestTree, testGroup) @@ -321,26 +320,24 @@ testRemoteRepos = do testLocalNoIndexRepos :: Assertion testLocalNoIndexRepos = do (config, legacy) <- readConfigDefault "local-no-index-repos" - let actualLocalRepos = (fromNubList . projectConfigLocalNoIndexRepos . projectConfigShared . snd . condTreeData) config - assertBool "Expected LocalNoIndexRepos do not match parsed values" $ compareLists expected actualLocalRepos compareLocalRepos + let localRepos = fromNubList . projectConfigLocalNoIndexRepos . projectConfigShared . snd . condTreeData + assertBool "Expected LocalNoIndexRepos do not match parsed values" $ compareLists expected (localRepos config) compareLocalRepos + assertBool "Expected LocalNoIndexRepos do not match legacy parsed values" $ compareLists expected (localRepos legacy) compareLocalRepos assertConfigEquals mempty config legacy (projectConfigRemoteRepos . projectConfigShared . snd . condTreeData) where expected = [myRepository, mySecureRepository] myRepository = LocalRepo { localRepoName = RepoName "my-repository" - , localRepoPath = normalisePath "/absolute/path/to/directory" + , localRepoPath = normalise "/absolute/path/to/directory" , localRepoSharedCache = False } mySecureRepository = LocalRepo { localRepoName = RepoName "my-other-repository" - , localRepoPath = normalisePath "/another/path/to/repository" + , localRepoPath = normalise "/another/path/to/repository" , localRepoSharedCache = False } - normalisePath path = case buildOS of - Windows -> asPosixPath path - _ -> path testProjectConfigProvenance :: Assertion testProjectConfigProvenance = do From e1d3570a8e4cc31c1045d9371ae3b593d20b262f Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Tue, 29 Sep 2026 08:31:16 -0400 Subject: [PATCH 30/37] Say why local repo paths are stored native --- cabal-install/src/Distribution/Client/Config.hs | 2 ++ .../Distribution/Client/ProjectConfig/Parsec.hs | 2 ++ .../src/Distribution/Client/Types/Repo.hs | 14 +++++++++----- 3 files changed, 13 insertions(+), 5 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs index 03264316db5..c87a978734b 100644 --- a/cabal-install/src/Distribution/Client/Config.hs +++ b/cabal-install/src/Distribution/Client/Config.hs @@ -1691,6 +1691,8 @@ postProcessRepo lineno reponameStr repo0 = do Left $ LocalRepo reponame + -- Native path, so a repository named here and in a project + -- file compares equal and shares one cache key. (fileNoIndexURIPath buildOS uri) (uriFragment uri == "#shared-cache") _ -> do diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index 7b51f18b805..0b08f08dc67 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -329,6 +329,8 @@ postProcessRemoteRepo pos repo = case uriScheme (remoteRepoURI repo) of -- Note: the trailing colon is important "file+noindex:" -> do let uri = remoteRepoURI repo + -- Native path, not the URI's POSIX-style one: the config file parser + -- stores native too, and the cache key hashes the spelling. return $ Left $ LocalRepo (remoteRepoName repo) (fileNoIndexURIPath buildOS uri) (uriFragment uri == "#shared-cache") _ -> do when (remoteRepoKeyThreshold repo > length (remoteRepoRootKeys repo)) $ diff --git a/cabal-install/src/Distribution/Client/Types/Repo.hs b/cabal-install/src/Distribution/Client/Types/Repo.hs index 74400e6fcda..71b3aa8f185 100644 --- a/cabal-install/src/Distribution/Client/Types/Repo.hs +++ b/cabal-install/src/Distribution/Client/Types/Repo.hs @@ -273,11 +273,15 @@ normaliseFileNoIndexURI os uri@(URI scheme _auth path query fragment) -- 'localRepoPath' of a 'LocalRepo'. -- -- This is the reading direction, the inverse of 'normaliseFileNoIndexURI'. --- Use it when parsing a @repository@ section. Both the legacy and parsec --- project file parsers read the path this way. Reading it with --- 'normaliseFileNoIndexURI' instead would keep the POSIX-style slashes on --- Windows and the two parsers would disagree with each other and with the --- path the URI was written from. +-- Use it when parsing a @repository@ section, in the user config file and in +-- project files alike. +-- +-- The path is stored native rather than POSIX-style because it is a +-- 'FilePath' like every other in cabal-install, because 'localRepoCacheKey' +-- hashes its spelling to name a cache directory, and because a repository +-- given in both the config file and a project file must compare equal to be +-- deduplicated. Reading with 'normaliseFileNoIndexURI' instead would keep +-- the URI's forward slashes on Windows and break all three. -- -- On Windows the path is normalised to backslashes, whether it was written -- POSIX-style by 'normaliseFileNoIndexURI' or with backslashes by hand. From e79eb4e65821e76396667fe303c7096033c4dc2d Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Tue, 29 Sep 2026 08:34:06 -0400 Subject: [PATCH 31/37] Spell out the uses of paths --- .../src/Distribution/Client/Types/Repo.hs | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Types/Repo.hs b/cabal-install/src/Distribution/Client/Types/Repo.hs index 71b3aa8f185..5d9d560b14b 100644 --- a/cabal-install/src/Distribution/Client/Types/Repo.hs +++ b/cabal-install/src/Distribution/Client/Types/Repo.hs @@ -276,12 +276,19 @@ normaliseFileNoIndexURI os uri@(URI scheme _auth path query fragment) -- Use it when parsing a @repository@ section, in the user config file and in -- project files alike. -- --- The path is stored native rather than POSIX-style because it is a --- 'FilePath' like every other in cabal-install, because 'localRepoCacheKey' --- hashes its spelling to name a cache directory, and because a repository --- given in both the config file and a project file must compare equal to be --- deduplicated. Reading with 'normaliseFileNoIndexURI' instead would keep --- the URI's forward slashes on Windows and break all three. +-- The path is stored native rather than POSIX-style because: +-- +-- 1. It is a 'FilePath', like every other path in cabal-install. +-- +-- 2. 'localRepoCacheKey' hashes its spelling to name a cache directory, so +-- two spellings of one directory would get two caches. +-- +-- 3. A repository given in both the config file and a project file must +-- compare equal to be deduplicated. +-- +-- Reading with 'normaliseFileNoIndexURI' instead would keep the URI's +-- forward slashes on Windows, which breaks 2 and 3 and makes 1 the odd one +-- out. -- -- On Windows the path is normalised to backslashes, whether it was written -- POSIX-style by 'normaliseFileNoIndexURI' or with backslashes by hand. From 435d95005ff0d5582ac7584552d6b61ea3f5f005 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Tue, 29 Sep 2026 08:56:55 -0400 Subject: [PATCH 32/37] Assert both parsers agree in readConfig - Add readConfigDiverging --- cabal-install/parser-tests/Tests/ParserTests.hs | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index 83a306ec215..d236ddc8a95 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -423,7 +423,7 @@ testProjectConfigLocalPackages = do -- leaves it unset, which is the better behaviour. testProjectConfigLocalPackagesEmptyString :: Assertion testProjectConfigLocalPackagesEmptyString = do - (config, legacy) <- readConfig "project-config-local-packages" "cabal.empty-string.project" + (config, legacy) <- readConfigDiverging "project-config-local-packages" "cabal.empty-string.project" assertEqual "Legacy parser sets the empty string" (toFlag (toPathTemplate "")) (field legacy) assertEqual "Parsec parser leaves the field unset" NoFlag (field config) where @@ -595,8 +595,19 @@ verbosity = mkVerbosity defaultVerbosityHandles normal readConfigDefault :: FilePath -> IO (ProjectConfigSkeleton, ProjectConfigSkeleton) readConfigDefault testSubDir = readConfig testSubDir "cabal.project" +-- | Reads a project file with both parsers and, with the legacy parser as the +-- oracle, checks that the parsec parser agrees with it on the whole config +-- before the caller looks at any one field. readConfig :: FilePath -> FilePath -> IO (ProjectConfigSkeleton, ProjectConfigSkeleton) readConfig testSubDir projectFileName = do + (parsec, legacy) <- readConfigDiverging testSubDir projectFileName + assertEqual "Parsec parser disagrees with the legacy parser" legacy parsec + return (parsec, legacy) + +-- | Reads a project file with both parsers without checking that they agree, +-- for the fixtures where they are known to differ. +readConfigDiverging :: FilePath -> FilePath -> IO (ProjectConfigSkeleton, ProjectConfigSkeleton) +readConfigDiverging testSubDir projectFileName = do (TestDir testRootFp projectConfigFp distDirLayout) <- testDirInfo testSubDir projectFileName exists <- liftIO $ doesFileExist projectConfigFp assertBool ("projectConfig does not exist: " <> projectConfigFp) exists From 9efcc1c6fcef8c48282fab852c493d43c7bbba2d Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Tue, 29 Sep 2026 09:02:52 -0400 Subject: [PATCH 33/37] Show a tree diff when the parsers disagree --- cabal-install/cabal-install.cabal | 5 ++++- cabal-install/parser-tests/Tests/ParserTests.hs | 14 ++++++++++++-- 2 files changed, 16 insertions(+), 3 deletions(-) diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 94890b190b9..4fc382f9017 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -398,17 +398,20 @@ test-suite parser-tests type: exitcode-stdio-1.0 main-is: Tests.hs - hs-source-dirs: parser-tests + hs-source-dirs: parser-tests tests build-depends: , cabal-install + , Cabal-tree-diff , containers , directory , filepath , network-uri >= 2.6.2.0 && <2.7 , tasty >= 1.2.3 && <1.6 , tasty-hunit >= 0.10 + , tree-diff other-modules: Tests.ParserTests + UnitTests.Distribution.Client.TreeDiffInstances -- 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/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index d236ddc8a95..858037cbd86 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -65,7 +65,10 @@ import System.FilePath (normalise, ()) import Prelude () import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, testCase) +import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase) + +import Data.TreeDiff (ToExpr, ansiWlEditExpr, ediff) +import UnitTests.Distribution.Client.TreeDiffInstances () parserTests :: TestTree parserTests = @@ -601,9 +604,16 @@ readConfigDefault testSubDir = readConfig testSubDir "cabal.project" readConfig :: FilePath -> FilePath -> IO (ProjectConfigSkeleton, ProjectConfigSkeleton) readConfig testSubDir projectFileName = do (parsec, legacy) <- readConfigDiverging testSubDir projectFileName - assertEqual "Parsec parser disagrees with the legacy parser" legacy parsec + assertEdiffEqual "Parsec parser disagrees with the legacy parser" legacy parsec return (parsec, legacy) +-- | Like 'assertEqual' but the failure shows a tree diff of the two values +-- instead of two 'show' dumps. +assertEdiffEqual :: (Eq a, ToExpr a, HasCallStack) => String -> a -> a -> Assertion +assertEdiffEqual msg expected actual = + unless (expected == actual) . assertFailure $ + unlines [msg, show (ansiWlEditExpr (ediff expected actual))] + -- | Reads a project file with both parsers without checking that they agree, -- for the fixtures where they are known to differ. readConfigDiverging :: FilePath -> FilePath -> IO (ProjectConfigSkeleton, ProjectConfigSkeleton) From 585d1750d201d1cafbd2c9ef7bbedfd1a0dd9f7f Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Tue, 29 Sep 2026 09:08:20 -0400 Subject: [PATCH 34/37] Parse the round trip text with both parsers --- .../Distribution/Client/ProjectConfig.hs | 25 ++++++++++++++----- 1 file changed, 19 insertions(+), 6 deletions(-) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 30170930cb5..9f9b296d481 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -18,6 +18,7 @@ import System.Directory (canonicalizePath, withCurrentDirectory) import System.FilePath import System.IO.Unsafe (unsafePerformIO) +import Distribution.Deprecated.ParseUtils (ParseResult (..)) import qualified Distribution.Deprecated.ReadP as Parse import Distribution.Package @@ -258,15 +259,27 @@ prop_roundtrip_legacytypes_specific config = -- Round trip: printing and parsing config -- +-- | Prints with the legacy printer and parses with both parsers, each of +-- which must give back the config. The legacy parser is the oracle for the +-- parsec parser, so the generators avoid the inputs where the two are known +-- to differ, such as commas and empty values in single-value fields. roundtrip_printparse :: ProjectConfig -> Property -roundtrip_printparse config = countering $ - case runParseResult $ parseProjectConfig "unused" (toUTF8BS str) of - (_, Right result) -> +roundtrip_printparse config = + countering $ + counterexample "parsec parser" parsecParsed + .&&. counterexample "legacy parser" legacyParsed + where + parsecParsed = case runParseResult $ parseProjectConfig "unused" bs of + (_, Right result) -> result `roundTripped` config + (_, Left err) -> counterexample ("ERROR: " ++ show err) False + legacyParsed = case parseLegacyProjectConfig "unused" bs of + ParseOk _ result -> convertLegacyProjectConfig result `roundTripped` config + ParseFailed err -> counterexample ("ERROR: " ++ show err) False + roundTripped result expected = ediffEq result{projectConfigProvenance = mempty} - config{projectConfigProvenance = mempty} - (_, Left err) -> counterexample ("ERROR: " ++ show err) False - where + expected{projectConfigProvenance = mempty} + bs = toUTF8BS str str :: String str = showLegacyProjectConfig (convertToLegacyProjectConfig config) countering = From 8a65ba7062d7c202d0f71f1332b62d7309b046ef Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Tue, 29 Sep 2026 09:22:48 -0400 Subject: [PATCH 35/37] Compare parsers on PackageTests projects --- cabal-install/parser-tests/Tests.hs | 8 ++- .../parser-tests/Tests/ParserTests.hs | 63 ++++++++++++++++++- 2 files changed, 65 insertions(+), 6 deletions(-) diff --git a/cabal-install/parser-tests/Tests.hs b/cabal-install/parser-tests/Tests.hs index f5655ad5389..13fc35b15ec 100644 --- a/cabal-install/parser-tests/Tests.hs +++ b/cabal-install/parser-tests/Tests.hs @@ -1,7 +1,9 @@ module Main where -import Test.Tasty (defaultMain) -import Tests.ParserTests (parserTests) +import Test.Tasty (defaultMain, testGroup) +import Tests.ParserTests (packageTestsProjectTests, parserTests) main :: IO () -main = defaultMain parserTests +main = do + packageTests <- packageTestsProjectTests + defaultMain $ testGroup "parser-tests" [parserTests, packageTests] diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index 858037cbd86..0df11c525db 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -2,12 +2,14 @@ {-# LANGUAGE RecordWildCards #-} -- | Tests for the project file parser -module Tests.ParserTests (parserTests) where +module Tests.ParserTests (parserTests, packageTestsProjectTests) where +import Control.Exception (try) import Control.Monad.IO.Class ( MonadIO (liftIO) ) import Data.Either (fromRight) +import Data.List (isInfixOf) import qualified Data.Map as Map import Data.Maybe (fromJust) import qualified Data.Set as Set @@ -60,8 +62,8 @@ import Distribution.Utils.NubList import Distribution.Verbosity import GHC.Stack (HasCallStack) import Network.URI (parseURI) -import System.Directory (canonicalizePath, doesFileExist) -import System.FilePath (normalise, ()) +import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist, listDirectory) +import System.FilePath (makeRelative, normalise, takeDirectory, takeExtension, takeFileName, ()) import Prelude () import Test.Tasty (TestTree, testGroup) @@ -607,6 +609,61 @@ readConfig testSubDir projectFileName = do assertEdiffEqual "Parsec parser disagrees with the legacy parser" legacy parsec return (parsec, legacy) +-- | The project files of the cabal-testsuite package tests, each read with +-- both parsers, which must agree. These are real project files exercising +-- far more of the grammar than the fixtures here, so with the legacy parser +-- as the oracle they are the widest check that the parsec parser has of what +-- a field means. +-- +-- Files with an import over HTTP are skipped so that the test needs no +-- network. Files that both parsers reject are accepted without comparing the +-- errors, but a file that only one parser rejects is a failure. +-- +-- The tests are empty when the cabal-testsuite directory is not there, as in +-- an sdist of cabal-install. +packageTestsProjectTests :: IO TestTree +packageTestsProjectTests = do + exists <- doesDirectoryExist packageTestsDir + files <- if exists then filterM isOffline =<< findProjectFiles packageTestsDir else pure [] + httpTransport <- configureTransport silentVerbosity [] Nothing + pure $ + testGroup + "cabal-testsuite project files" + [ testCase (makeRelative packageTestsDir file) (assertParsersAgree httpTransport file) + | file <- files + ] + where + packageTestsDir = ".." "cabal-testsuite" "PackageTests" + isOffline file = not . any importsHttp . lines <$> readFile file + importsHttp l = "import:" `isPrefixOf` dropWhile isSpace l && "http" `isInfixOf` l + +-- | Every @.project@ file under a directory. +findProjectFiles :: FilePath -> IO [FilePath] +findProjectFiles dir = do + entries <- map (dir ) <$> listDirectory dir + dirs <- filterM doesDirectoryExist entries + let files = [e | e <- entries, takeExtension e == ".project"] + (sort files ++) . concat <$> traverse findProjectFiles (sort dirs) + +-- | Reads one project file with both parsers and checks that they agree. +assertParsersAgree :: HttpTransport -> FilePath -> Assertion +assertParsersAgree httpTransport file = do + projectRootDir <- canonicalizePath (takeDirectory file) + let projectRoot = ProjectRootExplicit projectRootDir (takeFileName file) + distDirLayout = defaultDistDirLayout projectRoot Nothing Nothing + readWith reader = try . runRebuild projectRootDir $ reader silentVerbosity httpTransport distDirLayout ProjectFileKeyMain + parsec <- readWith readProjectFileSkeletonParsec + legacy <- readWith readProjectFileSkeletonLegacy + case (legacy, parsec) of + (Right l, Right p) -> assertEdiffEqual "Parsec parser disagrees with the legacy parser" l p + (Left _, Left _) -> pure () + (Left e, Right _) -> assertFailure $ "Legacy parser failed where the parsec parser succeeded:\n" ++ displayException (e :: SomeException) + (Right _, Left e) -> assertFailure $ "Parsec parser failed where the legacy parser succeeded:\n" ++ displayException (e :: SomeException) + +-- | Neither parser's warnings are of interest when comparing them. +silentVerbosity :: Verbosity +silentVerbosity = mkVerbosity defaultVerbosityHandles silent + -- | Like 'assertEqual' but the failure shows a tree diff of the two values -- instead of two 'show' dumps. assertEdiffEqual :: (Eq a, ToExpr a, HasCallStack) => String -> a -> a -> Assertion From d27de724566e5a2fc09ad795784092159552c7b8 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Wed, 11 Nov 2026 15:14:51 -0500 Subject: [PATCH 36/37] Fixup of doctest after rebase s/String/Text --- Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs index ac4b2f31add..8bfa729146f 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs @@ -141,10 +141,10 @@ newtype List sep b a = List {_getList :: [a]} -- >>> :t alaList' FSep Token -- alaList' FSep Token :: [Text] -> List FSep Token Text -- --- >>> _getList <$> (eitherParsec "foo bar foo" :: Either String (List FSep Token String)) +-- >>> _getList <$> (eitherParsec "foo bar foo" :: Either String (List FSep Token Text)) -- Right ["foo","bar","foo"] -- --- >>> _getList <$> (eitherParsec "xL{4,IE-,eK<}fE?e" :: Either String (List FSep Token String)) +-- >>> _getList <$> (eitherParsec "xL{4,IE-,eK<}fE?e" :: Either String (List FSep Token Text)) -- Right ["xL{4","IE-","eK<}fE?e"] alaList :: sep -> [a] -> List sep (Identity a) a alaList _ = List From 40a533e1a320782f63b63531577b389b0c7aa7fc Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Wed, 11 Nov 2026 15:26:07 -0500 Subject: [PATCH 37/37] Satisfy hlint --- Cabal/src/Distribution/Simple/Compiler.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/Cabal/src/Distribution/Simple/Compiler.hs b/Cabal/src/Distribution/Simple/Compiler.hs index bdf32eb3fa6..c1746083d73 100644 --- a/Cabal/src/Distribution/Simple/Compiler.hs +++ b/Cabal/src/Distribution/Simple/Compiler.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE ViewPatterns #-} -- | -- Module : Distribution.Simple.Compiler