cabal Glob performance improvements rollup

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

@@ -107,13 +107,13 @@ testMatchesVersion version pat expected = do
           -- 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
+        assertFailure $ "Unexpected result (pure matcher): " ++ show actual ++ "\nExpected: " ++ show expected
     checkIO globPat =
       withSystemTempDirectory "globstar-sample" $ \tmpdir -> do
         makeSampleFiles tmpdir
         actual <- runDirFileGlob Verbosity.normal (Just version) tmpdir globPat
         unless (isEqual actual expected) $
-          assertFailure $ "Unexpected result (impure matcher): " ++ show actual
+          assertFailure $ "Unexpected result (impure matcher): " ++ show actual ++ "\nExpected: " ++ show expected
 
 testFailParseVersion :: CabalSpecVersion -> FilePath -> GlobSyntaxError -> Assertion
 testFailParseVersion version pat expected =

Cabal/src/Distribution/PackageDescription/Check.hs

@@ -65,7 +65,6 @@ import Distribution.Simple.Glob
   ( Glob
   , GlobResult (..)
   , globMatches
-  , parseFileGlob
   , runDirFileGlob
   )
 import Distribution.Simple.Utils hiding (findPackageDesc, notice)
@@ -268,8 +267,6 @@ checkGenericPackageDescription
       checkP
         (not . null $ dups names)
         (PackageBuildImpossible $ DuplicateSections dupes)
-      -- PackageDescription checks.
-      checkPackageDescription packageDescription_
       -- Flag names.
       mapM_ checkFlagName genPackageFlags_
 
@@ -465,20 +462,6 @@ checkPackageDescription
     mapM_ (checkPath False "license-file" PathKindFile) licPaths
     mapM_ checkLicFileExist licenseFiles_
 
-    -- § Globs.
-    dataGlobs <- mapM (checkGlob "data-files" . getSymbolicPath) dataFiles_
-    extraSrcGlobs <- mapM (checkGlob "extra-source-files" . getSymbolicPath) extraSrcFiles_
-    docGlobs <- mapM (checkGlob "extra-doc-files" . getSymbolicPath) extraDocFiles_
-    extraGlobs <- mapM (checkGlob "extra-files" . getSymbolicPath) extraFiles_
-    -- We collect globs to feed them to checkMissingDocs.
-
-    -- § Missing documentation.
-    checkMissingDocs
-      (catMaybes dataGlobs)
-      (catMaybes extraSrcGlobs)
-      (catMaybes docGlobs)
-      (catMaybes extraGlobs)
-
     -- § Datafield checks.
     checkSetupBuildInfo setupBuildInfo_
     mapM_ checkTestedWith testedWith_
@@ -517,14 +500,27 @@ checkPackageDescription
       (isJust setupBuildInfo_ && buildType pkg `notElem` [Custom, Hooks])
       (PackageBuildWarning NoCustomSetup)
 
+    -- § Globs.
+    dataGlobs <- catMaybes <$> mapM (checkGlob "data-files" . getSymbolicPath) dataFiles_
+    extraSrcGlobs <- catMaybes <$> mapM (checkGlob "extra-source-files" . getSymbolicPath) extraSrcFiles_
+    docGlobs <- catMaybes <$> mapM (checkGlob "extra-doc-files" . getSymbolicPath) extraDocFiles_
+    extraGlobs <- catMaybes <$> mapM (checkGlob "extra-files" . getSymbolicPath) extraFiles_
+
     -- Contents.
     checkConfigureExists (buildType pkg)
     checkSetupExists (buildType pkg)
     checkCabalFile (packageName pkg)
-    mapM_ (checkGlobFile specVersion_ "." "extra-source-files" . getSymbolicPath) extraSrcFiles_
-    mapM_ (checkGlobFile specVersion_ "." "extra-doc-files" . getSymbolicPath) extraDocFiles_
-    mapM_ (checkGlobFile specVersion_ "." "extra-files" . getSymbolicPath) extraFiles_
-    mapM_ (checkGlobFile specVersion_ rawDataDir "data-files" . getSymbolicPath) dataFiles_
+    extraSrcFilesGlobResults <- mapM (checkGlobFile "." "extra-source-files") extraSrcGlobs
+    extraDocFilesGlobResults <- mapM (checkGlobFile "." "extra-doc-files") docGlobs
+    extraFilesGlobResults <- mapM (checkGlobFile "." "extra-files") extraGlobs
+    extraDataFilesGlobResults <- mapM (checkGlobFile rawDataDir "data-files") dataGlobs
+
+    -- § Missing documentation.
+    checkMissingDocs
+      extraDataFilesGlobResults
+      extraSrcFilesGlobResults
+      extraDocFilesGlobResults
+      extraFilesGlobResults
     where
       checkNull
         :: Monad m
@@ -845,29 +841,28 @@ checkSetupExists _ =
 
 checkGlobFile
   :: Monad m
-  => CabalSpecVersion
-  -> FilePath -- Glob pattern.
-  -> FilePath -- Folder to check.
+  => FilePath -- Folder to check.
   -> CabalField -- .cabal field we are checking.
-  -> CheckM m ()
-checkGlobFile cv ddir title fp = do
+  -> Glob -- Glob pattern.
+  -> CheckM m [GlobResult FilePath]
+checkGlobFile ddir title parsedGlob = do
   let adjDdir = if null ddir then "." else ddir
       dir
         | title == "data-files" = adjDdir
         | otherwise = "."
-
-  case parseFileGlob cv fp of
-    -- We just skip over parse errors here; they're reported elsewhere.
-    Left _ -> return ()
-    Right parsedGlob -> do
-      liftInt ciPreDistOps $ \po -> do
-        rs <- runDirFileGlobM po dir parsedGlob
-        return $ checkGlobResult title fp rs
+  mpo <- asksCM (ciPreDistOps . ccInterface)
+  case mpo of
+    Nothing ->
+      pure []
+    Just po -> do
+      rs <- liftCM $ runDirFileGlobM po dir parsedGlob
+      mapM_ tellP (checkGlobResult title parsedGlob rs)
+      return rs
 
 -- | Checks for matchless globs and too strict matching (<2.4 spec).
 checkGlobResult
   :: CabalField -- .cabal field we are checking
-  -> FilePath -- Glob pattern (to show the user
+  -> Glob -- Glob pattern (to show the user
   -- which pattern is the offending
   -- one).
   -> [GlobResult FilePath] -- List of glob results.
@@ -876,7 +871,7 @@ checkGlobResult title fp rs = dirCheck ++ catMaybes (map getWarning rs)
   where
     dirCheck
       | all (not . withoutNoMatchesWarning) rs =
-          [PackageDistSuspiciousWarn $ GlobNoMatch title fp]
+          [PackageDistSuspiciousWarn $ GlobNoMatch title (prettyShow fp)]
       | otherwise = []
 
     -- If there's a missing directory in play, since globs in Cabal packages
@@ -895,9 +890,9 @@ checkGlobResult title fp rs = dirCheck ++ catMaybes (map getWarning rs)
     -- suffix. This warning detects when pre-2.4 package descriptions
     -- are omitting files purely because of the stricter check.
     getWarning (GlobWarnMultiDot file) =
-      Just $ PackageDistSuspiciousWarn (GlobExactMatch title fp file)
+      Just $ PackageDistSuspiciousWarn (GlobExactMatch title (prettyShow fp) file)
     getWarning (GlobMissingDirectory dir) =
-      Just $ PackageDistSuspiciousWarn (GlobNoDir title fp dir)
+      Just $ PackageDistSuspiciousWarn (GlobNoDir title (prettyShow fp) dir)
     -- GlobMatchesDirectory is handled elsewhere if relevant;
     -- we can discard it here.
     getWarning (GlobMatchesDirectory _) = Nothing
@@ -999,10 +994,10 @@ pd2gpd pd = gpd
 -- present in our .cabal file.
 checkMissingDocs
   :: Monad m
-  => [Glob] -- data-files globs.
-  -> [Glob] -- extra-source-files globs.
-  -> [Glob] -- extra-doc-files globs.
-  -> [Glob] -- extra-files globs.
+  => [[GlobResult FilePath]] -- data-files globs.
+  -> [[GlobResult FilePath]] -- extra-source-files globs.
+  -> [[GlobResult FilePath]] -- extra-doc-files globs.
+  -> [[GlobResult FilePath]] -- extra-files globs.
   -> CheckM m ()
 checkMissingDocs dgs esgs edgs efgs = do
   extraDocSupport <- (>= CabalSpecV1_18) <$> asksCM ccSpecVersion
@@ -1018,12 +1013,11 @@ checkMissingDocs dgs esgs edgs efgs = do
 
         -- 2. Realise Globs.
         let realGlob t =
-              concatMap globMatches
-                <$> mapM (runDirFileGlobM ops "") t
-        rgs <- realGlob dgs
-        res <- realGlob esgs
-        red <- realGlob edgs
-        ref <- realGlob efgs
+              concatMap globMatches t
+        let rgs = realGlob dgs
+        let res = realGlob esgs
+        let red = realGlob edgs
+        let ref = realGlob efgs
 
         -- 3. Check if anything in 1. is missing in 2.
         let mcs = checkDoc extraDocSupport des (rgs ++ res ++ red ++ ref)

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

@@ -37,6 +37,7 @@ module Distribution.PackageDescription.Check.Monad
   , checkP
   , checkPkg
   , liftInt
+  , liftCM
   , tellP
   , checkSpecVer
   ) where

Cabal/src/Distribution/Simple/Glob.hs

@@ -370,7 +370,6 @@ runDirFileGlob verbosity mspec rawRoot pat = do
       "Null dir passed to runDirFileGlob; interpreting it "
         ++ "as '.'. This is probably an internal error."
   let root = if null rawRoot then "." else rawRoot
-  debug verbosity $ "Expanding glob '" ++ show (pretty pat) ++ "' in directory '" ++ root ++ "'."
   -- This function might be called from the project root with dir as
   -- ".". Walking the tree starting there involves going into .git/
   -- and dist-newstyle/, which is a lot of work for no reward, so
@@ -379,7 +378,7 @@ runDirFileGlob verbosity mspec rawRoot pat = do
   -- the whole directory if *, and just the specific file if it's a
   -- literal.
   let
-    (prefixSegments, variablePattern) = splitConstantPrefix pat
+    (prefixSegments, pathOrVariablePattern) = splitConstantPrefix pat
     joinedPrefix = joinPath prefixSegments
 
     -- The glob matching function depends on whether we care about the cabal version or not
@@ -431,17 +430,37 @@ runDirFileGlob verbosity mspec rawRoot pat = do
       concat <$> traverse (\subdir -> go globPath (dir </> subdir)) subdirs
     go GlobDirTrailing dir = return [GlobMatch dir]
 
-  directoryExists <- doesDirectoryExist (root </> joinedPrefix)
-  if directoryExists
-    then go variablePattern joinedPrefix
-    else return [GlobMissingDirectory joinedPrefix]
+  case pathOrVariablePattern of
+    Left filename -> do
+      let filepath = joinedPrefix </> filename
+      debug verbosity $ "Treating glob as filepath literal '" ++ filepath ++ "' in directory '" ++ root ++ "'."
+      directoryExists <- doesDirectoryExist (root </> filepath)
+      if directoryExists
+        then pure [GlobMatchesDirectory filepath]
+        else do
+          exist <- doesFileExist (root </> filepath)
+          pure $
+            if exist
+              then [GlobMatch filepath]
+              else []
+    Right variablePattern -> do
+      debug verbosity $ "Expanding glob '" ++ show (pretty pat) ++ "' in directory '" ++ root ++ "'."
+      directoryExists <- doesDirectoryExist (root </> joinedPrefix)
+      if directoryExists
+        then go variablePattern joinedPrefix
+        else return [GlobMissingDirectory joinedPrefix]
   where
     -- \| Extract the (possibly null) constant prefix from the pattern.
     -- This has the property that, if @(pref, final) = splitConstantPrefix pat@,
     -- then @pat === foldr GlobDir final pref@.
-    splitConstantPrefix :: Glob -> ([FilePath], Glob)
-    splitConstantPrefix = unfoldr' step
+    splitConstantPrefix :: Glob -> ([FilePath], Either FilePath Glob)
+    splitConstantPrefix = fmap literalize . unfoldr' step
       where
+        literalize (GlobFile [Literal filename]) =
+          Left filename
+        literalize glob =
+          Right glob
+
         step (GlobDir [Literal seg] pat') = Right (seg, pat')
         step pat' = Left pat'