From 6684a7aa3f53b3dd559090b6637cd116aa5a7a4c Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 4 Nov 2024 11:15:55 -0700 Subject: [PATCH] Avoid redundant glob checking --- .../Distribution/PackageDescription/Check.hs | 88 +++++++++---------- .../PackageDescription/Check/Monad.hs | 1 + 2 files changed, 43 insertions(+), 46 deletions(-) diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs index 8bab6ec961a..f3e425a1e85 100644 --- a/Cabal/src/Distribution/PackageDescription/Check.hs +++ b/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) @@ -465,20 +464,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 +502,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 +843,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 +873,7 @@ checkGlobResult title fp rs = dirCheck ++ catMaybes (map getWarning rs) where dirCheck | all (not . withoutNoMatchesWarning) rs = - [PackageDistSuspiciousWarn $ GlobNoMatch title fp] + [PackageDistSuspiciousWarn $ GlobNoMatch title (show fp)] | otherwise = [] -- If there's a missing directory in play, since globs in Cabal packages @@ -895,9 +892,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 (show fp) file) getWarning (GlobMissingDirectory dir) = - Just $ PackageDistSuspiciousWarn (GlobNoDir title fp dir) + Just $ PackageDistSuspiciousWarn (GlobNoDir title (show fp) dir) -- GlobMatchesDirectory is handled elsewhere if relevant; -- we can discard it here. getWarning (GlobMatchesDirectory _) = Nothing @@ -999,10 +996,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 +1015,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) diff --git a/Cabal/src/Distribution/PackageDescription/Check/Monad.hs b/Cabal/src/Distribution/PackageDescription/Check/Monad.hs index 23d37570800..0ca3359597c 100644 --- a/Cabal/src/Distribution/PackageDescription/Check/Monad.hs +++ b/Cabal/src/Distribution/PackageDescription/Check/Monad.hs @@ -37,6 +37,7 @@ module Distribution.PackageDescription.Check.Monad , checkP , checkPkg , liftInt + , liftCM , tellP , checkSpecVer ) where