Add back +legacy-comparison to the validate project

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)

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
+--
+-- >>> _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 Text))
+-- Right ["xL{4","IE-","eK<}fE?e"]
 alaList :: sep -> [a] -> List sep (Identity a) a
 alaList _ = List
 

Cabal/src/Distribution/Simple/Compiler.hs

@@ -435,9 +435,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@.
+    NoDebugInfo
   | MinimalDebugInfo
-  | NormalDebugInfo
+  | -- | The enabled level when enabled by @--enable-debug-info@ or @debug-info: True@.
+    NormalDebugInfo
   | MaximalDebugInfo
   deriving (Bounded, Enum, Eq, Generic, Read, Show)
 
@@ -454,6 +456,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 'NormalDebugInfo' when there's
+-- no string or when the string is "True".  When the string is "False", the
+-- level is 'NoDebugInfo'.  The booleans are case-sensitive, so "true" and
+-- "false" are errors, as is any other string.
+--
+-- >>> [flagToDebugInfoLevel (Just $ show n) | n <- [0 .. 3]]
+-- [NoDebugInfo,MinimalDebugInfo,NormalDebugInfo,MaximalDebugInfo]
+--
+-- >>> nub $ flagToDebugInfoLevel . Just <$> ["0", "False"]
+-- [NoDebugInfo]
+--
+-- >>> nub $ flagToDebugInfoLevel <$> Nothing : (Just <$> ["2", "True"])
+-- [NormalDebugInfo]
 flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel
 flagToDebugInfoLevel Nothing = NormalDebugInfo
 flagToDebugInfoLevel (Just s)

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

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,27 +61,35 @@ 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)
-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 =
   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 optional-packages glob" testOptionalPackagesGlob
     , testCase "read extra-packages" testExtraPackages
     , testCase "read source-repository-package" testSourceRepoList
     , testCase "read project-config-build-only" testProjectConfigBuildOnly
     , testCase "read project-config-shared" testProjectConfigShared
     , testCase "read install-dirs" testInstallDirs
     , testCase "read remote-repos" testRemoteRepos
     , testCase "read local-no-index-repos" testLocalNoIndexRepos
+    , testCase "read project-file-parser" testProjectFileParser
     , 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
@@ -98,16 +105,35 @@ 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)
 
+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"]
+  -- 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"]
   (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"
@@ -298,26 +324,31 @@ 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
+
+-- | The parser is chosen before the project file is read, so neither parser
+-- takes this field from the file.
+testProjectFileParser :: Assertion
+testProjectFileParser = do
+  (config, legacy) <- readConfigDefault "project-file-parser"
+  assertConfigEquals NoFlag config legacy (projectConfigProjectFileParser . projectConfigShared . snd . condTreeData)
 
 testProjectConfigProvenance :: Assertion
 testProjectConfigProvenance = do
@@ -397,6 +428,18 @@ 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) <- 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
+    field = packageConfigTestHumanLog . projectConfigLocalPackages . snd . condTreeData
+
 testProjectConfigAllPackages :: Assertion
 testProjectConfigAllPackages = do
   (config, legacy) <- readConfigDefault "project-config-all-packages"
@@ -563,8 +606,26 @@ 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
+  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)
+readConfigDiverging testSubDir projectFileName = do
   (TestDir testRootFp projectConfigFp distDirLayout) <- testDirInfo testSubDir projectFileName
   exists <- liftIO $ doesFileExist projectConfigFp
   assertBool ("projectConfig does not exist: " <> projectConfigFp) exists

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}/

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

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}/

cabal-install/parser-tests/Tests/files/packages/cabal.project

@@ -1 +1,2 @@
 packages: . packages/packages.cabal
+packages: a,b

cabal-install/parser-tests/Tests/files/project-config-local-packages/cabal.empty-string.project

@@ -0,0 +1 @@
+test-log:

cabal-install/parser-tests/Tests/files/project-file-parser/cabal.project

@@ -0,0 +1 @@
+project-file-parser: legacy

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,9 @@ postProcessRepo lineno reponameStr repo0 = do
         Left $
           LocalRepo
             reponame
-            (normalise (uriPath uri))
+            -- 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
       let repo = repo0{remoteRepoName = reponame}

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

@@ -930,7 +930,10 @@ readProjectFileSkeletonCompare verbosity httpTransport distDirLayout key = do
   readProjectFileSkeletonGen verbosity httpTransport distDirLayout key $ \fp -> do
     debug verbosity "Reading project file using the comparative parser"
     (pres, bs) <- parseProjectFileSkeletonParsec verbosity httpTransport distDirLayout key fp
-    lres <- parseProjectFileSkeletonLegacy verbosity httpTransport distDirLayout key fp
+    -- The legacy parse is only compared against, so the warnings it would
+    -- print while parsing, such as those about duplicate or untrimmed
+    -- imports, are left to the parsec parse or they would be printed twice.
+    lres <- parseProjectFileSkeletonLegacy (modifyVerbosityFlags (const silent) verbosity) httpTransport distDirLayout key fp
     let (_, ppres) = runParseResult pres
     case (lres, ppres) of
       -- 1. Both succeed, compare the results