Mattp/glob and preprocess

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

@@ -291,60 +291,62 @@ preprocessFile
   -- ^ fail on missing file
   -> IO ()
 preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers failOnMissing = do
-  -- look for files in the various source dirs with this module name
-  -- and a file extension of a known preprocessor
-  psrcFiles <- findFileWithExtension' (map fst handlers) (map getSymbolicPath searchLoc) baseFile
-  case psrcFiles of
-    -- no preprocessor file exists, look for an ordinary source file
-    -- just to make sure one actually exists at all for this module.
-    -- Note: by looking in the target/output build dir too, we allow
-    -- source files to appear magically in the target build dir without
-    -- any corresponding "real" source file. This lets custom Setup.hs
-    -- files generate source modules directly into the build dir without
-    -- the rest of the build system being aware of it (somewhat dodgy)
+  bsrcFiles <- findFileWithExtension builtinSuffixes (map getSymbolicPath searchLoc ++ [buildLoc]) baseFile
+  case bsrcFiles of
+    Just _ -> do
+      pure ()
     Nothing -> do
-      bsrcFiles <- findFileWithExtension builtinSuffixes (buildLoc : map getSymbolicPath searchLoc) baseFile
-      case (bsrcFiles, failOnMissing) of
-        (Nothing, True) ->
-          dieWithException verbosity $
-            CantFindSourceForPreProcessFile $
-              "can't find source for "
-                ++ baseFile
-                ++ " in "
-                ++ intercalate ", " (map getSymbolicPath searchLoc)
-        _ -> return ()
-    -- found a pre-processable file in one of the source dirs
-    Just (psrcLoc, psrcRelFile) -> do
-      let (srcStem, ext) = splitExtension psrcRelFile
-          psrcFile = psrcLoc </> psrcRelFile
-          pp =
-            fromMaybe
-              (error "Distribution.Simple.PreProcess: Just expected")
-              (lookup (Suffix $ safeTail ext) handlers)
-      -- Preprocessing files for 'sdist' is different from preprocessing
-      -- for 'build'.  When preprocessing for sdist we preprocess to
-      -- avoid that the user has to have the preprocessors available.
-      -- ATM, we don't have a way to specify which files are to be
-      -- preprocessed and which not, so for sdist we only process
-      -- platform independent files and put them into the 'buildLoc'
-      -- (which we assume is set to the temp. directory that will become
-      -- the tarball).
-      -- TODO: eliminate sdist variant, just supply different handlers
-      when (not forSDist || forSDist && platformIndependent pp) $ do
-        -- look for existing pre-processed source file in the dest dir to
-        -- see if we really have to re-run the preprocessor.
-        ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile
-        recomp <- case ppsrcFiles of
-          Nothing -> return True
-          Just ppsrcFile ->
-            psrcFile `moreRecentFile` ppsrcFile
-        when recomp $ do
-          let destDir = buildLoc </> dirName srcStem
-          createDirectoryIfMissingVerbose verbosity True destDir
-          runPreProcessorWithHsBootHack
-            pp
-            (psrcLoc, psrcRelFile)
-            (buildLoc, srcStem <.> "hs")
+      -- look for files in the various source dirs with this module name
+      -- and a file extension of a known preprocessor
+      psrcFiles <- findFileWithExtension' (map fst handlers) (map getSymbolicPath searchLoc) baseFile
+      case psrcFiles of
+        -- no preprocessor file exists, look for an ordinary source file
+        -- just to make sure one actually exists at all for this module.
+        -- Note: by looking in the target/output build dir too, we allow
+        -- source files to appear magically in the target build dir without
+        -- any corresponding "real" source file. This lets custom Setup.hs
+        -- files generate source modules directly into the build dir without
+        -- the rest of the build system being aware of it (somewhat dodgy)
+        Nothing -> do
+          when failOnMissing $ do
+            dieWithException verbosity $
+              CantFindSourceForPreProcessFile $
+                "can't find source for "
+                  ++ baseFile
+                  ++ " in "
+                  ++ intercalate ", " (map getSymbolicPath searchLoc)
+        -- found a pre-processable file in one of the source dirs
+        Just (psrcLoc, psrcRelFile) -> do
+          let (srcStem, ext) = splitExtension psrcRelFile
+              psrcFile = psrcLoc </> psrcRelFile
+              pp =
+                fromMaybe
+                  (error "Distribution.Simple.PreProcess: Just expected")
+                  (lookup (Suffix $ safeTail ext) handlers)
+          -- Preprocessing files for 'sdist' is different from preprocessing
+          -- for 'build'.  When preprocessing for sdist we preprocess to
+          -- avoid that the user has to have the preprocessors available.
+          -- ATM, we don't have a way to specify which files are to be
+          -- preprocessed and which not, so for sdist we only process
+          -- platform independent files and put them into the 'buildLoc'
+          -- (which we assume is set to the temp. directory that will become
+          -- the tarball).
+          -- TODO: eliminate sdist variant, just supply different handlers
+          when (not forSDist || forSDist && platformIndependent pp) $ do
+            -- look for existing pre-processed source file in the dest dir to
+            -- see if we really have to re-run the preprocessor.
+            ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile
+            recomp <- case ppsrcFiles of
+              Nothing -> return True
+              Just ppsrcFile ->
+                psrcFile `moreRecentFile` ppsrcFile
+            when recomp $ do
+              let destDir = buildLoc </> dirName srcStem
+              createDirectoryIfMissingVerbose verbosity True destDir
+              runPreProcessorWithHsBootHack
+                pp
+                (psrcLoc, psrcRelFile)
+                (buildLoc, srcStem <.> "hs")
   where
     dirName = takeDirectory
 

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