From 7c9e0de9a1200f8663bd1ea87d5d82a770b4eee7 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 4 Nov 2024 08:07:29 -0700 Subject: [PATCH 1/6] Delete second checkPackageDescription call --- Cabal/src/Distribution/PackageDescription/Check.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs index 8bab6ec961a..eb0cb3fa7b1 100644 --- a/Cabal/src/Distribution/PackageDescription/Check.hs +++ b/Cabal/src/Distribution/PackageDescription/Check.hs @@ -268,8 +268,6 @@ checkGenericPackageDescription checkP (not . null $ dups names) (PackageBuildImpossible $ DuplicateSections dupes) - -- PackageDescription checks. - checkPackageDescription packageDescription_ -- Flag names. mapM_ checkFlagName genPackageFlags_ From 70ae606ee9dff530a1635a135813536a49a222dd Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 4 Nov 2024 09:54:50 -0700 Subject: [PATCH 2/6] Don't Glob if Glob Ain't Glob 2: The Globbening --- Cabal/src/Distribution/Simple/Glob.hs | 32 ++++++++++++++++++++------- 1 file changed, 24 insertions(+), 8 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Glob.hs b/Cabal/src/Distribution/Simple/Glob.hs index 8798d7a8578..6771f1abd56 100644 --- a/Cabal/src/Distribution/Simple/Glob.hs +++ b/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,34 @@ 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 = root joinedPrefix filename + debug verbosity $ "Treating glob as filepath literal: " ++ filepath + exist <- doesFileExist 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' From c067f3a8ce38e8e082f90bfc25c952ba8c4d5b6c Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 4 Nov 2024 10:05:36 -0700 Subject: [PATCH 3/6] make style --- Cabal/src/Distribution/Simple/Glob.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/Cabal/src/Distribution/Simple/Glob.hs b/Cabal/src/Distribution/Simple/Glob.hs index 6771f1abd56..2d1404bc870 100644 --- a/Cabal/src/Distribution/Simple/Glob.hs +++ b/Cabal/src/Distribution/Simple/Glob.hs @@ -439,7 +439,6 @@ runDirFileGlob verbosity mspec rawRoot pat = do if exist then [GlobMatch filepath] else [] - Right variablePattern -> do debug verbosity $ "Expanding glob '" ++ show (pretty pat) ++ "' in directory '" ++ root ++ "'." directoryExists <- doesDirectoryExist (root joinedPrefix) From 1592c519c5d1ec5a0c5c56f7aba2c9dd48a487f2 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 4 Nov 2024 10:33:28 -0700 Subject: [PATCH 4/6] Fix tests --- .../UnitTests/Distribution/Simple/Glob.hs | 4 ++-- Cabal/src/Distribution/Simple/Glob.hs | 18 +++++++++++------- 2 files changed, 13 insertions(+), 9 deletions(-) diff --git a/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs b/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs index fce1ffbc050..c07fbb38623 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs +++ b/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 = diff --git a/Cabal/src/Distribution/Simple/Glob.hs b/Cabal/src/Distribution/Simple/Glob.hs index 2d1404bc870..d15c4a0dfff 100644 --- a/Cabal/src/Distribution/Simple/Glob.hs +++ b/Cabal/src/Distribution/Simple/Glob.hs @@ -432,13 +432,17 @@ runDirFileGlob verbosity mspec rawRoot pat = do case pathOrVariablePattern of Left filename -> do - let filepath = root joinedPrefix filename - debug verbosity $ "Treating glob as filepath literal: " ++ filepath - exist <- doesFileExist filepath - pure $ - if exist - then [GlobMatch filepath] - else [] + 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) From 6684a7aa3f53b3dd559090b6637cd116aa5a7a4c Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 4 Nov 2024 11:15:55 -0700 Subject: [PATCH 5/6] 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 From da080d1a235bd0d5481ab8d629adef122e31314b Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 4 Nov 2024 11:23:43 -0700 Subject: [PATCH 6/6] prettyShow --- Cabal/src/Distribution/PackageDescription/Check.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs index f3e425a1e85..b9b4dcd7eec 100644 --- a/Cabal/src/Distribution/PackageDescription/Check.hs +++ b/Cabal/src/Distribution/PackageDescription/Check.hs @@ -873,7 +873,7 @@ checkGlobResult title fp rs = dirCheck ++ catMaybes (map getWarning rs) where dirCheck | all (not . withoutNoMatchesWarning) rs = - [PackageDistSuspiciousWarn $ GlobNoMatch title (show fp)] + [PackageDistSuspiciousWarn $ GlobNoMatch title (prettyShow fp)] | otherwise = [] -- If there's a missing directory in play, since globs in Cabal packages @@ -892,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 (show fp) file) + Just $ PackageDistSuspiciousWarn (GlobExactMatch title (prettyShow fp) file) getWarning (GlobMissingDirectory dir) = - Just $ PackageDistSuspiciousWarn (GlobNoDir title (show fp) dir) + Just $ PackageDistSuspiciousWarn (GlobNoDir title (prettyShow fp) dir) -- GlobMatchesDirectory is handled elsewhere if relevant; -- we can discard it here. getWarning (GlobMatchesDirectory _) = Nothing