Skip to content

Commit 1da3835

Browse files
wismillwismill
committed
Move doc file check from checkPackageContent to checkPackageFilesPreDistribution
1 parent cae69e1 commit 1da3835

File tree

2 files changed

+132
-61
lines changed
  • Cabal/src/Distribution/PackageDescription
  • cabal-testsuite/PackageTests/Check/PackageFiles/MissingExpectedExtraDocFiles

2 files changed

+132
-61
lines changed

‎Cabal/src/Distribution/PackageDescription/Check.hs

Lines changed: 131 additions & 60 deletions
Original file line numberDiff line numberDiff line change
@@ -36,10 +36,11 @@ module Distribution.PackageDescription.Check (
3636
checkPackageFileNames,
3737
) where
3838

39+
import Data.Foldable (foldrM)
3940
import Distribution.Compat.Prelude
4041
import Prelude ()
4142

42-
import Data.List ((\\), group)
43+
import Data.List (delete, group)
4344
import Distribution.CabalSpecVersion
4445
import Distribution.Compat.Lens
4546
import Distribution.Compiler
@@ -251,6 +252,7 @@ data CheckExplanation =
251252
| UnknownDirectory String FilePath
252253
| MissingSourceControl
253254
| MissingExpectedExtraDocFiles [FilePath]
255+
| WrongFieldExpectedExtraDocFiles String [FilePath]
254256
deriving (Eq, Ord, Show)
255257

256258
-- | Wraps `ParseWarning` into `PackageCheck`.
@@ -784,10 +786,16 @@ ppExplanation MissingSourceControl =
784786
++ "details."
785787
ppExplanation (MissingExpectedExtraDocFiles paths) =
786788
"Please consider including the " ++ quotes paths
787-
++ " in the extra-doc-files section of the .cabal file "
789+
++ " in the 'extra-doc-files' section of the .cabal file "
788790
++ "if it contains useful information for users of the package."
789791
where quotes [p] = "file " ++ quote p
790792
quotes ps = "files " ++ intercalate ", " (map quote ps)
793+
ppExplanation (WrongFieldExpectedExtraDocFiles field paths) =
794+
"Please consider moving the " ++ quotes paths
795+
++ " from the '" ++ field ++ "' section of the .cabal file "
796+
++ "to the section 'extra-doc-files'."
797+
where quotes [p] = "file " ++ quote p
798+
quotes ps = "files " ++ intercalate ", " (map quote ps)
791799

792800

793801
-- | Results of some kind of failed package check.
@@ -2158,13 +2166,11 @@ checkPackageContent ops pkg = do
21582166
configureError <- checkConfigureExists ops pkg
21592167
localPathErrors <- checkLocalPathsExist ops pkg
21602168
vcsLocation <- checkMissingVcsInfo ops pkg
2161-
unlistedReadmes <- checkDesirableExtraDocFilesAreIncluded ops pkg
21622169

21632170
return $ licenseErrors
21642171
++ catMaybes [cabalBomError, cabalNameError, setupError, configureError]
21652172
++ localPathErrors
21662173
++ vcsLocation
2167-
++ unlistedReadmes
21682174

21692175
checkCabalFileBOM :: Monad m => CheckPackageContentOps m
21702176
-> m (Maybe PackageCheck)
@@ -2304,40 +2310,6 @@ repoTypeDirname Bazaar = [".bzr"]
23042310
repoTypeDirname Monotone = ["_MTN"]
23052311
repoTypeDirname Pijul = [".pijul"]
23062312

2307-
checkDesirableExtraDocFilesAreIncluded :: Monad m => CheckPackageContentOps m
2308-
-> PackageDescription
2309-
-> m [PackageCheck]
2310-
checkDesirableExtraDocFilesAreIncluded ops pkg = do
2311-
let dir = "."
2312-
rootContents <- getDirectoryContents ops dir
2313-
desirable <- filterM (doesFileExist ops)
2314-
[ dir </> file
2315-
| file <- rootContents
2316-
, isDesirableExtraDocFile file
2317-
]
2318-
-- [TODO] extraSrcFiles: add warning if the files are globed in
2319-
-- extra-source-files instead of extra-doc-files?
2320-
allDocFiles <- concatMap (fmap (dir </>)) <$>
2321-
traverse (getGlobFiles ops dir) (extraDocFiles pkg)
2322-
case desirable \\ allDocFiles of
2323-
[] -> return []
2324-
unlisted -> return
2325-
[PackageDistSuspiciousWarn (MissingExpectedExtraDocFiles unlisted)]
2326-
2327-
isDesirableExtraDocFile :: FilePath -> Bool
2328-
isDesirableExtraDocFile fp = map toLower basename `elem` desirable
2329-
where
2330-
(basename, _ext) = splitExtension fp
2331-
desirable =
2332-
[ -- Source: hackage-server/src/Distribution/Server/Packages/Readme.hs
2333-
"readme"
2334-
-- Source: hackage-server/src/Distribution/Server/Packages/ChangeLog.hs
2335-
, "news"
2336-
, "changelog"
2337-
, "change_log"
2338-
, "changes"
2339-
]
2340-
23412313
-- ------------------------------------------------------------
23422314
-- * Checks involving files in the package
23432315
-- ------------------------------------------------------------
@@ -2438,27 +2410,123 @@ checkGlobFiles :: Verbosity
24382410
-> PackageDescription
24392411
-> FilePath
24402412
-> IO [PackageCheck]
2441-
checkGlobFiles verbosity pkg root =
2442-
fmap concat $ for allGlobs $ \(field, dir, glob) ->
2443-
-- Note: we just skip over parse errors here; they're reported elsewhere.
2444-
case parseFileGlob (specVersion pkg) glob of
2445-
Left _ -> return []
2446-
Right parsedGlob -> do
2447-
results <- runDirFileGlob verbosity (root </> dir) parsedGlob
2448-
let individualWarnings = results >>= getWarning field glob
2449-
noMatchesWarning =
2450-
[ PackageDistSuspiciousWarn (GlobNoMatch field glob)
2451-
| all (not . suppressesNoMatchesWarning) results
2452-
]
2453-
return (noMatchesWarning ++ individualWarnings)
2413+
checkGlobFiles verbosity pkg root = do
2414+
-- Get the desirable doc files from package’s directory
2415+
rootContents <- System.Directory.getDirectoryContents root
2416+
desirableDocFiles0 <- filterM System.doesFileExist
2417+
[ root </> file
2418+
| file <- rootContents
2419+
, isDesirableExtraDocFile file
2420+
]
2421+
2422+
-- Check the globs
2423+
(warnings, unlisted) <- foldrM checkGlob ([], desirableDocFiles0) allGlobs
2424+
2425+
return $ if null unlisted
2426+
-- No missing desirable file
2427+
then warnings
2428+
-- Some missing desirable files
2429+
else warnings ++
2430+
[PackageDistSuspiciousWarn (MissingExpectedExtraDocFiles unlisted)]
24542431
where
2455-
adjustedDataDir = if null (dataDir pkg) then "." else dataDir pkg
2432+
adjustedDataDir = if null (dataDir pkg) then root else root </> dataDir pkg
2433+
-- Cabal fields with globs
2434+
allGlobs :: [(String, Bool, FilePath, FilePath)]
24562435
allGlobs = concat
2457-
[ (,,) "extra-source-files" "." <$> extraSrcFiles pkg
2458-
, (,,) "extra-doc-files" "." <$> extraDocFiles pkg
2459-
, (,,) "data-files" adjustedDataDir <$> dataFiles pkg
2436+
[ (,,,) "extra-source-files" False root <$> extraSrcFiles pkg
2437+
, (,,,) "extra-doc-files" True root <$> extraDocFiles pkg
2438+
, (,,,) "data-files" False adjustedDataDir <$> dataFiles pkg
24602439
]
24612440

2441+
-- For each field with globs (see allGlobs), look for:
2442+
-- • errors (missing directory, no match)
2443+
-- • omitted documentation files (readme, changelog)
2444+
checkGlob :: (String, Bool, FilePath, FilePath)
2445+
-> ([PackageCheck], [FilePath])
2446+
-> IO ([PackageCheck], [FilePath])
2447+
checkGlob (field, isDocField, dir, glob) acc@(warnings, desirableDocs) =
2448+
-- Note: we just skip over parse errors here; they're reported elsewhere.
2449+
case parseFileGlob (specVersion pkg) glob of
2450+
Left _ -> return acc
2451+
Right parsedGlob -> do
2452+
results <- runDirFileGlob verbosity (root </> dir) parsedGlob
2453+
let acc0 = (warnings, True, [], desirableDocs)
2454+
return $ case foldr checkGlobResult acc0 results of
2455+
(individualWarnings, noMatchesWarn, wrongPaths, desirableDocs') ->
2456+
let wrongFieldWarnings = [ PackageDistSuspiciousWarn
2457+
(WrongFieldExpectedExtraDocFiles
2458+
field wrongPaths)
2459+
| not (null wrongPaths) ]
2460+
in
2461+
( if noMatchesWarn
2462+
then [PackageDistSuspiciousWarn (GlobNoMatch field glob)] ++
2463+
individualWarnings ++
2464+
wrongFieldWarnings
2465+
else individualWarnings ++ wrongFieldWarnings
2466+
, desirableDocs'
2467+
)
2468+
where
2469+
checkGlobResult :: GlobResult FilePath
2470+
-> ([PackageCheck], Bool, [FilePath], [FilePath])
2471+
-> ([PackageCheck], Bool, [FilePath], [FilePath])
2472+
checkGlobResult result (ws, noMatchesWarn, wrongPaths, docFiles) =
2473+
let noMatchesWarn' = noMatchesWarn &&
2474+
not (suppressesNoMatchesWarning result)
2475+
in case getWarning field glob result of
2476+
-- No match: add warning and do no further check
2477+
Left w ->
2478+
( w : ws
2479+
, noMatchesWarn'
2480+
, wrongPaths
2481+
, docFiles
2482+
)
2483+
-- Match: check doc files
2484+
Right path ->
2485+
let path' = "." </> path -- HACK? match getDirectoryContents result
2486+
(wrongPaths', docFiles') = checkDoc isDocField path'
2487+
wrongPaths docFiles
2488+
in
2489+
( ws
2490+
, noMatchesWarn'
2491+
, wrongPaths'
2492+
, docFiles'
2493+
)
2494+
2495+
-- Check whether a path is a desirable doc: if so, check if it is in the
2496+
-- field "extra-doc-files" and remove it from the list of paths to check.
2497+
checkDoc :: Bool -- Is it "extra-doc-files" ?
2498+
-> FilePath -- Path to test
2499+
-> [FilePath] -- Previous wrong paths
2500+
-> [FilePath] -- Remaining paths to check
2501+
-> ([FilePath], [FilePath]) -- Updated paths
2502+
checkDoc isDocField path wrongFieldPaths docFiles =
2503+
if path `elem` docFiles
2504+
-- Found desirable doc file
2505+
then
2506+
( if isDocField then wrongFieldPaths else path : wrongFieldPaths
2507+
, delete path docFiles
2508+
)
2509+
-- Not a desirable doc file
2510+
else
2511+
( wrongFieldPaths
2512+
, docFiles
2513+
)
2514+
2515+
-- Test whether a file is a desirable documentation for Hackage server
2516+
isDesirableExtraDocFile :: FilePath -> Bool
2517+
isDesirableExtraDocFile fp = map toLower basename `elem` desirable
2518+
where
2519+
(basename, _ext) = splitExtension fp
2520+
desirable =
2521+
[ -- Source: hackage-server/src/Distribution/Server/Packages/Readme.hs
2522+
"readme"
2523+
-- Source: hackage-server/src/Distribution/Server/Packages/ChangeLog.hs
2524+
, "news"
2525+
, "changelog"
2526+
, "change_log"
2527+
, "changes"
2528+
]
2529+
24622530
-- If there's a missing directory in play, since our globs don't
24632531
-- (currently) support disjunction, that will always mean there are no
24642532
-- matches. The no matches error in this case is strictly less informative
@@ -2467,17 +2535,20 @@ checkGlobFiles verbosity pkg root =
24672535
suppressesNoMatchesWarning (GlobWarnMultiDot _) = False
24682536
suppressesNoMatchesWarning (GlobMissingDirectory _) = True
24692537

2470-
getWarning :: String -> FilePath -> GlobResult FilePath -> [PackageCheck]
2471-
getWarning _ _ (GlobMatch _) =
2472-
[]
2538+
getWarning :: String
2539+
-> FilePath
2540+
-> GlobResult FilePath
2541+
-> Either PackageCheck FilePath
2542+
getWarning _ _ (GlobMatch path) =
2543+
Right path
24732544
-- Before Cabal 2.4, the extensions of globs had to match the file
24742545
-- exactly. This has been relaxed in 2.4 to allow matching only the
24752546
-- suffix. This warning detects when pre-2.4 package descriptions are
24762547
-- omitting files purely because of the stricter check.
24772548
getWarning field glob (GlobWarnMultiDot file) =
2478-
[ PackageDistSuspiciousWarn (GlobExactMatch field glob file) ]
2549+
Left (PackageDistSuspiciousWarn (GlobExactMatch field glob file))
24792550
getWarning field glob (GlobMissingDirectory dir) =
2480-
[ PackageDistSuspiciousWarn (GlobNoDir field glob dir) ]
2551+
Left (PackageDistSuspiciousWarn (GlobNoDir field glob dir))
24812552

24822553
-- | Check that setup dependencies, have proper bounds.
24832554
-- In particular, @base@ and @Cabal@ upper bounds are mandatory.

‎cabal-testsuite/PackageTests/Check/PackageFiles/MissingExpectedExtraDocFiles/cabal.out

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,3 @@
11
# cabal check
22
Warning: These warnings may cause trouble when distributing the package:
3-
Warning: Please consider including the file './README' in the extra-doc-files section of the .cabal file if it contains useful information for users of the package.
3+
Warning: Please consider including the file './README' in the 'extra-doc-files' section of the .cabal file if it contains useful information for users of the package.

0 commit comments

Comments
 (0)