Use PackageTests projects for comparisons

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 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)

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.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]

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
@@ -24,7 +26,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 +50,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 (..))
@@ -61,19 +62,25 @@ import Distribution.Utils.NubList
 import Distribution.Verbosity
 import GHC.Stack (HasCallStack)
 import Network.URI (parseURI)
-import System.Directory (canonicalizePath, doesFileExist)
-import System.FilePath ((</>))
+import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist, listDirectory)
+import System.FilePath (makeRelative, normalise, takeDirectory, takeExtension, takeFileName, (</>))
 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
@@ -83,6 +90,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
@@ -98,16 +106,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 +325,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
@@ -397,6 +422,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 +600,81 @@ 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)
+
+-- | 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
+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/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}