Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Avoid redundant glob checking #10520

Open
wants to merge 3 commits into
base: master
Choose a base branch
from
Open

Avoid redundant glob checking #10520

Show file tree
Hide file tree
Changes from 2 commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
6684a7a
Avoid redundant glob checking
parsonsmatt Nov 4, 2024
da080d1
prettyShow
parsonsmatt Nov 4, 2024
c0a8d2d
Match empty glob result case
parsonsmatt Nov 7, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
88 changes: 42 additions & 46 deletions Cabal/src/Distribution/PackageDescription/Check.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -65,7 +65,6 @@ import Distribution.Simple.Glob
( Glob
, GlobResult (..)
, globMatches
, parseFileGlob
, runDirFileGlob
)
import Distribution.Simple.Utils hiding (findPackageDesc, notice)
Expand Down Expand Up @@ -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_
Expand Down Expand Up @@ -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
Comment on lines +515 to +518
Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Instead of re-parsing each FilePath here, we reuse the globs parsed above in checkGlob.


-- § Missing documentation.
checkMissingDocs
extraDataFilesGlobResults
extraSrcFilesGlobResults
extraDocFilesGlobResults
extraFilesGlobResults
Comment on lines +520 to +525
Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

And instead of re-parsing and then re-running the glob find, we just use the results generated above.

where
checkNull
:: Monad m
Expand Down Expand Up @@ -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]
Comment on lines +846 to +849
Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

these args are all just String 🤪 and were incorrectly documented before.

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
Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

liftCM was not previously exported, but it is necessary to actually use this if the liftint interface doesn't suffice - and since that interface has a forced return of (), it can't work here.

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.
Expand All @@ -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 (prettyShow fp)]
| otherwise = []

-- If there's a missing directory in play, since globs in Cabal packages
Expand All @@ -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 (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
Expand Down Expand Up @@ -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
Expand All @@ -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
Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

can simplify this to globMatches t and rely on callers to concat the args, too 🤷🏻

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)
Expand Down
1 change: 1 addition & 0 deletions Cabal/src/Distribution/PackageDescription/Check/Monad.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -37,6 +37,7 @@ module Distribution.PackageDescription.Check.Monad
, checkP
, checkPkg
, liftInt
, liftCM
Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

If we don't want to expose this I can probably replace with a function like liftInt but that allows a secondary return, like,

liftIntWith 
    :: (CheckInterface m -> Maybe (i m))
    -> (i m -> m ([PackageCheck], r)
    -> CheckM m (Maybe r)

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Exposing it is fine.

, tellP
, checkSpecVer
) where
Expand Down
Loading