Mattp/cabal glob perf improvements 2

.github/mergify.yml

@@ -44,6 +44,7 @@ pull_request_rules:
       - label=squash+merge me
       - label=merge delay passed
       - '#approved-reviews-by>=2'
+      - '-label~=^blocked:'
 
   # merge+no rebase strategy
   - actions:
@@ -55,6 +56,11 @@ pull_request_rules:
       - label=merge+no rebase
       - label=merge delay passed
       - '#approved-reviews-by>=2'
+      - '-label~=^blocked:'
+      # unlike the others, we need to force this one to be up to date
+      # because it's intended for when Mergify doesn't have permission
+      # to rebase
+      - '#commits-behind=0'
 
   # rebase+merge strategy for backports: require 1 approver instead of 2
   - actions:

Cabal/src/Distribution/PackageDescription/Check.hs

@@ -64,7 +64,6 @@ import Distribution.Simple.Glob
   ( Glob
   , GlobResult (..)
   , globMatches
-  , parseFileGlob
   , runDirFileGlob
   )
 import Distribution.Simple.Utils hiding (findPackageDesc, notice)
@@ -271,8 +270,6 @@ checkGenericPackageDescription
       checkP
         (not . null $ dups names)
         (PackageBuildImpossible $ DuplicateSections dupes)
-      -- PackageDescription checks.
-      checkPackageDescription packageDescription_
       -- Flag names.
       mapM_ checkFlagName genPackageFlags_
 
@@ -465,18 +462,6 @@ checkPackageDescription
     mapM_ (checkPath False "license-file" PathKindFile) licPaths
     mapM_ checkLicFileExist licenseFiles_
 
-    -- § Globs.
-    dataGlobs <- mapM (checkGlob "data-files") dataFiles_
-    extraGlobs <- mapM (checkGlob "extra-source-files") extraSrcFiles_
-    docGlobs <- mapM (checkGlob "extra-doc-files") extraDocFiles_
-    -- We collect globs to feed them to checkMissingDocs.
-
-    -- § Missing documentation.
-    checkMissingDocs
-      (catMaybes dataGlobs)
-      (catMaybes extraGlobs)
-      (catMaybes docGlobs)
-
     -- § Datafield checks.
     checkSetupBuildInfo setupBuildInfo_
     mapM_ checkTestedWith testedWith_
@@ -515,13 +500,26 @@ checkPackageDescription
       (isJust setupBuildInfo_ && buildType pkg /= Custom)
       (PackageBuildWarning NoCustomSetup)
 
+    -- § Globs.
+    dataGlobs <- catMaybes <$> mapM (checkGlob "data-files" ) dataFiles_
+    extraSrcGlobs <- catMaybes <$> mapM (checkGlob "extra-source-files" ) extraSrcFiles_
+    docGlobs <- catMaybes <$> mapM (checkGlob "extra-doc-files" ) 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") extraSrcFiles_
-    mapM_ (checkGlobFile specVersion_ "." "extra-doc-files") extraDocFiles_
-    mapM_ (checkGlobFile specVersion_ dataDir_ "data-files") dataFiles_
+    extraSrcFilesGlobResults <- mapM (checkGlobFile "." "extra-source-files") extraSrcGlobs
+    extraDocFilesGlobResults <- mapM (checkGlobFile "." "extra-doc-files") docGlobs
+    -- extraFilesGlobResults <- mapM (checkGlobFile "." "extra-files") extraGlobs
+    extraDataFilesGlobResults <- mapM (checkGlobFile dataDir_ "data-files") dataGlobs
+
+    -- § Missing documentation.
+    checkMissingDocs
+      extraDataFilesGlobResults
+      extraSrcFilesGlobResults
+      extraDocFilesGlobResults
     where
       checkNull
         :: Monad m
@@ -830,29 +828,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.
@@ -861,7 +858,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
@@ -880,9 +877,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
@@ -984,9 +981,9 @@ 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.
+  => [[GlobResult FilePath]] -- data-files globs.
+  -> [[GlobResult FilePath]] -- extra-source-files globs.
+  -> [[GlobResult FilePath]] -- extra-doc-files globs.
   -> CheckM m ()
 checkMissingDocs dgs esgs edgs = do
   extraDocSupport <- (>= CabalSpecV1_18) <$> asksCM ccSpecVersion
@@ -1002,11 +999,10 @@ checkMissingDocs dgs esgs edgs = do
 
         -- 2. Realise Globs.
         let realGlob t =
-              concatMap globMatches
-                <$> mapM (runDirFileGlobM ops "") t
-        rgs <- realGlob dgs
-        res <- realGlob esgs
-        red <- realGlob edgs
+              concatMap globMatches t
+        let rgs = realGlob dgs
+        let res = realGlob esgs
+        let red = realGlob edgs
 
         -- 3. Check if anything in 1. is missing in 2.
         let mcs = checkDoc extraDocSupport des (rgs ++ res ++ red)

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/Build/Macros.hs

@@ -58,7 +58,7 @@ generateCabalMacrosHeader pkg_descr lbi clbi =
           , let (major1, major2, minor) = majorMinor ver
           ]
       , Z.zPackageKey = case clbi of
-          LibComponentLocalBuildInfo{} -> componentCompatPackageKey clbi
+          LibComponentLocalBuildInfo{componentCompatPackageKey = compatPackageKey} -> compatPackageKey
           _ -> ""
       , Z.zComponentId = prettyShow (componentComponentId clbi)
       , Z.zPackageVersion = pkgVersion (package pkg_descr)

Cabal/src/Distribution/Simple/PreProcess/Types.hs

@@ -41,11 +41,12 @@ import qualified Text.PrettyPrint as Disp
 --  > ppTestHandler =
 --  >   PreProcessor {
 --  >     platformIndependent = True,
+--  >     ppOrdering = \_ _ -> return,
 --  >     runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->
 --  >       do info verbosity (inFile++" has been preprocessed to "++outFile)
 --  >          stuff <- readFile inFile
 --  >          writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff)
---  >          return ExitSuccess
+--  >          return ()
 --
 --  We split the input and output file names into a base directory and the
 --  rest of the file name. The input base dir is the path in the list of search

Cabal/src/Distribution/Simple/Register.hs

@@ -489,9 +489,9 @@ generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDi
     { IPI.sourcePackageId = packageId pkg
     , IPI.installedUnitId = componentUnitId clbi
     , IPI.installedComponentId_ = componentComponentId clbi
-    , IPI.instantiatedWith = componentInstantiatedWith clbi
+    , IPI.instantiatedWith = expectLibraryComponent (maybeComponentInstantiatedWith clbi)
     , IPI.sourceLibName = libName lib
-    , IPI.compatPackageKey = componentCompatPackageKey clbi
+    , IPI.compatPackageKey = expectLibraryComponent (maybeComponentCompatPackageKey clbi)
     , -- If GHC >= 8.4 we register with SDPX, otherwise with legacy license
       IPI.license =
         if ghc84
@@ -510,7 +510,7 @@ generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDi
     , IPI.indefinite = componentIsIndefinite clbi
     , IPI.exposed = libExposed lib
     , IPI.exposedModules =
-        componentExposedModules clbi
+        expectLibraryComponent (maybeComponentExposedModules clbi)
           -- add virtual modules into the list of exposed modules for the
           -- package database as well.
           ++ map (\name -> IPI.ExposedModule name Nothing) (virtualModules bi)
@@ -591,7 +591,13 @@ generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDi
           , dynlibdir installDirs : extraLibDirs bi
           )
       | otherwise =
+-- <<<<<<< HEAD
           (libdir installDirs : dynlibdir installDirs : extraLibDirs bi, [])
+-- =======
+--           (libdir installDirs : dynlibdir installDirs : extraLibDirs', [])
+    expectLibraryComponent (Just attribute) = attribute
+    expectLibraryComponent Nothing = (error "generalInstalledPackageInfo: Expected a library component, got something else.")
+-- >>>>>>> 68333b35a (Merge branch 'mattp/skip-glob-filepaths-2' into mattp/cabal-glob-perf-improvements)
 
 -- the compiler doesn't understand the dynamic-library-dirs field so we
 -- add the dyn directory to the "normal" list in the library-dirs field

Cabal/src/Distribution/Simple/Setup/Repl.hs

@@ -100,8 +100,7 @@ replCommand progDb =
     , commandDescription = Just $ \pname ->
         wrapText $
           "If the current directory contains no package, ignores COMPONENT "
-            ++ "parameters and opens an interactive interpreter session; if a "
-            ++ "sandbox is present, its package database will be used.\n"
+            ++ "parameters and opens an interactive interpreter session.\n"
             ++ "\n"
             ++ "Otherwise, (re)configures with the given or default flags, and "
             ++ "loads the interpreter with the relevant modules. For executables, "

Cabal/src/Distribution/Types/ComponentLocalBuildInfo.hs

@@ -6,6 +6,8 @@ module Distribution.Types.ComponentLocalBuildInfo
   ( ComponentLocalBuildInfo (..)
   , componentIsIndefinite
   , maybeComponentInstantiatedWith
+  , maybeComponentCompatPackageKey
+  , maybeComponentExposedModules
   ) where
 
 import Distribution.Compat.Prelude
@@ -126,3 +128,13 @@ maybeComponentInstantiatedWith :: ComponentLocalBuildInfo -> Maybe [(ModuleName,
 maybeComponentInstantiatedWith
   LibComponentLocalBuildInfo{componentInstantiatedWith = insts} = Just insts
 maybeComponentInstantiatedWith _ = Nothing
+
+maybeComponentCompatPackageKey :: ComponentLocalBuildInfo -> Maybe String
+maybeComponentCompatPackageKey
+  LibComponentLocalBuildInfo{componentCompatPackageKey = key} = Just key
+maybeComponentCompatPackageKey _ = Nothing
+
+maybeComponentExposedModules :: ComponentLocalBuildInfo -> Maybe [Installed.ExposedModule]
+maybeComponentExposedModules
+  LibComponentLocalBuildInfo{componentExposedModules = exposed} = Just exposed
+maybeComponentExposedModules _ = Nothing

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

@@ -1123,8 +1123,8 @@ symlink
       overwritePolicy
       installDir
       (mkSourceBinDir unit)
-      (mkExeName exe)
       (mkFinalExeName exe)
+      (mkExeName exe)
 
 -- |
 -- -- * When 'InstallCheckOnly', warn if install would fail overwrite policy
@@ -1169,7 +1169,7 @@ installCheckUnitExes
       errorMessage installdir exe = case overwritePolicy of
         NeverOverwrite ->
           "Path '"
-            <> (installdir </> prettyShow exe)
+            <> (installdir </> mkFinalExeName exe)
             <> "' already exists. "
             <> "Use --overwrite-policy=always to overwrite."
         -- This shouldn't even be possible, but we keep it in case symlinking or