Merge pull request #9673 from alt-romes/wip/romes/globbing

Merge two Globbing Modules and Fix #5349

Author: mergify[bot]

Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 module UnitTests.Distribution.Simple.Glob
     ( tests
     ) where
@@ -54,7 +55,7 @@ compatibilityTests version =
   [ testCase "literal match" $
       testMatches "foo/a" [GlobMatch "foo/a"]
   , testCase "literal no match on prefix" $
-      testMatches "foo/c.html" []
+      testMatches "foo/c.html" [GlobMatchesDirectory "foo/c.html"]
   , testCase "literal no match on suffix" $
       testMatches "foo/a.html" [GlobMatch "foo/a.html"]
   , testCase "literal no prefix" $
@@ -64,7 +65,7 @@ compatibilityTests version =
   , testCase "glob" $
       testMatches "*.html" [GlobMatch "a.html", GlobMatch "b.html"]
   , testCase "glob in subdir" $
-      testMatches "foo/*.html" [GlobMatch "foo/a.html", GlobMatch "foo/b.html"]
+      testMatches "foo/*.html" [GlobMatchesDirectory "foo/c.html", GlobMatch "foo/b.html", GlobMatch "foo/a.html"]
   , testCase "glob multiple extensions" $
       testMatches "foo/*.html.gz" [GlobMatch "foo/a.html.gz", GlobMatch "foo/b.html.gz"]
   , testCase "glob in deep subdir" $
@@ -101,13 +102,16 @@ testMatchesVersion version pat expected = do
   where
     isEqual = (==) `on` (sort . fmap (fmap normalise))
     checkPure globPat = do
-      let actual = mapMaybe (fileGlobMatches globPat) sampleFileNames
-      unless (sort expected == sort actual) $
+      let actual = mapMaybe (\p -> (p <$) <$> fileGlobMatches version globPat p) sampleFileNames
+          -- We drop directory matches from the expected results since the pure
+          -- check can't identify that kind of match.
+          expected' = filter (\case GlobMatchesDirectory _ -> False; _ -> True) expected
+      unless (sort expected' == sort actual) $
         assertFailure $ "Unexpected result (pure matcher): " ++ show actual
     checkIO globPat =
       withSystemTempDirectory "globstar-sample" $ \tmpdir -> do
         makeSampleFiles tmpdir
-        actual <- runDirFileGlob Verbosity.normal tmpdir globPat
+        actual <- runDirFileGlob Verbosity.normal (Just version) tmpdir globPat
         unless (isEqual actual expected) $
           assertFailure $ "Unexpected result (impure matcher): " ++ show actual
 

Cabal/Cabal.cabal

@@ -108,6 +108,7 @@ library
     Distribution.Simple.GHCJS
     Distribution.Simple.Haddock
     Distribution.Simple.Glob
+    Distribution.Simple.Glob.Internal
     Distribution.Simple.HaskellSuite
     Distribution.Simple.Hpc
     Distribution.Simple.Install

Cabal/src/Distribution/PackageDescription/Check.hs

@@ -61,9 +61,20 @@ import Distribution.PackageDescription.Check.Warning
 import Distribution.Parsec.Warning (PWarning)
 import Distribution.Pretty (prettyShow)
 import Distribution.Simple.Glob
+  ( Glob
+  , GlobResult (..)
+  , globMatches
+  , parseFileGlob
+  , runDirFileGlob
+  )
 import Distribution.Simple.Utils hiding (findPackageDesc, notice)
 import Distribution.Utils.Generic (isAscii)
 import Distribution.Utils.Path
+  ( LicenseFile
+  , PackageDir
+  , SymbolicPath
+  , getSymbolicPath
+  )
 import Distribution.Verbosity
 import Distribution.Version
 import System.FilePath (splitExtension, takeFileName, (<.>), (</>))
@@ -170,7 +181,7 @@ checkPackageFilesGPD verbosity gpd root =
 
     checkPreIO =
       CheckPreDistributionOps
-        { runDirFileGlobM = \fp g -> runDirFileGlob verbosity (root </> fp) g
+        { runDirFileGlobM = \fp g -> runDirFileGlob verbosity (Just . specVersion $ packageDescription gpd) (root </> fp) g
         , getDirectoryContentsM = System.Directory.getDirectoryContents . relative
         }
 
@@ -853,13 +864,14 @@ checkGlobResult title fp rs = dirCheck ++ catMaybes (map getWarning rs)
           [PackageDistSuspiciousWarn $ GlobNoMatch title fp]
       | otherwise = []
 
-    -- If there's a missing directory in play, since our globs don't
-    -- (currently) support disjunction, that will always mean there are
+    -- If there's a missing directory in play, since globs in Cabal packages
+    -- don't (currently) support disjunction, that will always mean there are
     -- no matches. The no matches error in this case is strictly less
     -- informative than the missing directory error.
     withoutNoMatchesWarning (GlobMatch _) = True
     withoutNoMatchesWarning (GlobWarnMultiDot _) = False
     withoutNoMatchesWarning (GlobMissingDirectory _) = True
+    withoutNoMatchesWarning (GlobMatchesDirectory _) = True
 
     getWarning :: GlobResult FilePath -> Maybe PackageCheck
     getWarning (GlobMatch _) = Nothing
@@ -871,6 +883,9 @@ checkGlobResult title fp rs = dirCheck ++ catMaybes (map getWarning rs)
       Just $ PackageDistSuspiciousWarn (GlobExactMatch title fp file)
     getWarning (GlobMissingDirectory dir) =
       Just $ PackageDistSuspiciousWarn (GlobNoDir title fp dir)
+    -- GlobMatchesDirectory is handled elsewhere if relevant;
+    -- we can discard it here.
+    getWarning (GlobMatchesDirectory _) = Nothing
 
 -- ------------------------------------------------------------
 -- Other exports
@@ -1012,10 +1027,6 @@ checkMissingDocs dgs esgs edgs = do
         return (mcs ++ pcs)
     )
   where
-    -- From Distribution.Simple.Glob.
-    globMatches :: [GlobResult a] -> [a]
-    globMatches input = [a | GlobMatch a <- input]
-
     checkDoc
       :: Bool -- Cabal spec ≥ 1.18?
       -> [FilePath] -- Desirables.

Cabal/src/Distribution/PackageDescription/Check/Paths.hs

@@ -24,6 +24,11 @@ import Distribution.PackageDescription.Check.Common
 import Distribution.PackageDescription.Check.Monad
 import Distribution.Simple.CCompiler
 import Distribution.Simple.Glob
+  ( Glob
+  , explainGlobSyntaxError
+  , isRecursiveInRoot
+  , parseFileGlob
+  )
 import Distribution.Simple.Utils hiding (findPackageDesc, notice)
 import System.FilePath (splitDirectories, splitPath, takeExtension)