diff --git a/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs b/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs index 6ea21e7b368..93feff2fbbe 100644 --- a/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs +++ b/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs @@ -110,18 +110,29 @@ unqualComponentNameToPackageName = mkPackageNameST . unUnqualComponentNameST -- | Combine names in targets if one name is empty or both names are equal -- (partial function). -- Useful in 'Semigroup' and similar instances. -combineNames :: a -> a -> (a -> UnqualComponentName) -> String -> - UnqualComponentName +combineNames + :: a + -> a + -> (a -> UnqualComponentName) + -> String + -> UnqualComponentName combineNames a b tacc tt - -- One empty or the same. - | P.null unb || - una == unb = na - | P.null una = nb - -- Both non-empty, different. - | otherwise = error $ "Ambiguous values for " ++ tt ++ " field: '" - ++ una ++ "' and '" ++ unb ++ "'" - where - (na, nb) = (tacc a, tacc b) - una = unUnqualComponentName na - unb = unUnqualComponentName nb - + -- One empty or the same. + | P.null unb + || una == unb = + na + | P.null una = nb + -- Both non-empty, different. + | otherwise = + error $ + "Ambiguous values for " + ++ tt + ++ " field: '" + ++ una + ++ "' and '" + ++ unb + ++ "'" + where + (na, nb) = (tacc a, tacc b) + una = unUnqualComponentName na + unb = unUnqualComponentName nb diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs index 4a0db1d8d7b..e31969ca891 100644 --- a/Cabal/src/Distribution/PackageDescription/Check.hs +++ b/Cabal/src/Distribution/PackageDescription/Check.hs @@ -1,7 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------ - -- | -- Module : Distribution.PackageDescription.Check -- Copyright : Lennart Kolmodin 2008, Francesco Ariis 2022 @@ -49,8 +47,8 @@ import Distribution.Compiler import Distribution.License import Distribution.Package import Distribution.PackageDescription -import Distribution.PackageDescription.Check.Conditional import Distribution.PackageDescription.Check.Common +import Distribution.PackageDescription.Check.Conditional import Distribution.PackageDescription.Check.Monad import Distribution.PackageDescription.Check.Paths import Distribution.PackageDescription.Check.Target @@ -59,14 +57,14 @@ import Distribution.Pretty (prettyShow) import Distribution.Simple.Glob import Distribution.Simple.Utils hiding (findPackageDesc, notice) import Distribution.Utils.Generic (isAscii) +import Distribution.Utils.Path import Distribution.Verbosity import Distribution.Version -import Distribution.Utils.Path import System.FilePath (splitExtension, takeFileName, (<.>), ()) -import qualified Data.ByteString.Lazy as BS -import qualified Distribution.SPDX as SPDX -import qualified System.Directory as System +import qualified Data.ByteString.Lazy as BS +import qualified Distribution.SPDX as SPDX +import qualified System.Directory as System import qualified System.Directory (getDirectoryContents) import qualified System.FilePath.Windows as FilePath.Windows (isValid) @@ -93,9 +91,8 @@ import Control.Monad -- 3. 'PackageCheck' and 'CheckExplanation' are types for warning severity -- and description. - -- ------------------------------------------------------------ --- * Checking interface +-- Checking interface -- ------------------------------------------------------------ -- | 'checkPackagePrim' is the most general way to invoke package checks. @@ -106,24 +103,24 @@ import Control.Monad -- Generality over @m@ means we could do non pure checks in monads other -- than IO (e.g. a virtual filesystem, like a zip file, a VCS filesystem, -- etc). -checkPackagePrim :: Monad m => - Bool -> -- Perform pure checks? - Maybe (CheckPackageContentOps m) -> -- Package content interface. - Maybe (CheckPreDistributionOps m) -> -- Predist checks interface. - GenericPackageDescription -> -- GPD to check. - m [PackageCheck] +checkPackagePrim + :: Monad m + => Bool -- Perform pure checks? + -> Maybe (CheckPackageContentOps m) -- Package content interface. + -> Maybe (CheckPreDistributionOps m) -- Predist checks interface. + -> GenericPackageDescription -- GPD to check. + -> m [PackageCheck] checkPackagePrim b mco mpdo gpd = do - let cm = checkGenericPackageDescription gpd - ci = CheckInterface b mco mpdo - ctx = pristineCheckCtx ci gpd - execCheckM cm ctx + let cm = checkGenericPackageDescription gpd + ci = CheckInterface b mco mpdo + ctx = pristineCheckCtx ci gpd + execCheckM cm ctx -- | Check for common mistakes and problems in package descriptions. -- -- This is the standard collection of checks covering all aspects except -- for checks that require looking at files within the package. For those -- see 'checkPackageFiles'. --- checkPackage :: GenericPackageDescription -> [PackageCheck] checkPackage gpd = runIdentity $ checkPackagePrim True Nothing Nothing gpd @@ -139,35 +136,37 @@ checkConfiguredPackage pd = checkPackage (pd2gpd pd) -- -- The point of this extra generality is to allow doing checks in some virtual -- file system, for example a tarball in memory. --- -checkPackageContent :: Monad m - => CheckPackageContentOps m - -> GenericPackageDescription - -> m [PackageCheck] +checkPackageContent + :: Monad m + => CheckPackageContentOps m + -> GenericPackageDescription + -> m [PackageCheck] checkPackageContent pops gpd = checkPackagePrim False (Just pops) Nothing gpd -- | Sanity checks that require IO. 'checkPackageFiles' looks at the files -- in the package and expects to find the package unpacked at the given -- filepath. -checkPackageFilesGPD :: - Verbosity -> -- Glob warn message verbosity. - GenericPackageDescription -> - FilePath -> -- Package root. - IO [PackageCheck] +checkPackageFilesGPD + :: Verbosity -- Glob warn message verbosity. + -> GenericPackageDescription + -> FilePath -- Package root. + -> IO [PackageCheck] checkPackageFilesGPD verbosity gpd root = - checkPackagePrim False (Just checkFilesIO) (Just checkPreIO) gpd + checkPackagePrim False (Just checkFilesIO) (Just checkPreIO) gpd where - checkFilesIO = CheckPackageContentOps { - doesFileExist = System.doesFileExist . relative, - doesDirectoryExist = System.doesDirectoryExist . relative, - getDirectoryContents = System.Directory.getDirectoryContents . relative, - getFileContents = BS.readFile . relative - } - - checkPreIO = CheckPreDistributionOps { - runDirFileGlobM = \fp g -> runDirFileGlob verbosity (root fp) g, - getDirectoryContentsM = System.Directory.getDirectoryContents . relative - } + checkFilesIO = + CheckPackageContentOps + { doesFileExist = System.doesFileExist . relative + , doesDirectoryExist = System.doesDirectoryExist . relative + , getDirectoryContents = System.Directory.getDirectoryContents . relative + , getFileContents = BS.readFile . relative + } + + checkPreIO = + CheckPreDistributionOps + { runDirFileGlobM = \fp g -> runDirFileGlob verbosity (root fp) g + , getDirectoryContentsM = System.Directory.getDirectoryContents . relative + } relative path = root path @@ -175,16 +174,16 @@ checkPackageFilesGPD verbosity gpd root = -- -- This function is included for legacy reasons, use 'checkPackageFilesGPD' -- if you are working with 'GenericPackageDescription'. -checkPackageFiles :: - Verbosity -> -- Glob warn message verbosity. - PackageDescription -> - FilePath -> -- Package root. - IO [PackageCheck] +checkPackageFiles + :: Verbosity -- Glob warn message verbosity. + -> PackageDescription + -> FilePath -- Package root. + -> IO [PackageCheck] checkPackageFiles verbosity pd oot = - checkPackageFilesGPD verbosity (pd2gpd pd) oot + checkPackageFilesGPD verbosity (pd2gpd pd) oot -- ------------------------------------------------------------ --- * Package description +-- Package description -- ------------------------------------------------------------ -- Here lies the meat of the module. Starting from 'GenericPackageDescription', @@ -204,347 +203,507 @@ checkPackageFiles verbosity pd oot = -- you should walk condLibrary_ etc. and *not* the (empty) target info in -- PD. See 'pd2gpd' for a convenient hack when you only have -- 'PackageDescription'. --- -checkGenericPackageDescription :: Monad m => GenericPackageDescription -> - CheckM m () checkGenericPackageDescription - gpd@(GenericPackageDescription - packageDescription_ _gpdScannedVersion_ genPackageFlags_ - condLibrary_ condSubLibraries_ condForeignLibs_ condExecutables_ - condTestSuites_ condBenchmarks_) - = do - -- § Description and names. - checkPackageDescription packageDescription_ - -- Targets should be present... - let condAllLibraries = maybeToList condLibrary_ ++ - (map snd condSubLibraries_) - checkP (and [null condExecutables_, null condTestSuites_, - null condBenchmarks_, null condAllLibraries, - null condForeignLibs_]) - (PackageBuildImpossible NoTarget) - -- ... and have unique names (names are not under conditional, it is - -- appropriate to check here. - (nsubs, nexes, ntests, nbenchs) <- asksCM - ((\n -> (pnSubLibs n, pnExecs n, - pnTests n, pnBenchs n)) . ccNames) - let names = concat [nsubs, nexes, ntests, nbenchs] - dupes = dups names - checkP (not . null $ dups names) - (PackageBuildImpossible $ DuplicateSections dupes) - -- PackageDescription checks. - checkPackageDescription packageDescription_ - -- Flag names. - mapM_ checkFlagName genPackageFlags_ - - -- § Feature checks. - checkSpecVer CabalSpecV2_0 (not . null $ condSubLibraries_) - (PackageDistInexcusable CVMultiLib) - checkSpecVer CabalSpecV1_8 (not . null $ condTestSuites_) - (PackageDistInexcusable CVTestSuite) - - -- § Conditional targets - - -- Extract dependencies from libraries, to be passed along for - -- PVP checks purposes. - pName <- asksCM (packageNameToUnqualComponentName . pkgName . - pnPackageId . ccNames) - let ads = maybe [] ((:[]) . extractAssocDeps pName) condLibrary_ ++ - map (uncurry extractAssocDeps) condSubLibraries_ - - case condLibrary_ of - Just cl -> checkCondTarget - genPackageFlags_ - (checkLibrary False ads) - (const id) (mempty, cl) - Nothing -> return () - mapM_ (checkCondTarget genPackageFlags_ - (checkLibrary False ads) - (\u l -> l {libName = maybeToLibraryName (Just u)})) - condSubLibraries_ - mapM_ (checkCondTarget genPackageFlags_ - checkForeignLib - (const id)) - condForeignLibs_ - mapM_ (checkCondTarget genPackageFlags_ - (checkExecutable (package packageDescription_) ads) - (const id)) - condExecutables_ - mapM_ (checkCondTarget genPackageFlags_ - (checkTestSuite ads) - (\u l -> l {testName = u})) - condTestSuites_ - mapM_ (checkCondTarget genPackageFlags_ - (checkBenchmark ads) - (\u l -> l {benchmarkName = u})) - condBenchmarks_ - - -- For unused flags it is clearer and more convenient to fold the - -- data rather than walk it, an exception to the rule. - checkP (decFlags /= usedFlags) - (PackageDistSuspicious $ DeclaredUsedFlags decFlags usedFlags) - - -- Duplicate modules. - mapM_ tellP (checkDuplicateModules gpd) - - where - -- todo is this caught at parse time? - checkFlagName :: Monad m => PackageFlag -> CheckM m () - checkFlagName pf = - let fn = unFlagName . flagName $ pf - - invalidFlagName ('-':_) = True -- starts with dash - invalidFlagName cs = any (not . isAscii) cs -- non ASCII - in checkP (invalidFlagName fn) - (PackageDistInexcusable $ SuspiciousFlagName [fn]) - - decFlags :: Set.Set FlagName - decFlags = toSetOf (L.genPackageFlags . traverse . L.flagName) gpd - - usedFlags :: Set.Set FlagName - usedFlags = mconcat - [ toSetOf (L.condLibrary . traverse . traverseCondTreeV . L._PackageFlag) gpd - , toSetOf (L.condSubLibraries . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd - , toSetOf (L.condForeignLibs . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd - , toSetOf (L.condExecutables . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd - , toSetOf (L.condTestSuites . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd - , toSetOf (L.condBenchmarks . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + :: Monad m + => GenericPackageDescription + -> CheckM m () +checkGenericPackageDescription + gpd@( GenericPackageDescription + packageDescription_ + _gpdScannedVersion_ + genPackageFlags_ + condLibrary_ + condSubLibraries_ + condForeignLibs_ + condExecutables_ + condTestSuites_ + condBenchmarks_ + ) = + do + -- § Description and names. + checkPackageDescription packageDescription_ + -- Targets should be present... + let condAllLibraries = + maybeToList condLibrary_ + ++ (map snd condSubLibraries_) + checkP + ( and + [ null condExecutables_ + , null condTestSuites_ + , null condBenchmarks_ + , null condAllLibraries + , null condForeignLibs_ ] + ) + (PackageBuildImpossible NoTarget) + -- ... and have unique names (names are not under conditional, it is + -- appropriate to check here. + (nsubs, nexes, ntests, nbenchs) <- + asksCM + ( ( \n -> + ( pnSubLibs n + , pnExecs n + , pnTests n + , pnBenchs n + ) + ) + . ccNames + ) + let names = concat [nsubs, nexes, ntests, nbenchs] + dupes = dups names + checkP + (not . null $ dups names) + (PackageBuildImpossible $ DuplicateSections dupes) + -- PackageDescription checks. + checkPackageDescription packageDescription_ + -- Flag names. + mapM_ checkFlagName genPackageFlags_ + + -- § Feature checks. + checkSpecVer + CabalSpecV2_0 + (not . null $ condSubLibraries_) + (PackageDistInexcusable CVMultiLib) + checkSpecVer + CabalSpecV1_8 + (not . null $ condTestSuites_) + (PackageDistInexcusable CVTestSuite) + + -- § Conditional targets + + -- Extract dependencies from libraries, to be passed along for + -- PVP checks purposes. + pName <- + asksCM + ( packageNameToUnqualComponentName + . pkgName + . pnPackageId + . ccNames + ) + let ads = + maybe [] ((: []) . extractAssocDeps pName) condLibrary_ + ++ map (uncurry extractAssocDeps) condSubLibraries_ + + case condLibrary_ of + Just cl -> + checkCondTarget + genPackageFlags_ + (checkLibrary False ads) + (const id) + (mempty, cl) + Nothing -> return () + mapM_ + ( checkCondTarget + genPackageFlags_ + (checkLibrary False ads) + (\u l -> l{libName = maybeToLibraryName (Just u)}) + ) + condSubLibraries_ + mapM_ + ( checkCondTarget + genPackageFlags_ + checkForeignLib + (const id) + ) + condForeignLibs_ + mapM_ + ( checkCondTarget + genPackageFlags_ + (checkExecutable (package packageDescription_) ads) + (const id) + ) + condExecutables_ + mapM_ + ( checkCondTarget + genPackageFlags_ + (checkTestSuite ads) + (\u l -> l{testName = u}) + ) + condTestSuites_ + mapM_ + ( checkCondTarget + genPackageFlags_ + (checkBenchmark ads) + (\u l -> l{benchmarkName = u}) + ) + condBenchmarks_ + + -- For unused flags it is clearer and more convenient to fold the + -- data rather than walk it, an exception to the rule. + checkP + (decFlags /= usedFlags) + (PackageDistSuspicious $ DeclaredUsedFlags decFlags usedFlags) + + -- Duplicate modules. + mapM_ tellP (checkDuplicateModules gpd) + where + -- todo is this caught at parse time? + checkFlagName :: Monad m => PackageFlag -> CheckM m () + checkFlagName pf = + let fn = unFlagName . flagName $ pf + + invalidFlagName ('-' : _) = True -- starts with dash + invalidFlagName cs = any (not . isAscii) cs -- non ASCII + in checkP + (invalidFlagName fn) + (PackageDistInexcusable $ SuspiciousFlagName [fn]) + + decFlags :: Set.Set FlagName + decFlags = toSetOf (L.genPackageFlags . traverse . L.flagName) gpd + + usedFlags :: Set.Set FlagName + usedFlags = + mconcat + [ toSetOf (L.condLibrary . traverse . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condSubLibraries . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condForeignLibs . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condExecutables . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condTestSuites . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condBenchmarks . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + ] checkPackageDescription :: Monad m => PackageDescription -> CheckM m () checkPackageDescription - pkg@(PackageDescription - specVersion_ package_ licenseRaw_ licenseFiles_ _copyright_ - maintainer_ _author_ _stability_ testedWith_ _homepage_ _pkgUrl_ - _bugReports_ sourceRepos_ synopsis_ description_ category_ - customFieldsPD_ buildTypeRaw_ setupBuildInfo_ _library_ - _subLibraries_ _executables_ _foreignLibs_ _testSuites_ _benchmarks_ - dataFiles_ dataDir_ extraSrcFiles_ extraTmpFiles_ extraDocFiles_) = do - - -- § Sanity checks. - checkPackageId package_ - -- TODO `name` is caught at parse level, remove this test. - let pn = packageName package_ - checkP (null . unPackageName $ pn) - (PackageBuildImpossible NoNameField) - -- TODO `version` is caught at parse level, remove this test. - checkP (nullVersion == packageVersion package_) - (PackageBuildImpossible NoVersionField) - -- But it is OK for executables to have the same name. - nsubs <- asksCM (pnSubLibs . ccNames) - checkP (any (== prettyShow pn) (prettyShow <$> nsubs)) - (PackageBuildImpossible $ IllegalLibraryName pn) - - -- § Fields check. - checkNull category_ - (PackageDistSuspicious $ MissingField CEFCategory) - checkNull maintainer_ - (PackageDistSuspicious $ MissingField CEFMaintainer) - checkP (ShortText.null synopsis_ && not (ShortText.null description_)) - (PackageDistSuspicious $ MissingField CEFSynopsis) - checkP (ShortText.null description_ && not (ShortText.null synopsis_)) - (PackageDistSuspicious $ MissingField CEFDescription) - checkP (all ShortText.null [synopsis_, description_]) - (PackageDistInexcusable $ MissingField CEFSynOrDesc) - checkP (ShortText.length synopsis_ > 80) - (PackageDistSuspicious SynopsisTooLong) - checkP (not (ShortText.null description_) && - ShortText.length description_ <= ShortText.length synopsis_) - (PackageDistSuspicious ShortDesc) - - -- § Paths. - mapM_ (checkPath False "extra-source-files" PathKindGlob) extraSrcFiles_ - mapM_ (checkPath False "extra-tmp-files" PathKindFile) extraTmpFiles_ - mapM_ (checkPath False "extra-doc-files" PathKindGlob) extraDocFiles_ - mapM_ (checkPath False "data-files" PathKindGlob) dataFiles_ - checkPath True "data-dir" PathKindDirectory dataDir_ - let licPaths = map getSymbolicPath licenseFiles_ - 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_ - either checkNewLicense - (checkOldLicense $ null licenseFiles_) - licenseRaw_ - checkSourceRepos sourceRepos_ - mapM_ checkCustomField customFieldsPD_ - - -- Feature checks. - checkSpecVer CabalSpecV1_18 (not . null $ extraDocFiles_) - (PackageDistInexcusable CVExtraDocFiles) - checkSpecVer CabalSpecV1_6 (not . null $ sourceRepos_) - (PackageDistInexcusable CVSourceRepository) - checkP (specVersion_ >= CabalSpecV1_24 && - isNothing setupBuildInfo_ && - buildTypeRaw_ == Just Custom) - (PackageBuildWarning CVCustomSetup) - checkSpecVer CabalSpecV1_24 - (isNothing setupBuildInfo_ && - buildTypeRaw_ == Just Custom) - (PackageDistSuspiciousWarn CVExpliticDepsCustomSetup) - checkP (isNothing buildTypeRaw_ && specVersion_ < CabalSpecV2_2) - (PackageBuildWarning NoBuildType) - checkP (isJust setupBuildInfo_ && buildType pkg /= Custom) - (PackageBuildWarning NoCustomSetup) - - -- 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_ + pkg@( PackageDescription + specVersion_ + package_ + licenseRaw_ + licenseFiles_ + _copyright_ + maintainer_ + _author_ + _stability_ + testedWith_ + _homepage_ + _pkgUrl_ + _bugReports_ + sourceRepos_ + synopsis_ + description_ + category_ + customFieldsPD_ + buildTypeRaw_ + setupBuildInfo_ + _library_ + _subLibraries_ + _executables_ + _foreignLibs_ + _testSuites_ + _benchmarks_ + dataFiles_ + dataDir_ + extraSrcFiles_ + extraTmpFiles_ + extraDocFiles_ + ) = do + -- § Sanity checks. + checkPackageId package_ + -- TODO `name` is caught at parse level, remove this test. + let pn = packageName package_ + checkP + (null . unPackageName $ pn) + (PackageBuildImpossible NoNameField) + -- TODO `version` is caught at parse level, remove this test. + checkP + (nullVersion == packageVersion package_) + (PackageBuildImpossible NoVersionField) + -- But it is OK for executables to have the same name. + nsubs <- asksCM (pnSubLibs . ccNames) + checkP + (any (== prettyShow pn) (prettyShow <$> nsubs)) + (PackageBuildImpossible $ IllegalLibraryName pn) + + -- § Fields check. + checkNull + category_ + (PackageDistSuspicious $ MissingField CEFCategory) + checkNull + maintainer_ + (PackageDistSuspicious $ MissingField CEFMaintainer) + checkP + (ShortText.null synopsis_ && not (ShortText.null description_)) + (PackageDistSuspicious $ MissingField CEFSynopsis) + checkP + (ShortText.null description_ && not (ShortText.null synopsis_)) + (PackageDistSuspicious $ MissingField CEFDescription) + checkP + (all ShortText.null [synopsis_, description_]) + (PackageDistInexcusable $ MissingField CEFSynOrDesc) + checkP + (ShortText.length synopsis_ > 80) + (PackageDistSuspicious SynopsisTooLong) + checkP + ( not (ShortText.null description_) + && ShortText.length description_ <= ShortText.length synopsis_ + ) + (PackageDistSuspicious ShortDesc) + + -- § Paths. + mapM_ (checkPath False "extra-source-files" PathKindGlob) extraSrcFiles_ + mapM_ (checkPath False "extra-tmp-files" PathKindFile) extraTmpFiles_ + mapM_ (checkPath False "extra-doc-files" PathKindGlob) extraDocFiles_ + mapM_ (checkPath False "data-files" PathKindGlob) dataFiles_ + checkPath True "data-dir" PathKindDirectory dataDir_ + let licPaths = map getSymbolicPath licenseFiles_ + 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_ + either + checkNewLicense + (checkOldLicense $ null licenseFiles_) + licenseRaw_ + checkSourceRepos sourceRepos_ + mapM_ checkCustomField customFieldsPD_ + + -- Feature checks. + checkSpecVer + CabalSpecV1_18 + (not . null $ extraDocFiles_) + (PackageDistInexcusable CVExtraDocFiles) + checkSpecVer + CabalSpecV1_6 + (not . null $ sourceRepos_) + (PackageDistInexcusable CVSourceRepository) + checkP + ( specVersion_ >= CabalSpecV1_24 + && isNothing setupBuildInfo_ + && buildTypeRaw_ == Just Custom + ) + (PackageBuildWarning CVCustomSetup) + checkSpecVer + CabalSpecV1_24 + ( isNothing setupBuildInfo_ + && buildTypeRaw_ == Just Custom + ) + (PackageDistSuspiciousWarn CVExpliticDepsCustomSetup) + checkP + (isNothing buildTypeRaw_ && specVersion_ < CabalSpecV2_2) + (PackageBuildWarning NoBuildType) + checkP + (isJust setupBuildInfo_ && buildType pkg /= Custom) + (PackageBuildWarning NoCustomSetup) + + -- 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_ where - checkNull :: Monad m => ShortText.ShortText -> PackageCheck -> - CheckM m () - checkNull st c = checkP (ShortText.null st) c - - checkTestedWith :: Monad m => (CompilerFlavor, VersionRange) -> - CheckM m () - checkTestedWith (OtherCompiler n, _) = - tellP (PackageBuildWarning $ UnknownCompilers [n]) - checkTestedWith (compiler, versionRange) = - checkVersionRange compiler versionRange - - checkVersionRange :: Monad m => CompilerFlavor -> VersionRange -> - CheckM m () - checkVersionRange cmp vr = - when (isNoVersion vr) - (let dep = [Dependency (mkPackageName (prettyShow cmp)) - vr mainLibSet] - in tellP (PackageDistInexcusable (InvalidTestWith dep))) + checkNull + :: Monad m + => ShortText.ShortText + -> PackageCheck + -> CheckM m () + checkNull st c = checkP (ShortText.null st) c + + checkTestedWith + :: Monad m + => (CompilerFlavor, VersionRange) + -> CheckM m () + checkTestedWith (OtherCompiler n, _) = + tellP (PackageBuildWarning $ UnknownCompilers [n]) + checkTestedWith (compiler, versionRange) = + checkVersionRange compiler versionRange + + checkVersionRange + :: Monad m + => CompilerFlavor + -> VersionRange + -> CheckM m () + checkVersionRange cmp vr = + when + (isNoVersion vr) + ( let dep = + [ Dependency + (mkPackageName (prettyShow cmp)) + vr + mainLibSet + ] + in tellP (PackageDistInexcusable (InvalidTestWith dep)) + ) checkSetupBuildInfo :: Monad m => Maybe SetupBuildInfo -> CheckM m () checkSetupBuildInfo Nothing = return () checkSetupBuildInfo (Just (SetupBuildInfo ds _)) = do - let uqs = map mkUnqualComponentName ["base", "Cabal"] - (is, rs) <- partitionDeps [] uqs ds - let ick = PackageDistInexcusable . UpperBoundSetup - rck = PackageDistSuspiciousWarn . - MissingUpperBounds CETSetup - checkPVP ick is - checkPVPs rck rs + let uqs = map mkUnqualComponentName ["base", "Cabal"] + (is, rs) <- partitionDeps [] uqs ds + let ick = PackageDistInexcusable . UpperBoundSetup + rck = + PackageDistSuspiciousWarn + . MissingUpperBounds CETSetup + checkPVP ick is + checkPVPs rck rs checkPackageId :: Monad m => PackageIdentifier -> CheckM m () checkPackageId (PackageIdentifier pkgName_ _pkgVersion_) = do - checkP (not . FilePath.Windows.isValid . prettyShow $ pkgName_) - (PackageDistInexcusable $ InvalidNameWin pkgName_) - checkP (isPrefixOf "z-" . prettyShow $ pkgName_) $ - (PackageDistInexcusable ZPrefix) + checkP + (not . FilePath.Windows.isValid . prettyShow $ pkgName_) + (PackageDistInexcusable $ InvalidNameWin pkgName_) + checkP (isPrefixOf "z-" . prettyShow $ pkgName_) $ + (PackageDistInexcusable ZPrefix) checkNewLicense :: Monad m => SPDX.License -> CheckM m () checkNewLicense lic = do - checkP (lic == SPDX.NONE) - (PackageDistInexcusable NONELicense) - -checkOldLicense :: Monad m => - Bool -> -- Flag: no license file? - License -> - CheckM m () + checkP + (lic == SPDX.NONE) + (PackageDistInexcusable NONELicense) + +checkOldLicense + :: Monad m + => Bool -- Flag: no license file? + -> License + -> CheckM m () checkOldLicense nullLicFiles lic = do - checkP (lic == UnspecifiedLicense) - (PackageDistInexcusable NoLicense) - checkP (lic == AllRightsReserved) - (PackageDistSuspicious AllRightsReservedLicense) - checkSpecVer CabalSpecV1_4 (lic `notElem` compatLicenses) - (PackageDistInexcusable (LicenseMessParse lic)) - checkP (lic == BSD4) - (PackageDistSuspicious UncommonBSD4) - case lic of - UnknownLicense l -> - tellP (PackageBuildWarning (UnrecognisedLicense l)) - _ -> return () - checkP (lic `notElem` [AllRightsReserved, - UnspecifiedLicense, PublicDomain] && - -- AllRightsReserved and PublicDomain are not strictly - -- licenses so don't need license files. - nullLicFiles) $ - (PackageDistSuspicious NoLicenseFile) - case unknownLicenseVersion lic of - Just knownVersions -> tellP - (PackageDistSuspicious $ UnknownLicenseVersion lic knownVersions) - _ -> return () - where - compatLicenses = [GPL Nothing, LGPL Nothing, AGPL Nothing, BSD3, - BSD4, PublicDomain, AllRightsReserved, - UnspecifiedLicense, OtherLicense] - - unknownLicenseVersion (GPL (Just v)) - | v `notElem` knownVersions = Just knownVersions - where knownVersions = [ v' | GPL (Just v') <- knownLicenses ] - unknownLicenseVersion (LGPL (Just v)) - | v `notElem` knownVersions = Just knownVersions - where knownVersions = [ v' | LGPL (Just v') <- knownLicenses ] - unknownLicenseVersion (AGPL (Just v)) - | v `notElem` knownVersions = Just knownVersions - where knownVersions = [ v' | AGPL (Just v') <- knownLicenses ] - unknownLicenseVersion (Apache (Just v)) - | v `notElem` knownVersions = Just knownVersions - where knownVersions = [ v' | Apache (Just v') <- knownLicenses ] - unknownLicenseVersion _ = Nothing + checkP + (lic == UnspecifiedLicense) + (PackageDistInexcusable NoLicense) + checkP + (lic == AllRightsReserved) + (PackageDistSuspicious AllRightsReservedLicense) + checkSpecVer + CabalSpecV1_4 + (lic `notElem` compatLicenses) + (PackageDistInexcusable (LicenseMessParse lic)) + checkP + (lic == BSD4) + (PackageDistSuspicious UncommonBSD4) + case lic of + UnknownLicense l -> + tellP (PackageBuildWarning (UnrecognisedLicense l)) + _ -> return () + checkP + ( lic + `notElem` [ AllRightsReserved + , UnspecifiedLicense + , PublicDomain + ] + && + -- AllRightsReserved and PublicDomain are not strictly + -- licenses so don't need license files. + nullLicFiles + ) + $ (PackageDistSuspicious NoLicenseFile) + case unknownLicenseVersion lic of + Just knownVersions -> + tellP + (PackageDistSuspicious $ UnknownLicenseVersion lic knownVersions) + _ -> return () + where + compatLicenses = + [ GPL Nothing + , LGPL Nothing + , AGPL Nothing + , BSD3 + , BSD4 + , PublicDomain + , AllRightsReserved + , UnspecifiedLicense + , OtherLicense + ] + + unknownLicenseVersion (GPL (Just v)) + | v `notElem` knownVersions = Just knownVersions + where + knownVersions = [v' | GPL (Just v') <- knownLicenses] + unknownLicenseVersion (LGPL (Just v)) + | v `notElem` knownVersions = Just knownVersions + where + knownVersions = [v' | LGPL (Just v') <- knownLicenses] + unknownLicenseVersion (AGPL (Just v)) + | v `notElem` knownVersions = Just knownVersions + where + knownVersions = [v' | AGPL (Just v') <- knownLicenses] + unknownLicenseVersion (Apache (Just v)) + | v `notElem` knownVersions = Just knownVersions + where + knownVersions = [v' | Apache (Just v') <- knownLicenses] + unknownLicenseVersion _ = Nothing checkSourceRepos :: Monad m => [SourceRepo] -> CheckM m () checkSourceRepos rs = do - mapM_ repoCheck rs - checkMissingVcsInfo rs - where - -- Single repository checks. - repoCheck :: Monad m => SourceRepo -> CheckM m () - repoCheck (SourceRepo repoKind_ repoType_ repoLocation_ - repoModule_ _repoBranch_ repoTag_ repoSubdir_) = do - case repoKind_ of - RepoKindUnknown kind -> tellP - (PackageDistInexcusable $ UnrecognisedSourceRepo kind) - _ -> return () - checkP (isNothing repoType_) - (PackageDistInexcusable MissingType) - checkP (isNothing repoLocation_) - (PackageDistInexcusable MissingLocation) - checkP (repoType_ == Just (KnownRepoType CVS) && - isNothing repoModule_) - (PackageDistInexcusable MissingModule) - checkP (repoKind_ == RepoThis && isNothing repoTag_) - (PackageDistInexcusable MissingTag) - checkP (any isAbsoluteOnAnyPlatform repoSubdir_) - (PackageDistInexcusable SubdirRelPath) - case join . fmap isGoodRelativeDirectoryPath $ repoSubdir_ of - Just err -> tellP - (PackageDistInexcusable $ SubdirGoodRelPath err) - Nothing -> return () + mapM_ repoCheck rs + checkMissingVcsInfo rs + where + -- Single repository checks. + repoCheck :: Monad m => SourceRepo -> CheckM m () + repoCheck + ( SourceRepo + repoKind_ + repoType_ + repoLocation_ + repoModule_ + _repoBranch_ + repoTag_ + repoSubdir_ + ) = do + case repoKind_ of + RepoKindUnknown kind -> + tellP + (PackageDistInexcusable $ UnrecognisedSourceRepo kind) + _ -> return () + checkP + (isNothing repoType_) + (PackageDistInexcusable MissingType) + checkP + (isNothing repoLocation_) + (PackageDistInexcusable MissingLocation) + checkP + ( repoType_ == Just (KnownRepoType CVS) + && isNothing repoModule_ + ) + (PackageDistInexcusable MissingModule) + checkP + (repoKind_ == RepoThis && isNothing repoTag_) + (PackageDistInexcusable MissingTag) + checkP + (any isAbsoluteOnAnyPlatform repoSubdir_) + (PackageDistInexcusable SubdirRelPath) + case join . fmap isGoodRelativeDirectoryPath $ repoSubdir_ of + Just err -> + tellP + (PackageDistInexcusable $ SubdirGoodRelPath err) + Nothing -> return () checkMissingVcsInfo :: Monad m => [SourceRepo] -> CheckM m () checkMissingVcsInfo rs = - let rdirs = concatMap repoTypeDirname knownRepoTypes - in checkPkg - (\ops -> do us <- or <$> traverse (doesDirectoryExist ops) rdirs - return (null rs && us)) - (PackageDistSuspicious MissingSourceControl) - where - repoTypeDirname :: KnownRepoType -> [FilePath] - repoTypeDirname Darcs = ["_darcs"] - repoTypeDirname Git = [".git"] - repoTypeDirname SVN = [".svn"] - repoTypeDirname CVS = ["CVS"] - repoTypeDirname Mercurial = [".hg"] - repoTypeDirname GnuArch = [".arch-params"] - repoTypeDirname Bazaar = [".bzr"] - repoTypeDirname Monotone = ["_MTN"] - repoTypeDirname Pijul = [".pijul"] + let rdirs = concatMap repoTypeDirname knownRepoTypes + in checkPkg + ( \ops -> do + us <- or <$> traverse (doesDirectoryExist ops) rdirs + return (null rs && us) + ) + (PackageDistSuspicious MissingSourceControl) + where + repoTypeDirname :: KnownRepoType -> [FilePath] + repoTypeDirname Darcs = ["_darcs"] + repoTypeDirname Git = [".git"] + repoTypeDirname SVN = [".svn"] + repoTypeDirname CVS = ["CVS"] + repoTypeDirname Mercurial = [".hg"] + repoTypeDirname GnuArch = [".arch-params"] + repoTypeDirname Bazaar = [".bzr"] + repoTypeDirname Monotone = ["_MTN"] + repoTypeDirname Pijul = [".pijul"] -- ------------------------------------------------------------ --- * Package and distribution checks +-- Package and distribution checks -- ------------------------------------------------------------ -- | Find a package description file in the given directory. Looks for @@ -552,72 +711,89 @@ checkMissingVcsInfo rs = -- but generalized over monads. findPackageDesc :: Monad m => CheckPackageContentOps m -> m [FilePath] findPackageDesc ops = do - let dir = "." - files <- getDirectoryContents ops dir - -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal - -- file we filter to exclude dirs and null base file names: - cabalFiles <- filterM (doesFileExist ops) - [ dir file - | file <- files - , let (name, ext) = splitExtension file - , not (null name) && ext == ".cabal" ] - return cabalFiles + let dir = "." + files <- getDirectoryContents ops dir + -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal + -- file we filter to exclude dirs and null base file names: + cabalFiles <- + filterM + (doesFileExist ops) + [ dir file + | file <- files + , let (name, ext) = splitExtension file + , not (null name) && ext == ".cabal" + ] + return cabalFiles checkCabalFile :: Monad m => PackageName -> CheckM m () checkCabalFile pn = do - -- liftInt is a bit more messy than stricter interface, but since - -- each of the following check is exclusive, we can simplify the - -- condition flow. - liftInt ciPackageOps (\ops -> do - -- 1. Get .cabal files. - ds <- findPackageDesc ops - case ds of - [] -> return [PackageBuildImpossible NoDesc] - -- No .cabal file. - [d] -> do bc <- bomf ops d - return (catMaybes [bc, noMatch d]) - -- BOM + no matching .cabal checks. - _ -> return [PackageBuildImpossible $ MultiDesc ds]) - -- Multiple .cabal files. - where - bomf :: Monad m => CheckPackageContentOps m -> FilePath -> - m (Maybe PackageCheck) - bomf wops wfp = do - b <- BS.isPrefixOf bomUtf8 <$> getFileContents wops wfp - if b - then (return . Just) (PackageDistInexcusable $ BOMStart wfp) - else return Nothing - - bomUtf8 :: BS.ByteString - bomUtf8 = BS.pack [0xef,0xbb,0xbf] -- U+FEFF encoded as UTF8 - - noMatch :: FilePath -> Maybe PackageCheck - noMatch wd = - let expd = unPackageName pn <.> "cabal" in - if takeFileName wd /= expd - then Just (PackageDistInexcusable $ NotPackageName wd expd) - else Nothing - -checkLicFileExist :: Monad m => SymbolicPath PackageDir LicenseFile -> - CheckM m () + -- liftInt is a bit more messy than stricter interface, but since + -- each of the following check is exclusive, we can simplify the + -- condition flow. + liftInt + ciPackageOps + ( \ops -> do + -- 1. Get .cabal files. + ds <- findPackageDesc ops + case ds of + [] -> return [PackageBuildImpossible NoDesc] + -- No .cabal file. + [d] -> do + bc <- bomf ops d + return (catMaybes [bc, noMatch d]) + -- BOM + no matching .cabal checks. + _ -> return [PackageBuildImpossible $ MultiDesc ds] + ) + where + -- Multiple .cabal files. + + bomf + :: Monad m + => CheckPackageContentOps m + -> FilePath + -> m (Maybe PackageCheck) + bomf wops wfp = do + b <- BS.isPrefixOf bomUtf8 <$> getFileContents wops wfp + if b + then (return . Just) (PackageDistInexcusable $ BOMStart wfp) + else return Nothing + + bomUtf8 :: BS.ByteString + bomUtf8 = BS.pack [0xef, 0xbb, 0xbf] -- U+FEFF encoded as UTF8 + noMatch :: FilePath -> Maybe PackageCheck + noMatch wd = + let expd = unPackageName pn <.> "cabal" + in if takeFileName wd /= expd + then Just (PackageDistInexcusable $ NotPackageName wd expd) + else Nothing + +checkLicFileExist + :: Monad m + => SymbolicPath PackageDir LicenseFile + -> CheckM m () checkLicFileExist sp = do - let fp = getSymbolicPath sp - checkPkg (\ops -> not <$> doesFileExist ops fp) - (PackageBuildWarning $ UnknownFile "license-file" sp) + let fp = getSymbolicPath sp + checkPkg + (\ops -> not <$> doesFileExist ops fp) + (PackageBuildWarning $ UnknownFile "license-file" sp) checkConfigureExists :: Monad m => BuildType -> CheckM m () checkConfigureExists Configure = - checkPkg (\ops -> not <$> doesFileExist ops "configure") - (PackageBuildWarning MissingConfigureScript) + checkPkg + (\ops -> not <$> doesFileExist ops "configure") + (PackageBuildWarning MissingConfigureScript) checkConfigureExists _ = return () checkSetupExists :: Monad m => BuildType -> CheckM m () checkSetupExists Simple = return () checkSetupExists _ = - checkPkg (\ops -> do ba <- doesFileExist ops "Setup.hs" - bb <- doesFileExist ops "Setup.lhs" - return (not $ ba || bb)) - (PackageDistInexcusable MissingSetupFile) + checkPkg + ( \ops -> do + ba <- doesFileExist ops "Setup.hs" + bb <- doesFileExist ops "Setup.lhs" + return (not $ ba || bb) + ) + (PackageDistInexcusable MissingSetupFile) -- The following functions are similar to 'CheckPackageContentOps m' ones, -- but, as they inspect the files included in the package, but are primarily @@ -635,73 +811,76 @@ checkSetupExists _ = -- because that will make us say that Hackage would reject the package. -- But, because Hackage doesn't yet run these tests, that will be a lie! -checkGlobFile :: Monad m => CabalSpecVersion -> - FilePath -> -- Glob pattern. - FilePath -> -- Folder to check. - CabalField -> -- .cabal field we are checking. - CheckM m () +checkGlobFile + :: Monad m + => CabalSpecVersion + -> FilePath -- Glob pattern. + -> FilePath -- Folder to check. + -> CabalField -- .cabal field we are checking. + -> CheckM m () checkGlobFile cv ddir title fp = 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 + 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 -- | Checks for matchless globs and too strict mathching (<2.4 spec). -checkGlobResult :: - CabalField -> -- .cabal field we are checking - FilePath -> -- Glob pattern (to show the user - -- which pattern is the offending - -- one). - [GlobResult FilePath] -> -- List of glob results. - [PackageCheck] +checkGlobResult + :: CabalField -- .cabal field we are checking + -> FilePath -- Glob pattern (to show the user + -- which pattern is the offending + -- one). + -> [GlobResult FilePath] -- List of glob results. + -> [PackageCheck] checkGlobResult title fp rs = dirCheck ++ catMaybes (map getWarning rs) - where - dirCheck | all (not . withoutNoMatchesWarning) rs = - [PackageDistSuspiciousWarn $ GlobNoMatch title fp] - | otherwise = [] - - -- If there's a missing directory in play, since our globs don't - -- (currently) support disjunction, that will always mean there are - -- no matches. The no matches error in this case is strictly less - -- informative than the missing directory error. - withoutNoMatchesWarning (GlobMatch _) = True - withoutNoMatchesWarning (GlobWarnMultiDot _) = False - withoutNoMatchesWarning (GlobMissingDirectory _) = True - - getWarning :: GlobResult FilePath -> Maybe PackageCheck - getWarning (GlobMatch _) = Nothing - -- Before Cabal 2.4, the extensions of globs had to match the file - -- exactly. This has been relaxed in 2.4 to allow matching only the - -- 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) - getWarning (GlobMissingDirectory dir) = - Just $ PackageDistSuspiciousWarn (GlobNoDir title fp dir) - + where + dirCheck + | all (not . withoutNoMatchesWarning) rs = + [PackageDistSuspiciousWarn $ GlobNoMatch title fp] + | otherwise = [] + + -- If there's a missing directory in play, since our globs don't + -- (currently) support disjunction, that will always mean there are + -- no matches. The no matches error in this case is strictly less + -- informative than the missing directory error. + withoutNoMatchesWarning (GlobMatch _) = True + withoutNoMatchesWarning (GlobWarnMultiDot _) = False + withoutNoMatchesWarning (GlobMissingDirectory _) = True + + getWarning :: GlobResult FilePath -> Maybe PackageCheck + getWarning (GlobMatch _) = Nothing + -- Before Cabal 2.4, the extensions of globs had to match the file + -- exactly. This has been relaxed in 2.4 to allow matching only the + -- 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) + getWarning (GlobMissingDirectory dir) = + Just $ PackageDistSuspiciousWarn (GlobNoDir title fp dir) -- ------------------------------------------------------------ --- * Other exports +-- Other exports -- ------------------------------------------------------------ -- | Wraps `ParseWarning` into `PackageCheck`. --- wrapParseWarning :: FilePath -> PWarning -> PackageCheck wrapParseWarning fp pw = PackageDistSuspicious (ParseWarning fp pw) - -- TODO: as Jul 2022 there is no severity indication attached PWarnType. - -- Once that is added, we can output something more appropriate - -- than PackageDistSuspicious for every parse warning. - -- (see: Cabal-syntax/src/Distribution/Parsec/Warning.hs) + +-- TODO: as Jul 2022 there is no severity indication attached PWarnType. +-- Once that is added, we can output something more appropriate +-- than PackageDistSuspicious for every parse warning. +-- (see: Cabal-syntax/src/Distribution/Parsec/Warning.hs) -- ------------------------------------------------------------ --- * Ancillaries +-- Ancillaries -- ------------------------------------------------------------ -- Gets a list of dependencies from a Library target to pass to PVP related @@ -709,15 +888,16 @@ wrapParseWarning fp pw = PackageDistSuspicious (ParseWarning fp pw) -- library itself *will* be checked for PVP errors. -- Same for branch merging, -- each of those branch will be checked one by one. -extractAssocDeps :: UnqualComponentName -> -- Name of the target library - CondTree ConfVar [Dependency] Library -> - AssocDep +extractAssocDeps + :: UnqualComponentName -- Name of the target library + -> CondTree ConfVar [Dependency] Library + -> AssocDep extractAssocDeps n ct = - let a = ignoreConditions ct - -- Merging is fine here, remember the specific - -- library dependencies will be checked branch - -- by branch. - in (n, snd a) + let a = ignoreConditions ct + in -- Merging is fine here, remember the specific + -- library dependencies will be checked branch + -- by branch. + (n, snd a) -- | August 2022: this function is an oddity due to the historical -- GenericPackageDescription/PackageDescription split (check @@ -727,67 +907,82 @@ extractAssocDeps n ct = -- future in favour of `checkPackage` when PD and GPD are refactored sensibly. pd2gpd :: PackageDescription -> GenericPackageDescription pd2gpd pd = gpd - where - gpd :: GenericPackageDescription - gpd = emptyGenericPackageDescription { - packageDescription = pd, - condLibrary = fmap t2c (library pd), - condSubLibraries = map (t2cName ln id) (subLibraries pd), - condForeignLibs = map (t2cName foreignLibName id) - (foreignLibs pd), - condExecutables = map (t2cName exeName id) - (executables pd), - condTestSuites = map (t2cName testName remTest) - (testSuites pd), - condBenchmarks = map (t2cName benchmarkName remBench) - (benchmarks pd) } - - -- From target to simple, unconditional CondTree. - t2c :: a -> CondTree ConfVar [Dependency] a - t2c a = CondNode a [] [] - - -- From named target to unconditional CondTree. Notice we have - -- a function to extract the name *and* a function to modify - -- the target. This is needed for 'initTargetAnnotation' to work - -- properly and to contain all the quirks inside 'pd2gpd'. - t2cName :: (a -> UnqualComponentName) -> (a -> a) -> a -> - (UnqualComponentName, CondTree ConfVar [Dependency] a) - t2cName nf mf a = (nf a, t2c . mf $ a) - - ln :: Library -> UnqualComponentName - ln wl = case libName wl of - (LSubLibName u) -> u - LMainLibName -> mkUnqualComponentName "main-library" - - remTest :: TestSuite -> TestSuite - remTest t = t { testName = mempty } - - remBench :: Benchmark -> Benchmark - remBench b = b { benchmarkName = mempty } + where + gpd :: GenericPackageDescription + gpd = + emptyGenericPackageDescription + { packageDescription = pd + , condLibrary = fmap t2c (library pd) + , condSubLibraries = map (t2cName ln id) (subLibraries pd) + , condForeignLibs = + map + (t2cName foreignLibName id) + (foreignLibs pd) + , condExecutables = + map + (t2cName exeName id) + (executables pd) + , condTestSuites = + map + (t2cName testName remTest) + (testSuites pd) + , condBenchmarks = + map + (t2cName benchmarkName remBench) + (benchmarks pd) + } + + -- From target to simple, unconditional CondTree. + t2c :: a -> CondTree ConfVar [Dependency] a + t2c a = CondNode a [] [] + + -- From named target to unconditional CondTree. Notice we have + -- a function to extract the name *and* a function to modify + -- the target. This is needed for 'initTargetAnnotation' to work + -- properly and to contain all the quirks inside 'pd2gpd'. + t2cName + :: (a -> UnqualComponentName) + -> (a -> a) + -> a + -> (UnqualComponentName, CondTree ConfVar [Dependency] a) + t2cName nf mf a = (nf a, t2c . mf $ a) + + ln :: Library -> UnqualComponentName + ln wl = case libName wl of + (LSubLibName u) -> u + LMainLibName -> mkUnqualComponentName "main-library" + + remTest :: TestSuite -> TestSuite + remTest t = t{testName = mempty} + + remBench :: Benchmark -> Benchmark + remBench b = b{benchmarkName = mempty} -- checkMissingDocs will check that we don’t have an interesting file -- (changes.txt, Changelog.md, NEWS, etc.) in our work-tree which is not -- present in our .cabal file. -checkMissingDocs :: Monad m => - [Glob] -> -- data-files globs. - [Glob] -> -- extra-source-files globs. - [Glob] -> -- extra-doc-files globs. - CheckM m () +checkMissingDocs + :: Monad m + => [Glob] -- data-files globs. + -> [Glob] -- extra-source-files globs. + -> [Glob] -- extra-doc-files globs. + -> CheckM m () checkMissingDocs dgs esgs edgs = do + extraDocSupport <- (>= CabalSpecV1_18) <$> asksCM ccSpecVersion - extraDocSupport <- (>= CabalSpecV1_18) <$> asksCM ccSpecVersion - - -- Everything in this block uses CheckPreDistributionOps interface. - liftInt ciPreDistOps (\ops -> do - + -- Everything in this block uses CheckPreDistributionOps interface. + liftInt + ciPreDistOps + ( \ops -> do -- 1. Get root files, see if they are interesting to us. rootContents <- getDirectoryContentsM ops "." - -- Recall getDirectoryContentsM arg is relative to root path. + -- Recall getDirectoryContentsM arg is relative to root path. let des = filter isDesirableExtraDocFile rootContents -- 2. Realise Globs. - let realGlob t = concatMap globMatches <$> - mapM (runDirFileGlobM ops "") t + let realGlob t = + concatMap globMatches + <$> mapM (runDirFileGlobM ops "") t rgs <- realGlob dgs res <- realGlob esgs red <- realGlob edgs @@ -797,61 +992,76 @@ checkMissingDocs dgs esgs edgs = do -- 4. Check if files are present but in the wrong field. let pcsData = checkDocMove extraDocSupport "data-files" des rgs - pcsSource = if extraDocSupport - then checkDocMove extraDocSupport - "extra-source-files" des res - else [] + pcsSource = + if extraDocSupport + then + checkDocMove + extraDocSupport + "extra-source-files" + des + res + else [] pcs = pcsData ++ pcsSource - return (mcs ++ pcs)) - where - -- From Distribution.Simple.Glob. - globMatches :: [GlobResult a] -> [a] - globMatches input = [a | GlobMatch a <- input] - - checkDoc :: Bool -> -- Cabal spec ≥ 1.18? - [FilePath] -> -- Desirables. - [FilePath] -> -- Actuals. - [PackageCheck] - checkDoc b ds as = - let fds = map ("." ) $ filter (flip notElem as) ds - in if null fds then [] - else [PackageDistSuspiciousWarn $ - MissingExpectedDocFiles b fds] - - checkDocMove :: Bool -> -- Cabal spec ≥ 1.18? - CabalField -> -- Name of the field. - [FilePath] -> -- Desirables. - [FilePath] -> -- Actuals. - [PackageCheck] - checkDocMove b field ds as = - let fds = filter (flip elem as) ds - in if null fds then [] - else [PackageDistSuspiciousWarn $ - WrongFieldForExpectedDocFiles b field fds] + return (mcs ++ pcs) + ) + where + -- From Distribution.Simple.Glob. + globMatches :: [GlobResult a] -> [a] + globMatches input = [a | GlobMatch a <- input] + + checkDoc + :: Bool -- Cabal spec ≥ 1.18? + -> [FilePath] -- Desirables. + -> [FilePath] -- Actuals. + -> [PackageCheck] + checkDoc b ds as = + let fds = map ("." ) $ filter (flip notElem as) ds + in if null fds + then [] + else + [ PackageDistSuspiciousWarn $ + MissingExpectedDocFiles b fds + ] + + checkDocMove + :: Bool -- Cabal spec ≥ 1.18? + -> CabalField -- Name of the field. + -> [FilePath] -- Desirables. + -> [FilePath] -- Actuals. + -> [PackageCheck] + checkDocMove b field ds as = + let fds = filter (flip elem as) ds + in if null fds + then [] + else + [ PackageDistSuspiciousWarn $ + WrongFieldForExpectedDocFiles b field fds + ] -- Predicate for desirable documentation file on Hackage server. isDesirableExtraDocFile :: FilePath -> Bool -isDesirableExtraDocFile path = basename `elem` desirableChangeLog && - ext `elem` desirableChangeLogExtensions +isDesirableExtraDocFile path = + basename `elem` desirableChangeLog + && ext `elem` desirableChangeLogExtensions where - (basename, ext) = splitExtension (map toLower path) - - -- Changelog patterns (basenames & extensions) - -- Source: hackage-server/src/Distribution/Server/Packages/ChangeLog.hs - desirableChangeLog = ["news", "changelog", "change_log", "changes"] - desirableChangeLogExtensions = ["", ".txt", ".md", ".markdown", ".rst"] - -- [TODO] Check readme. Observations: - -- • Readme is not necessary if package description is good. - -- • Some readmes exists only for repository browsing. - -- • There is currently no reliable way to check what a good - -- description is; there will be complains if the criterion - -- is based on the length or number of words (can of worms). - -- -- Readme patterns - -- -- Source: hackage-server/src/Distribution/Server/Packages/Readme.hs - -- desirableReadme = ["readme"] + (basename, ext) = splitExtension (map toLower path) + + -- Changelog patterns (basenames & extensions) + -- Source: hackage-server/src/Distribution/Server/Packages/ChangeLog.hs + desirableChangeLog = ["news", "changelog", "change_log", "changes"] + desirableChangeLogExtensions = ["", ".txt", ".md", ".markdown", ".rst"] + +-- [TODO] Check readme. Observations: +-- • Readme is not necessary if package description is good. +-- • Some readmes exists only for repository browsing. +-- • There is currently no reliable way to check what a good +-- description is; there will be complains if the criterion +-- is based on the length or number of words (can of worms). +-- -- Readme patterns +-- -- Source: hackage-server/src/Distribution/Server/Packages/Readme.hs +-- desirableReadme = ["readme"] -- Remove duplicates from list. dups :: Ord a => [a] -> [a] -dups xs = [ x | (x:_:_) <- group (sort xs) ] - +dups xs = [x | (x : _ : _) <- group (sort xs)] diff --git a/Cabal/src/Distribution/PackageDescription/Check/Common.hs b/Cabal/src/Distribution/PackageDescription/Check/Common.hs index d0f1da83911..4c528831430 100644 --- a/Cabal/src/Distribution/PackageDescription/Check/Common.hs +++ b/Cabal/src/Distribution/PackageDescription/Check/Common.hs @@ -1,4 +1,3 @@ ------------------------------------------------------------------------------ -- | -- Module : Distribution.PackageDescription.Check.Common -- Copyright : Francesco Ariis 2022 @@ -9,17 +8,15 @@ -- -- Common types/functions to various check modules which are *no* part of -- Distribution.PackageDescription.Check.Monad. - -module Distribution.PackageDescription.Check.Common ( - AssocDep, - CabalField, - PathKind(..), - - checkCustomField, - partitionDeps, - checkPVP, - checkPVPs - ) where +module Distribution.PackageDescription.Check.Common + ( AssocDep + , CabalField + , PathKind (..) + , checkCustomField + , partitionDeps + , checkPVP + , checkPVPs + ) where import Distribution.Compat.Prelude import Prelude () @@ -35,9 +32,9 @@ import Control.Monad -- Type of FilePath. data PathKind - = PathKindFile - | PathKindDirectory - | PathKindGlob + = PathKindFile + | PathKindDirectory + | PathKindGlob deriving (Eq) -- | .cabal field we are referring to. As now it is just a synonym to help @@ -47,11 +44,12 @@ type CabalField = String checkCustomField :: Monad m => (String, String) -> CheckM m () checkCustomField (n, _) = - checkP (any (not . isAscii) n) - (PackageDistInexcusable $ NonASCIICustomField [n]) + checkP + (any (not . isAscii) n) + (PackageDistInexcusable $ NonASCIICustomField [n]) -- ------------------------------------------------------------ --- * PVP types/functions +-- PVP types/functions -- ------------------------------------------------------------ -- A library name / dependencies association list. Ultimately to be @@ -66,80 +64,86 @@ type AssocDep = (UnqualComponentName, [Dependency]) -- main library will not need to specify upper bounds on shared dependencies, -- hence we do not return those). -- -partitionDeps :: Monad m => - [AssocDep] -> -- Possibly inherited dependencies, i.e. - -- dependencies from internal/main libs. - [UnqualComponentName] -> -- List of package names ("base", "Cabal"…) - [Dependency] -> -- Dependencies to check. - CheckM m ([Dependency], [Dependency]) +partitionDeps + :: Monad m + => [AssocDep] -- Possibly inherited dependencies, i.e. + -- dependencies from internal/main libs. + -> [UnqualComponentName] -- List of package names ("base", "Cabal"…) + -> [Dependency] -- Dependencies to check. + -> CheckM m ([Dependency], [Dependency]) partitionDeps ads ns ds = do - - -- Shared dependencies from “intra .cabal” libraries. - let -- names of our dependencies - dqs = map unqualName ds - -- shared targets that match - fads = filter (flip elem dqs . fst) ads - -- the names of such targets - inNam = nub $ map fst fads :: [UnqualComponentName] - -- the dependencies of such targets - inDep = concatMap snd fads :: [Dependency] - - -- We exclude from checks: - -- 1. dependencies which are shared with main library / a - -- sublibrary; and of course - -- 2. the names of main library / sub libraries themselves. - -- - -- So in myPackage.cabal - -- library - -- build-depends: text < 5 - -- ⁝ - -- build-depends: myPackage, ← no warning, internal - -- text, ← no warning, inherited - -- monadacme ← warning! - let fFun d = notElem (unqualName d) inNam && - notElem (unqualName d) - (map unqualName inDep) - ds' = filter fFun ds - - return $ partition (flip elem ns . unqualName) ds' - where - -- Return *sublibrary* name if exists (internal), - -- otherwise package name. - unqualName :: Dependency -> UnqualComponentName - unqualName (Dependency n _ nel) = - case head (toNonEmpty nel) of - (LSubLibName ln) -> ln - _ -> packageNameToUnqualComponentName n + -- Shared dependencies from “intra .cabal” libraries. + let + -- names of our dependencies + dqs = map unqualName ds + -- shared targets that match + fads = filter (flip elem dqs . fst) ads + -- the names of such targets + inNam = nub $ map fst fads :: [UnqualComponentName] + -- the dependencies of such targets + inDep = concatMap snd fads :: [Dependency] + + -- We exclude from checks: + -- 1. dependencies which are shared with main library / a + -- sublibrary; and of course + -- 2. the names of main library / sub libraries themselves. + -- + -- So in myPackage.cabal + -- library + -- build-depends: text < 5 + -- ⁝ + -- build-depends: myPackage, ← no warning, internal + -- text, ← no warning, inherited + -- monadacme ← warning! + let fFun d = + notElem (unqualName d) inNam + && notElem + (unqualName d) + (map unqualName inDep) + ds' = filter fFun ds + + return $ partition (flip elem ns . unqualName) ds' + where + -- Return *sublibrary* name if exists (internal), + -- otherwise package name. + unqualName :: Dependency -> UnqualComponentName + unqualName (Dependency n _ nel) = + case head (toNonEmpty nel) of + (LSubLibName ln) -> ln + _ -> packageNameToUnqualComponentName n -- PVP dependency check (one warning message per dependency, usually -- for important dependencies like base). -checkPVP :: Monad m => - (String -> PackageCheck) -> -- Warn message dependend on name - -- (e.g. "base", "Cabal"). - [Dependency] -> - CheckM m () +checkPVP + :: Monad m + => (String -> PackageCheck) -- Warn message dependend on name + -- (e.g. "base", "Cabal"). + -> [Dependency] + -> CheckM m () checkPVP ckf ds = do - let ods = checkPVPPrim ds - mapM_ (tellP . ckf . unPackageName . depPkgName) ods + let ods = checkPVPPrim ds + mapM_ (tellP . ckf . unPackageName . depPkgName) ods -- PVP dependency check for a list of dependencies. Some code duplication -- is sadly needed to provide more ergonimic error messages. -checkPVPs :: Monad m => - ([String] -> - PackageCheck) -> -- Grouped error message, depends on a - -- set of names. - [Dependency] -> -- Deps to analyse. - CheckM m () -checkPVPs cf ds | null ns = return () - | otherwise = tellP (cf ns) - where - ods = checkPVPPrim ds - ns = map (unPackageName . depPkgName) ods +checkPVPs + :: Monad m + => ( [String] + -> PackageCheck -- Grouped error message, depends on a + -- set of names. + ) + -> [Dependency] -- Deps to analyse. + -> CheckM m () +checkPVPs cf ds + | null ns = return () + | otherwise = tellP (cf ns) + where + ods = checkPVPPrim ds + ns = map (unPackageName . depPkgName) ods -- Returns dependencies without upper bounds. checkPVPPrim :: [Dependency] -> [Dependency] checkPVPPrim ds = filter withoutUpper ds - where - withoutUpper :: Dependency -> Bool - withoutUpper (Dependency _ ver _) = not . hasUpperBound $ ver - + where + withoutUpper :: Dependency -> Bool + withoutUpper (Dependency _ ver _) = not . hasUpperBound $ ver diff --git a/Cabal/src/Distribution/PackageDescription/Check/Conditional.hs b/Cabal/src/Distribution/PackageDescription/Check/Conditional.hs index a18cf9eaab3..49356575f7f 100644 --- a/Cabal/src/Distribution/PackageDescription/Check/Conditional.hs +++ b/Cabal/src/Distribution/PackageDescription/Check/Conditional.hs @@ -1,6 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------ -- | -- Module : Distribution.PackageDescription.Check.Conditional -- Copyright : Lennart Kolmodin 2008, Francesco Ariis 2023 @@ -12,11 +11,10 @@ -- Checks on conditional targes (libraries, executables, etc. that are -- still inside a CondTree and related checks that can only be performed -- here (variables, duplicated modules). - -module Distribution.PackageDescription.Check.Conditional ( - checkCondTarget, - checkDuplicateModules - ) where +module Distribution.PackageDescription.Check.Conditional + ( checkCondTarget + , checkDuplicateModules + ) where import Distribution.Compat.Prelude import Prelude () @@ -28,11 +26,10 @@ import Distribution.PackageDescription import Distribution.PackageDescription.Check.Monad import Distribution.System -import qualified Data.Map as Map +import qualified Data.Map as Map import Control.Monad - -- As a prerequisite to some checks, we transform a target CondTree into -- a CondTree of “target + useful context”. -- This is slightly clearer, is easier to walk without resorting to @@ -41,130 +38,144 @@ import Control.Monad -- | @nf@ function is needed to appropriately name some targets which need -- to be spoonfed (otherwise name appears as ""). --- -initTargetAnnotation :: Monoid a => - (UnqualComponentName -> a -> a) -> -- Naming function for targets. - UnqualComponentName -> - TargetAnnotation a +initTargetAnnotation + :: Monoid a + => (UnqualComponentName -> a -> a) -- Naming function for targets. + -> UnqualComponentName + -> TargetAnnotation a initTargetAnnotation nf n = TargetAnnotation (nf n mempty) False -- | We “build up” target from various slices. --- -updateTargetAnnotation :: Monoid a => - a -> -- A target (lib, exe, test, …) - TargetAnnotation a -> - TargetAnnotation a -updateTargetAnnotation t ta = ta { taTarget = taTarget ta <> t } +updateTargetAnnotation + :: Monoid a + => a -- A target (lib, exe, test, …) + -> TargetAnnotation a + -> TargetAnnotation a +updateTargetAnnotation t ta = ta{taTarget = taTarget ta <> t} -- | Before walking a target 'CondTree', we need to annotate it with -- information relevant to the checks (read 'TaraAnn' and 'checkCondTarget' -- doc for more info). --- -annotateCondTree :: forall a. Monoid a => - [PackageFlag] -> -- User flags. - TargetAnnotation a -> - CondTree ConfVar [Dependency] a -> - CondTree ConfVar [Dependency] (TargetAnnotation a) +annotateCondTree + :: forall a + . Monoid a + => [PackageFlag] -- User flags. + -> TargetAnnotation a + -> CondTree ConfVar [Dependency] a + -> CondTree ConfVar [Dependency] (TargetAnnotation a) annotateCondTree fs ta (CondNode a c bs) = - let ta' = updateTargetAnnotation a ta - bs' = map (annotateBranch ta') bs - in CondNode ta' c bs' - where - annotateBranch :: TargetAnnotation a -> - CondBranch ConfVar [Dependency] a -> - CondBranch ConfVar [Dependency] - (TargetAnnotation a) - annotateBranch wta (CondBranch k t mf) = - let uf = isPkgFlagCond k - wta' = wta { taPackageFlag = taPackageFlag wta || uf } - atf = annotateCondTree fs - in CondBranch k (atf wta' t) - (atf wta <$> mf) - -- Note how we are passing the *old* wta - -- in the `else` branch, since we are not - -- under that flag. - - -- We only want to pick up variables that are flags and that are - -- *off* by default. - isPkgFlagCond :: Condition ConfVar -> Bool - isPkgFlagCond (Lit _) = False - isPkgFlagCond (Var (PackageFlag f)) = elem f defOffFlags - isPkgFlagCond (Var _) = False - isPkgFlagCond (CNot cn) = not (isPkgFlagCond cn) - isPkgFlagCond (CAnd ca cb) = isPkgFlagCond ca || isPkgFlagCond cb - isPkgFlagCond (COr ca cb) = isPkgFlagCond ca && isPkgFlagCond cb - - -- Package flags that are off by default *and* that are manual. - defOffFlags = map flagName $ - filter (\f -> not (flagDefault f) && - flagManual f) fs + let ta' = updateTargetAnnotation a ta + bs' = map (annotateBranch ta') bs + in CondNode ta' c bs' + where + annotateBranch + :: TargetAnnotation a + -> CondBranch ConfVar [Dependency] a + -> CondBranch + ConfVar + [Dependency] + (TargetAnnotation a) + annotateBranch wta (CondBranch k t mf) = + let uf = isPkgFlagCond k + wta' = wta{taPackageFlag = taPackageFlag wta || uf} + atf = annotateCondTree fs + in CondBranch + k + (atf wta' t) + (atf wta <$> mf) + -- Note how we are passing the *old* wta + -- in the `else` branch, since we are not + -- under that flag. + + -- We only want to pick up variables that are flags and that are + -- \*off* by default. + isPkgFlagCond :: Condition ConfVar -> Bool + isPkgFlagCond (Lit _) = False + isPkgFlagCond (Var (PackageFlag f)) = elem f defOffFlags + isPkgFlagCond (Var _) = False + isPkgFlagCond (CNot cn) = not (isPkgFlagCond cn) + isPkgFlagCond (CAnd ca cb) = isPkgFlagCond ca || isPkgFlagCond cb + isPkgFlagCond (COr ca cb) = isPkgFlagCond ca && isPkgFlagCond cb + + -- Package flags that are off by default *and* that are manual. + defOffFlags = + map flagName $ + filter + ( \f -> + not (flagDefault f) + && flagManual f + ) + fs -- | A conditional target is a library, exe, benchmark etc., destructured -- in a CondTree. Traversing method: we render the branches, pass a -- relevant context, collect checks. --- -checkCondTarget :: forall m a. (Monad m, Monoid a) => - [PackageFlag] -> -- User flags. - (a -> CheckM m ()) -> -- Check function (a = target). - (UnqualComponentName -> a -> a) -> - -- Naming function (some targets - -- need to have their name - -- spoonfed to them. - (UnqualComponentName, CondTree ConfVar [Dependency] a) -> - -- Target name/condtree. - CheckM m () +checkCondTarget + :: forall m a + . (Monad m, Monoid a) + => [PackageFlag] -- User flags. + -> (a -> CheckM m ()) -- Check function (a = target). + -> (UnqualComponentName -> a -> a) + -- Naming function (some targets + -- need to have their name + -- spoonfed to them. + -> (UnqualComponentName, CondTree ConfVar [Dependency] a) + -- Target name/condtree. + -> CheckM m () checkCondTarget fs cf nf (unqualName, ct) = - wTree $ annotateCondTree fs (initTargetAnnotation nf unqualName) ct - where - -- Walking the tree. Remember that CondTree is not a binary - -- tree but a /rose/tree. - wTree :: CondTree ConfVar [Dependency] (TargetAnnotation a) -> - CheckM m () - wTree (CondNode ta _ bs) - -- There are no branches (and [] == True) *or* every branch - -- is “simple” (i.e. missing a 'condBranchIfFalse' part). - -- This is convenient but not necessarily correct in all - -- cases; a more precise way would be to check incompatibility - -- among simple branches conditions (or introduce a principled - -- `cond` construct in `.cabal` files. - | all isSimple bs = do - localCM (initCheckCtx ta) (cf $ taTarget ta) - mapM_ wBranch bs - -- If there are T/F conditions, there is no need to check - -- the intermediate 'TargetAnnotation' too. - | otherwise = do - mapM_ wBranch bs - - isSimple :: CondBranch ConfVar [Dependency] (TargetAnnotation a)-> - Bool - isSimple (CondBranch _ _ Nothing) = True - isSimple (CondBranch _ _ (Just _)) = False - - wBranch :: CondBranch ConfVar [Dependency] (TargetAnnotation a) -> - CheckM m () - wBranch (CondBranch k t mf) = do - checkCondVars k - wTree t - maybe (return ()) wTree mf + wTree $ annotateCondTree fs (initTargetAnnotation nf unqualName) ct + where + -- Walking the tree. Remember that CondTree is not a binary + -- tree but a /rose/tree. + wTree + :: CondTree ConfVar [Dependency] (TargetAnnotation a) + -> CheckM m () + wTree (CondNode ta _ bs) + -- There are no branches (and [] == True) *or* every branch + -- is “simple” (i.e. missing a 'condBranchIfFalse' part). + -- This is convenient but not necessarily correct in all + -- cases; a more precise way would be to check incompatibility + -- among simple branches conditions (or introduce a principled + -- `cond` construct in `.cabal` files. + | all isSimple bs = do + localCM (initCheckCtx ta) (cf $ taTarget ta) + mapM_ wBranch bs + -- If there are T/F conditions, there is no need to check + -- the intermediate 'TargetAnnotation' too. + | otherwise = do + mapM_ wBranch bs + + isSimple + :: CondBranch ConfVar [Dependency] (TargetAnnotation a) + -> Bool + isSimple (CondBranch _ _ Nothing) = True + isSimple (CondBranch _ _ (Just _)) = False + + wBranch + :: CondBranch ConfVar [Dependency] (TargetAnnotation a) + -> CheckM m () + wBranch (CondBranch k t mf) = do + checkCondVars k + wTree t + maybe (return ()) wTree mf -- | Condvar checking (misspelled OS in if conditions, etc). --- checkCondVars :: Monad m => Condition ConfVar -> CheckM m () checkCondVars cond = - let (_, vs) = simplifyCondition cond (\v -> Left v) - -- Using simplifyCondition is convenient and correct, - -- if checks become more complex we can always walk - -- 'Condition'. - in mapM_ vcheck vs - where - vcheck :: Monad m => ConfVar -> CheckM m () - vcheck (OS (OtherOS os)) = - tellP (PackageDistInexcusable $ UnknownOS [os]) - vcheck (Arch (OtherArch arch)) = - tellP (PackageDistInexcusable $ UnknownArch [arch]) - vcheck (Impl (OtherCompiler os) _) = - tellP (PackageDistInexcusable $ UnknownCompiler [os]) - vcheck _ = return () + let (_, vs) = simplifyCondition cond (\v -> Left v) + in -- Using simplifyCondition is convenient and correct, + -- if checks become more complex we can always walk + -- 'Condition'. + mapM_ vcheck vs + where + vcheck :: Monad m => ConfVar -> CheckM m () + vcheck (OS (OtherOS os)) = + tellP (PackageDistInexcusable $ UnknownOS [os]) + vcheck (Arch (OtherArch arch)) = + tellP (PackageDistInexcusable $ UnknownArch [arch]) + vcheck (Impl (OtherCompiler os) _) = + tellP (PackageDistInexcusable $ UnknownCompiler [os]) + vcheck _ = return () -- Checking duplicated modules cannot unfortunately be done in the -- “tree checking”. This is because of the monoidal instance in some targets, @@ -172,33 +183,39 @@ checkCondVars cond = -- this particular check. checkDuplicateModules :: GenericPackageDescription -> [PackageCheck] checkDuplicateModules pkg = - concatMap checkLib (maybe id (:) (condLibrary pkg) . map snd $ condSubLibraries pkg) - ++ concatMap checkExe (map snd $ condExecutables pkg) - ++ concatMap checkTest (map snd $ condTestSuites pkg) - ++ concatMap checkBench (map snd $ condBenchmarks pkg) + concatMap checkLib (maybe id (:) (condLibrary pkg) . map snd $ condSubLibraries pkg) + ++ concatMap checkExe (map snd $ condExecutables pkg) + ++ concatMap checkTest (map snd $ condTestSuites pkg) + ++ concatMap checkBench (map snd $ condBenchmarks pkg) where -- the duplicate modules check is has not been thoroughly vetted for backpack - checkLib = checkDups "library" (\l -> explicitLibModules l ++ map moduleReexportName (reexportedModules l)) - checkExe = checkDups "executable" exeModules - checkTest = checkDups "test suite" testModules - checkBench = checkDups "benchmark" benchmarkModules + checkLib = checkDups "library" (\l -> explicitLibModules l ++ map moduleReexportName (reexportedModules l)) + checkExe = checkDups "executable" exeModules + checkTest = checkDups "test suite" testModules + checkBench = checkDups "benchmark" benchmarkModules checkDups :: String -> (a -> [ModuleName]) -> CondTree v c a -> [PackageCheck] checkDups s getModules t = - let sumPair (x,x') (y,y') = (x + x' :: Int, y + y' :: Int) - mergePair (x, x') (y, y') = (x + x', max y y') - maxPair (x, x') (y, y') = (max x x', max y y') - libMap = foldCondTree Map.empty - (\(_,v) -> Map.fromListWith sumPair . map (\x -> (x,(1, 1))) $ getModules v ) - (Map.unionWith mergePair) -- if a module may occur in nonexclusive branches count it twice strictly and once loosely. - (Map.unionWith maxPair) -- a module occurs the max of times it might appear in exclusive branches - t - dupLibsStrict = Map.keys $ Map.filter ((>1) . fst) libMap - dupLibsLax = Map.keys $ Map.filter ((>1) . snd) libMap - in if not (null dupLibsLax) - then [PackageBuildImpossible - (DuplicateModule s dupLibsLax)] - else if not (null dupLibsStrict) - then [PackageDistSuspicious - (PotentialDupModule s dupLibsStrict)] - else [] - + let sumPair (x, x') (y, y') = (x + x' :: Int, y + y' :: Int) + mergePair (x, x') (y, y') = (x + x', max y y') + maxPair (x, x') (y, y') = (max x x', max y y') + libMap = + foldCondTree + Map.empty + (\(_, v) -> Map.fromListWith sumPair . map (\x -> (x, (1, 1))) $ getModules v) + (Map.unionWith mergePair) -- if a module may occur in nonexclusive branches count it twice strictly and once loosely. + (Map.unionWith maxPair) -- a module occurs the max of times it might appear in exclusive branches + t + dupLibsStrict = Map.keys $ Map.filter ((> 1) . fst) libMap + dupLibsLax = Map.keys $ Map.filter ((> 1) . snd) libMap + in if not (null dupLibsLax) + then + [ PackageBuildImpossible + (DuplicateModule s dupLibsLax) + ] + else + if not (null dupLibsStrict) + then + [ PackageDistSuspicious + (PotentialDupModule s dupLibsStrict) + ] + else [] diff --git a/Cabal/src/Distribution/PackageDescription/Check/Monad.hs b/Cabal/src/Distribution/PackageDescription/Check/Monad.hs index d6127d10dbd..9e375e8d9b8 100644 --- a/Cabal/src/Distribution/PackageDescription/Check/Monad.hs +++ b/Cabal/src/Distribution/PackageDescription/Check/Monad.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------ -- | -- Module : Distribution.PackageDescription.Check.Monad -- Copyright : Francesco Ariis 2022 @@ -13,37 +12,35 @@ -- Primitives for package checking: check types and monadic interface. -- Having these primitives in a different module allows us to appropriately -- limit/manage the interface to suit checking needs. - module Distribution.PackageDescription.Check.Monad - ( -- * Types and constructors - CheckM(..), - execCheckM, - CheckInterface(..), - CheckPackageContentOps(..), - CheckPreDistributionOps(..), - TargetAnnotation(..), - PackageCheck(..), - CheckExplanation(..), - CEField(..), - CEType(..), - WarnLang(..), - CheckCtx(..), - pristineCheckCtx, - initCheckCtx, - PNames(..), - - -- * Operations - ppPackageCheck, - isHackageDistError, - asksCM, - localCM, - checkP, - checkPkg, - liftInt, - tellP, - checkSpecVer - - ) where + ( -- * Types and constructors + CheckM (..) + , execCheckM + , CheckInterface (..) + , CheckPackageContentOps (..) + , CheckPreDistributionOps (..) + , TargetAnnotation (..) + , PackageCheck (..) + , CheckExplanation (..) + , CEField (..) + , CEType (..) + , WarnLang (..) + , CheckCtx (..) + , pristineCheckCtx + , initCheckCtx + , PNames (..) + + -- * Operations + , ppPackageCheck + , isHackageDistError + , asksCM + , localCM + , checkP + , checkPkg + , liftInt + , tellP + , checkSpecVer + ) where import Distribution.Compat.Prelude import Prelude () @@ -56,159 +53,166 @@ import Distribution.Simple.Glob (Glob, GlobResult) import Distribution.Types.ExeDependency (ExeDependency) import Distribution.Types.GenericPackageDescription import Distribution.Types.LegacyExeDependency (LegacyExeDependency) -import Distribution.Types.PackageId (PackageIdentifier) import Distribution.Types.PackageDescription (package, specVersion) +import Distribution.Types.PackageId (PackageIdentifier) import Distribution.Types.UnqualComponentName import qualified Control.Monad.Reader as Reader -import qualified Control.Monad.Writer as Writer import qualified Control.Monad.Trans.Class as Trans +import qualified Control.Monad.Writer as Writer import qualified Data.ByteString.Lazy as BS import qualified Data.Set as Set import Control.Monad - -- Monadic interface for for Distribution.PackageDescription.Check. -- -- Monadic checking allows us to have a fine grained control on checks -- (e.g. omitting warning checks in certain situations). -- * Interfaces + -- -- | Which interface to we have available/should we use? (to perform: pure -- checks, package checks, pre-distribution checks.) -data CheckInterface m = - CheckInterface { ciPureChecks :: Bool, - -- Perform pure checks? - ciPackageOps :: Maybe (CheckPackageContentOps m), - -- If you want to perform package contents - -- checks, provide an interface. - ciPreDistOps :: Maybe (CheckPreDistributionOps m) - -- If you want to work-tree checks, provide - -- an interface. - } +data CheckInterface m = CheckInterface + { ciPureChecks :: Bool + , -- Perform pure checks? + ciPackageOps :: Maybe (CheckPackageContentOps m) + , -- If you want to perform package contents + -- checks, provide an interface. + ciPreDistOps :: Maybe (CheckPreDistributionOps m) + -- If you want to work-tree checks, provide + -- an interface. + } -- | A record of operations needed to check the contents of packages. -- Abstracted over `m` to provide flexibility (could be IO, a .tar.gz -- file, etc). --- -data CheckPackageContentOps m = CheckPackageContentOps { - doesFileExist :: FilePath -> m Bool, - doesDirectoryExist :: FilePath -> m Bool, - getDirectoryContents :: FilePath -> m [FilePath], - getFileContents :: FilePath -> m BS.ByteString +data CheckPackageContentOps m = CheckPackageContentOps + { doesFileExist :: FilePath -> m Bool + , doesDirectoryExist :: FilePath -> m Bool + , getDirectoryContents :: FilePath -> m [FilePath] + , getFileContents :: FilePath -> m BS.ByteString } -- | A record of operations needed to check contents *of the work tree* -- (compare it with 'CheckPackageContentOps'). This is still `m` abstracted -- in case in the future we can obtain the same infos other than from IO -- (e.g. a VCS work tree). --- -data CheckPreDistributionOps m = CheckPreDistributionOps { - runDirFileGlobM :: FilePath -> Glob -> m [GlobResult FilePath], - getDirectoryContentsM :: FilePath -> m [FilePath] - } +data CheckPreDistributionOps m = CheckPreDistributionOps + { runDirFileGlobM :: FilePath -> Glob -> m [GlobResult FilePath] + , getDirectoryContentsM :: FilePath -> m [FilePath] + } -- | Context to perform checks (will be the Reader part in your monad). --- -data CheckCtx m = CheckCtx { - ccInterface :: CheckInterface m, - -- Interface for checks. - - -- Contextual infos for checks. - ccFlag :: Bool, - -- Are we under a user flag? - - -- Convenience bits that we prefer to carry - -- in our Reader monad instead of passing it - -- via ->, as they are often useful and often - -- in deeply nested places in the GPD tree. - ccSpecVersion :: CabalSpecVersion, - -- Cabal version. - ccDesugar :: LegacyExeDependency -> Maybe ExeDependency, - -- A desugaring function from - -- Distribution.Simple.BuildToolDepends - -- (desugarBuildToolSimple). Again since it - -- eats PackageName and a list of executable - -- names, it is more convenient to pass it - -- via Reader. - ccNames :: PNames - -- Various names (id, libs, execs, tests, - -- benchs), convenience. - } +data CheckCtx m = CheckCtx + { ccInterface :: CheckInterface m + , -- Interface for checks. + + -- Contextual infos for checks. + ccFlag :: Bool + , -- Are we under a user flag? + + -- Convenience bits that we prefer to carry + -- in our Reader monad instead of passing it + -- via ->, as they are often useful and often + -- in deeply nested places in the GPD tree. + ccSpecVersion :: CabalSpecVersion + , -- Cabal version. + ccDesugar :: LegacyExeDependency -> Maybe ExeDependency + , -- A desugaring function from + -- Distribution.Simple.BuildToolDepends + -- (desugarBuildToolSimple). Again since it + -- eats PackageName and a list of executable + -- names, it is more convenient to pass it + -- via Reader. + ccNames :: PNames + -- Various names (id, libs, execs, tests, + -- benchs), convenience. + } -- | Creates a pristing 'CheckCtx'. With pristine we mean everything that -- can be deduced by GPD but *not* user flags information. -pristineCheckCtx :: Monad m => CheckInterface m -> GenericPackageDescription -> - CheckCtx m +pristineCheckCtx + :: Monad m + => CheckInterface m + -> GenericPackageDescription + -> CheckCtx m pristineCheckCtx ci gpd = - let ens = map fst (condExecutables gpd) - in CheckCtx ci - False - (specVersion . packageDescription $ gpd) - (desugarBuildToolSimple (packageName gpd) ens) - (initPNames gpd) + let ens = map fst (condExecutables gpd) + in CheckCtx + ci + False + (specVersion . packageDescription $ gpd) + (desugarBuildToolSimple (packageName gpd) ens) + (initPNames gpd) -- | Adds useful bits to 'CheckCtx' (as now, whether we are operating under -- a user off-by-default flag). initCheckCtx :: Monad m => TargetAnnotation a -> CheckCtx m -> CheckCtx m -initCheckCtx t c = c {ccFlag = taPackageFlag t} +initCheckCtx t c = c{ccFlag = taPackageFlag t} -- | 'TargetAnnotation' collects contextual information on the target we are -- realising: a buildup of the various slices of the target (a library, -- executable, etc. — is a monoid) whether we are under an off-by-default -- package flag. --- -data TargetAnnotation a = TargetAnnotation { - taTarget :: a, - -- The target we are building (lib, exe, etc.) - taPackageFlag :: Bool - -- Whether we are under an off-by-default package flag. - } +data TargetAnnotation a = TargetAnnotation + { taTarget :: a + , -- The target we are building (lib, exe, etc.) + taPackageFlag :: Bool + -- Whether we are under an off-by-default package flag. + } deriving (Show, Eq, Ord) -- | A collection os names, shipping tuples around is annoying. --- -data PNames = PNames { - pnPackageId :: PackageIdentifier, -- Package ID… - -- … and a bunch of lib, exe, test, bench names. - pnSubLibs :: [UnqualComponentName], - pnExecs :: [UnqualComponentName], - pnTests :: [UnqualComponentName], - pnBenchs :: [UnqualComponentName] - } +data PNames = PNames + { pnPackageId :: PackageIdentifier -- Package ID… + -- … and a bunch of lib, exe, test, bench names. + , pnSubLibs :: [UnqualComponentName] + , pnExecs :: [UnqualComponentName] + , pnTests :: [UnqualComponentName] + , pnBenchs :: [UnqualComponentName] + } -- | Init names from a GPD. initPNames :: GenericPackageDescription -> PNames -initPNames gpd = PNames (package . packageDescription $ gpd) - (map fst $ condSubLibraries gpd) - (map fst $ condExecutables gpd) - (map fst $ condTestSuites gpd) - (map fst $ condBenchmarks gpd) +initPNames gpd = + PNames + (package . packageDescription $ gpd) + (map fst $ condSubLibraries gpd) + (map fst $ condExecutables gpd) + (map fst $ condTestSuites gpd) + (map fst $ condBenchmarks gpd) -- | Check monad, carrying a context, collecting 'PackageCheck's. -- Using Set for writer (automatic sort) is useful for output stability -- on different platforms. -- It is nothing more than a monad stack with Reader+Writer. -- `m` is the monad that could be used to do package/file checks. --- -newtype CheckM m a = CheckM (Reader.ReaderT (CheckCtx m) - (Writer.WriterT (Set.Set PackageCheck) - m) - a) - deriving (Functor, Applicative, Monad) - -- Not autoderiving MonadReader and MonadWriter gives us better - -- control on the interface of CheckM. +newtype CheckM m a + = CheckM + ( Reader.ReaderT + (CheckCtx m) + ( Writer.WriterT + (Set.Set PackageCheck) + m + ) + a + ) + deriving (Functor, Applicative, Monad) + +-- Not autoderiving MonadReader and MonadWriter gives us better +-- control on the interface of CheckM. -- | Execute a CheckM monad, leaving `m [PackageCheck]` which can be -- run in the appropriate `m` environment (IO, pure, …). execCheckM :: Monad m => CheckM m () -> CheckCtx m -> m [PackageCheck] execCheckM (CheckM rwm) ctx = - let wm = Reader.runReaderT rwm ctx - m = Writer.execWriterT wm - in Set.toList <$> m + let wm = Reader.runReaderT rwm ctx + m = Writer.execWriterT wm + in Set.toList <$> m -- | As 'checkP' but always succeeding. tellP :: Monad m => PackageCheck -> CheckM m () @@ -217,116 +221,134 @@ tellP = checkP True -- | Add a package warning withoutu performing any check. tellCM :: Monad m => PackageCheck -> CheckM m () tellCM ck = do - cf <- asksCM ccFlag - unless (cf && canSkip ck) - -- Do not push this message if the warning is not severe *and* - -- we are under a non-default package flag. - (CheckM . Writer.tell $ Set.singleton ck) - where - -- Check if we can skip this error if we are under a - -- non-default user flag. - canSkip :: PackageCheck -> Bool - canSkip wck = not (isSevereLocal wck) || isErrAllowable wck - - isSevereLocal :: PackageCheck -> Bool - isSevereLocal (PackageBuildImpossible _) = True - isSevereLocal (PackageBuildWarning _) = True - isSevereLocal (PackageDistSuspicious _) = False - isSevereLocal (PackageDistSuspiciousWarn _) = False - isSevereLocal (PackageDistInexcusable _) = True - - -- There are some errors which, even though severe, will - -- be allowed by Hackage *if* under a non-default flag. - isErrAllowable :: PackageCheck -> Bool - isErrAllowable c = case extractCheckExplantion c of - (WErrorUnneeded _) -> True - (JUnneeded _) -> True - (FDeferTypeErrorsUnneeded _) -> True - (DynamicUnneeded _) -> True - (ProfilingUnneeded _) -> True - _ -> False + cf <- asksCM ccFlag + unless + (cf && canSkip ck) + -- Do not push this message if the warning is not severe *and* + -- we are under a non-default package flag. + (CheckM . Writer.tell $ Set.singleton ck) + where + -- Check if we can skip this error if we are under a + -- non-default user flag. + canSkip :: PackageCheck -> Bool + canSkip wck = not (isSevereLocal wck) || isErrAllowable wck + + isSevereLocal :: PackageCheck -> Bool + isSevereLocal (PackageBuildImpossible _) = True + isSevereLocal (PackageBuildWarning _) = True + isSevereLocal (PackageDistSuspicious _) = False + isSevereLocal (PackageDistSuspiciousWarn _) = False + isSevereLocal (PackageDistInexcusable _) = True + + -- There are some errors which, even though severe, will + -- be allowed by Hackage *if* under a non-default flag. + isErrAllowable :: PackageCheck -> Bool + isErrAllowable c = case extractCheckExplantion c of + (WErrorUnneeded _) -> True + (JUnneeded _) -> True + (FDeferTypeErrorsUnneeded _) -> True + (DynamicUnneeded _) -> True + (ProfilingUnneeded _) -> True + _ -> False -- | Lift a monadic computation to CM. liftCM :: Monad m => m a -> CheckM m a liftCM ma = CheckM . Trans.lift . Trans.lift $ ma -- | Lift a monadic action via an interface. Missing interface, no action. --- -liftInt :: forall m i. Monad m => - (CheckInterface m -> Maybe (i m)) -> - -- Check interface, may or may not exist. If it does not, - -- the check simply will not be performed. - (i m -> m [PackageCheck]) -> - -- The actual check to perform with the above-mentioned - -- interface. Note the [] around `PackageCheck`, this is - -- meant to perform/collect multiple checks. - CheckM m () -liftInt acc f = do ops <- asksCM (acc . ccInterface) - maybe (return ()) l ops - where - l :: i m -> CheckM m () - l wi = do cks <- liftCM (f wi) - mapM_ (check True) cks +liftInt + :: forall m i + . Monad m + => (CheckInterface m -> Maybe (i m)) + -- Check interface, may or may not exist. If it does not, + -- the check simply will not be performed. + -> (i m -> m [PackageCheck]) + -- The actual check to perform with the above-mentioned + -- interface. Note the [] around `PackageCheck`, this is + -- meant to perform/collect multiple checks. + -> CheckM m () +liftInt acc f = do + ops <- asksCM (acc . ccInterface) + maybe (return ()) l ops + where + l :: i m -> CheckM m () + l wi = do + cks <- liftCM (f wi) + mapM_ (check True) cks -- | Most basic check function. You do not want to export this, rather export -- “smart” functions (checkP, checkPkg) to enforce relevant properties. --- -check :: Monad m => Bool -> -- Is there something to warn about? - PackageCheck -> -- Warn message. - CheckM m () +check + :: Monad m + => Bool -- Is there something to warn about? + -> PackageCheck -- Warn message. + -> CheckM m () check True ck = tellCM ck check False _ = return () -- | Pure check not requiring IO or other interfaces. --- -checkP :: Monad m => Bool -> -- Is there something to warn about? - PackageCheck -> -- Warn message. - CheckM m () -checkP b ck = do pb <- asksCM (ciPureChecks . ccInterface) - when pb (check b ck) +checkP + :: Monad m + => Bool -- Is there something to warn about? + -> PackageCheck -- Warn message. + -> CheckM m () +checkP b ck = do + pb <- asksCM (ciPureChecks . ccInterface) + when pb (check b ck) -- Check with 'CheckPackageContentOps' operations (i.e. package file checks). -- -checkPkg :: forall m. Monad m => - (CheckPackageContentOps m -> m Bool) -> - -- Actual check to perform with CPC interface - PackageCheck -> - -- Warn message. - CheckM m () +checkPkg + :: forall m + . Monad m + => (CheckPackageContentOps m -> m Bool) + -- Actual check to perform with CPC interface + -> PackageCheck + -- Warn message. + -> CheckM m () checkPkg f ck = checkInt ciPackageOps f ck -- | Generalised version for checks that need an interface. We pass a Reader -- accessor to such interface ‘i’, a check function. --- -checkIntDep :: forall m i. Monad m => - (CheckInterface m -> Maybe (i m)) -> - -- Check interface, may or may not exist. If it does not, - -- the check simply will not be performed. - (i m -> m (Maybe PackageCheck)) -> - -- The actual check to perform (single check). - CheckM m () -checkIntDep acc mck = do po <- asksCM (acc . ccInterface) - maybe (return ()) (lc . mck) po - where - lc :: Monad m => m (Maybe PackageCheck) -> CheckM m () - lc wmck = do b <- liftCM wmck - maybe (return ()) (check True) b +checkIntDep + :: forall m i + . Monad m + => (CheckInterface m -> Maybe (i m)) + -- Check interface, may or may not exist. If it does not, + -- the check simply will not be performed. + -> (i m -> m (Maybe PackageCheck)) + -- The actual check to perform (single check). + -> CheckM m () +checkIntDep acc mck = do + po <- asksCM (acc . ccInterface) + maybe (return ()) (lc . mck) po + where + lc :: Monad m => m (Maybe PackageCheck) -> CheckM m () + lc wmck = do + b <- liftCM wmck + maybe (return ()) (check True) b -- | As 'checkIntDep', but 'PackageCheck' does not depend on the monadic -- computation. --- -checkInt :: forall m i. Monad m => - (CheckInterface m -> Maybe (i m)) -> - -- Where to get the interface (if available). - (i m -> m Bool) -> - -- Condition to check - PackageCheck -> - -- Warning message to add (does not depend on `m`). - CheckM m () -checkInt acc f ck = checkIntDep acc (\ops -> do b <- f ops - if b - then return $ Just ck - else return Nothing) +checkInt + :: forall m i + . Monad m + => (CheckInterface m -> Maybe (i m)) + -- Where to get the interface (if available). + -> (i m -> m Bool) + -- Condition to check + -> PackageCheck + -- Warning message to add (does not depend on `m`). + -> CheckM m () +checkInt acc f ck = + checkIntDep + acc + ( \ops -> do + b <- f ops + if b + then return $ Just ck + else return Nothing + ) -- | `local` (from Control.Monad.Reader) for CheckM. localCM :: Monad m => (CheckCtx m -> CheckCtx m) -> CheckM m () -> CheckM m () @@ -338,13 +360,13 @@ asksCM f = CheckM $ Reader.asks f -- As checkP, but with an additional condition: the check will be performed -- only if our spec version is < `vc`. -checkSpecVer :: Monad m => - CabalSpecVersion -> -- Perform this check only if our - -- spec version is < than this. - Bool -> -- Check condition. - PackageCheck -> -- Check message. - CheckM m () +checkSpecVer + :: Monad m + => CabalSpecVersion -- Perform this check only if our + -- spec version is < than this. + -> Bool -- Check condition. + -> PackageCheck -- Check message. + -> CheckM m () checkSpecVer vc cond c = do - vp <- asksCM ccSpecVersion - unless (vp >= vc) (checkP cond c) - + vp <- asksCM ccSpecVersion + unless (vp >= vc) (checkP cond c) diff --git a/Cabal/src/Distribution/PackageDescription/Check/Paths.hs b/Cabal/src/Distribution/PackageDescription/Check/Paths.hs index cd2dfb65d42..f389c6797be 100644 --- a/Cabal/src/Distribution/PackageDescription/Check/Paths.hs +++ b/Cabal/src/Distribution/PackageDescription/Check/Paths.hs @@ -1,4 +1,3 @@ ------------------------------------------------------------------------------ -- | -- Module : Distribution.PackageDescription.Check.Paths -- Copyright : Lennart Kolmodin 2008, Francesco Ariis 2023 @@ -8,105 +7,113 @@ -- Portability : portable -- -- Functions to check filepaths, directories, globs, etc. - -module Distribution.PackageDescription.Check.Paths ( - checkGlob, - checkPath, - fileExtensionSupportedLanguage, - isGoodRelativeDirectoryPath, - isGoodRelativeFilePath, - isGoodRelativeGlob, - isInsideDist - ) where +module Distribution.PackageDescription.Check.Paths + ( checkGlob + , checkPath + , fileExtensionSupportedLanguage + , isGoodRelativeDirectoryPath + , isGoodRelativeFilePath + , isGoodRelativeGlob + , isInsideDist + ) where import Distribution.Compat.Prelude import Prelude () -import Distribution.PackageDescription.Check.Monad import Distribution.PackageDescription.Check.Common +import Distribution.PackageDescription.Check.Monad import Distribution.Simple.CCompiler import Distribution.Simple.Glob import Distribution.Simple.Utils hiding (findPackageDesc, notice) -import System.FilePath (takeExtension, splitDirectories, splitPath) +import System.FilePath (splitDirectories, splitPath, takeExtension) import qualified System.FilePath.Windows as FilePath.Windows (isValid) - - fileExtensionSupportedLanguage :: FilePath -> Bool fileExtensionSupportedLanguage path = - isHaskell || isC + isHaskell || isC where extension = takeExtension path isHaskell = extension `elem` [".hs", ".lhs"] - isC = isJust (filenameCDialect extension) + isC = isJust (filenameCDialect extension) -- Boolean: are absolute paths allowed? -checkPath :: Monad m => - Bool -> -- Can be absolute path? - CabalField -> -- .cabal field that we are checking. - PathKind -> -- Path type. - FilePath -> -- Path. - CheckM m () +checkPath + :: Monad m + => Bool -- Can be absolute path? + -> CabalField -- .cabal field that we are checking. + -> PathKind -- Path type. + -> FilePath -- Path. + -> CheckM m () checkPath isAbs title kind path = do - checkP (isOutsideTree path) - (PackageBuildWarning $ RelativeOutside title path) - checkP (isInsideDist path) - (PackageDistInexcusable $ DistPoint (Just title) path) - checkPackageFileNamesWithGlob kind path - - -- Skip if "can be absolute path". - checkP (not isAbs && isAbsoluteOnAnyPlatform path) - (PackageDistInexcusable $ AbsolutePath title path) - case grl path kind of - Just e -> checkP (not isAbs) - (PackageDistInexcusable $ BadRelativePath title path e) - Nothing -> return () - checkWindowsPath (kind == PathKindGlob) path - where - isOutsideTree wpath = case splitDirectories wpath of - "..":_ -> True - ".":"..":_ -> True - _ -> False + checkP + (isOutsideTree path) + (PackageBuildWarning $ RelativeOutside title path) + checkP + (isInsideDist path) + (PackageDistInexcusable $ DistPoint (Just title) path) + checkPackageFileNamesWithGlob kind path + + -- Skip if "can be absolute path". + checkP + (not isAbs && isAbsoluteOnAnyPlatform path) + (PackageDistInexcusable $ AbsolutePath title path) + case grl path kind of + Just e -> + checkP + (not isAbs) + (PackageDistInexcusable $ BadRelativePath title path e) + Nothing -> return () + checkWindowsPath (kind == PathKindGlob) path + where + isOutsideTree wpath = case splitDirectories wpath of + ".." : _ -> True + "." : ".." : _ -> True + _ -> False - -- These are not paths, but globs... - grl wfp PathKindFile = isGoodRelativeFilePath wfp - grl wfp PathKindGlob = isGoodRelativeGlob wfp - grl wfp PathKindDirectory = isGoodRelativeDirectoryPath wfp + -- These are not paths, but globs... + grl wfp PathKindFile = isGoodRelativeFilePath wfp + grl wfp PathKindGlob = isGoodRelativeGlob wfp + grl wfp PathKindDirectory = isGoodRelativeDirectoryPath wfp -- | Is a 'FilePath' inside `dist`, `dist-newstyle` and friends? isInsideDist :: FilePath -> Bool isInsideDist path = - case map lowercase (splitDirectories path) of - "dist" :_ -> True - ".":"dist":_ -> True - "dist-newstyle" :_ -> True - ".":"dist-newstyle":_ -> True - _ -> False - -checkPackageFileNamesWithGlob :: Monad m => - PathKind -> - FilePath -> -- Filepath or possibly a glob pattern. - CheckM m () + case map lowercase (splitDirectories path) of + "dist" : _ -> True + "." : "dist" : _ -> True + "dist-newstyle" : _ -> True + "." : "dist-newstyle" : _ -> True + _ -> False + +checkPackageFileNamesWithGlob + :: Monad m + => PathKind + -> FilePath -- Filepath or possibly a glob pattern. + -> CheckM m () checkPackageFileNamesWithGlob kind fp = do - checkWindowsPath (kind == PathKindGlob) fp - checkTarPath fp - -checkWindowsPath :: Monad m => - Bool -> -- Is it a glob pattern? - FilePath -> -- Path. - CheckM m () + checkWindowsPath (kind == PathKindGlob) fp + checkTarPath fp + +checkWindowsPath + :: Monad m + => Bool -- Is it a glob pattern? + -> FilePath -- Path. + -> CheckM m () checkWindowsPath isGlob path = - checkP (not . FilePath.Windows.isValid $ escape isGlob path) - (PackageDistInexcusable $ InvalidOnWin [path]) + checkP + (not . FilePath.Windows.isValid $ escape isGlob path) + (PackageDistInexcusable $ InvalidOnWin [path]) where -- Force a relative name to catch invalid file names like "f:oo" which -- otherwise parse as file "oo" in the current directory on the 'f' drive. escape :: Bool -> String -> String - escape wisGlob wpath = (".\\" ++) - -- Glob paths will be expanded before being dereferenced, so asterisks - -- shouldn't count against them. - $ map (\c -> if c == '*' && wisGlob then 'x' else c) wpath + escape wisGlob wpath = + (".\\" ++) + -- Glob paths will be expanded before being dereferenced, so asterisks + -- shouldn't count against them. + $ + map (\c -> if c == '*' && wisGlob then 'x' else c) wpath -- | Check a file name is valid for the portable POSIX tar format. -- @@ -115,36 +122,36 @@ checkWindowsPath isGlob path = -- restriction is that either the whole path be 100 characters or less, or it -- be possible to split the path on a directory separator such that the first -- part is 155 characters or less and the second part 100 characters or less. --- checkTarPath :: Monad m => FilePath -> CheckM m () checkTarPath path - | length path > 255 = tellP longPath + | length path > 255 = tellP longPath | otherwise = case pack nameMax (reverse (splitPath path)) of - Left err -> tellP err - Right [] -> return () - Right (h:rest) -> case pack prefixMax remainder of - Left err -> tellP err - Right [] -> return () - Right (_:_) -> tellP noSplit - where - -- drop the '/' between the name and prefix: - remainder = safeInit h : rest - + Left err -> tellP err + Right [] -> return () + Right (h : rest) -> case pack prefixMax remainder of + Left err -> tellP err + Right [] -> return () + Right (_ : _) -> tellP noSplit + where + -- drop the '/' between the name and prefix: + remainder = safeInit h : rest where nameMax, prefixMax :: Int - nameMax = 100 + nameMax = 100 prefixMax = 155 - pack _ [] = Left emptyName - pack maxLen (c:cs) - | n > maxLen = Left longName - | otherwise = Right (pack' maxLen n cs) - where n = length c + pack _ [] = Left emptyName + pack maxLen (c : cs) + | n > maxLen = Left longName + | otherwise = Right (pack' maxLen n cs) + where + n = length c - pack' maxLen n (c:cs) + pack' maxLen n (c : cs) | n' <= maxLen = pack' maxLen n' cs - where n' = n + length c - pack' _ _ cs = cs + where + n' = n + length c + pack' _ _ cs = cs longPath = PackageDistInexcusable (FilePathTooLong path) longName = PackageDistInexcusable (FilePathNameTooLong path) @@ -153,24 +160,31 @@ checkTarPath path -- `checkGlob` checks glob patterns and returns good ones for further -- processing. -checkGlob :: Monad m => - CabalField -> -- .cabal field we are checking. - FilePath -> -- glob filepath pattern - CheckM m (Maybe Glob) +checkGlob + :: Monad m + => CabalField -- .cabal field we are checking. + -> FilePath -- glob filepath pattern + -> CheckM m (Maybe Glob) checkGlob title pat = do - ver <- asksCM ccSpecVersion - - -- Glob sanity check. - case parseFileGlob ver pat of - Left e -> do tellP (PackageDistInexcusable $ - GlobSyntaxError title (explainGlobSyntaxError pat e)) - return Nothing - Right wglob -> do -- * Miscellaneous checks on sane glob. - -- Checks for recursive glob in root. - checkP (isRecursiveInRoot wglob) - (PackageDistSuspiciousWarn $ - RecursiveGlobInRoot title pat) - return (Just wglob) + ver <- asksCM ccSpecVersion + + -- Glob sanity check. + case parseFileGlob ver pat of + Left e -> do + tellP + ( PackageDistInexcusable $ + GlobSyntaxError title (explainGlobSyntaxError pat e) + ) + return Nothing + Right wglob -> do + -- \* Miscellaneous checks on sane glob. + -- Checks for recursive glob in root. + checkP + (isRecursiveInRoot wglob) + ( PackageDistSuspiciousWarn $ + RecursiveGlobInRoot title pat + ) + return (Just wglob) -- | Whether a path is a good relative path. We aren't worried about perfect -- cross-platform compatibility here; this function just checks the paths in @@ -211,94 +225,106 @@ checkGlob title pat = do -- -- >>> traverse_ (print . isGoodRelativeGlob) ["foo/../bar"] -- Just "parent directory segment: .." --- isGoodRelativeFilePath :: FilePath -> Maybe String isGoodRelativeFilePath = state0 where -- initial state - state0 [] = Just "empty path" - state0 (c:cs) | c == '.' = state1 cs - | c == '/' = Just "posix absolute path" - | otherwise = state5 cs + state0 [] = Just "empty path" + state0 (c : cs) + | c == '.' = state1 cs + | c == '/' = Just "posix absolute path" + | otherwise = state5 cs -- after initial . - state1 [] = Just "trailing dot segment" - state1 (c:cs) | c == '.' = state4 cs - | c == '/' = state2 cs - | otherwise = state5 cs + state1 [] = Just "trailing dot segment" + state1 (c : cs) + | c == '.' = state4 cs + | c == '/' = state2 cs + | otherwise = state5 cs -- after ./ or after / between segments - state2 [] = Just "trailing slash" - state2 (c:cs) | c == '.' = state3 cs - | c == '/' = Just "empty path segment" - | otherwise = state5 cs + state2 [] = Just "trailing slash" + state2 (c : cs) + | c == '.' = state3 cs + | c == '/' = Just "empty path segment" + | otherwise = state5 cs -- after non-first segment's . - state3 [] = Just "trailing same directory segment: ." - state3 (c:cs) | c == '.' = state4 cs - | c == '/' = Just "same directory segment: ." - | otherwise = state5 cs + state3 [] = Just "trailing same directory segment: ." + state3 (c : cs) + | c == '.' = state4 cs + | c == '/' = Just "same directory segment: ." + | otherwise = state5 cs -- after .. - state4 [] = Just "trailing parent directory segment: .." - state4 (c:cs) | c == '.' = state5 cs - | c == '/' = Just "parent directory segment: .." - | otherwise = state5 cs + state4 [] = Just "trailing parent directory segment: .." + state4 (c : cs) + | c == '.' = state5 cs + | c == '/' = Just "parent directory segment: .." + | otherwise = state5 cs -- in a segment which is ok. - state5 [] = Nothing - state5 (c:cs) | c == '.' = state5 cs - | c == '/' = state2 cs - | otherwise = state5 cs + state5 [] = Nothing + state5 (c : cs) + | c == '.' = state5 cs + | c == '/' = state2 cs + | otherwise = state5 cs -- | See 'isGoodRelativeFilePath'. -- -- This is barebones function. We check whether the glob is a valid file -- by replacing stars @*@ with @x@ses. isGoodRelativeGlob :: FilePath -> Maybe String -isGoodRelativeGlob = isGoodRelativeFilePath . map f where +isGoodRelativeGlob = isGoodRelativeFilePath . map f + where f '*' = 'x' - f c = c + f c = c -- | See 'isGoodRelativeFilePath'. isGoodRelativeDirectoryPath :: FilePath -> Maybe String isGoodRelativeDirectoryPath = state0 where -- initial state - state0 [] = Just "empty path" - state0 (c:cs) | c == '.' = state5 cs - | c == '/' = Just "posix absolute path" - | otherwise = state4 cs + state0 [] = Just "empty path" + state0 (c : cs) + | c == '.' = state5 cs + | c == '/' = Just "posix absolute path" + | otherwise = state4 cs -- after initial ./ or after / between segments - state1 [] = Nothing - state1 (c:cs) | c == '.' = state2 cs - | c == '/' = Just "empty path segment" - | otherwise = state4 cs + state1 [] = Nothing + state1 (c : cs) + | c == '.' = state2 cs + | c == '/' = Just "empty path segment" + | otherwise = state4 cs -- after non-first setgment's . - state2 [] = Just "trailing same directory segment: ." - state2 (c:cs) | c == '.' = state3 cs - | c == '/' = Just "same directory segment: ." - | otherwise = state4 cs + state2 [] = Just "trailing same directory segment: ." + state2 (c : cs) + | c == '.' = state3 cs + | c == '/' = Just "same directory segment: ." + | otherwise = state4 cs -- after .. - state3 [] = Just "trailing parent directory segment: .." - state3 (c:cs) | c == '.' = state4 cs - | c == '/' = Just "parent directory segment: .." - | otherwise = state4 cs + state3 [] = Just "trailing parent directory segment: .." + state3 (c : cs) + | c == '.' = state4 cs + | c == '/' = Just "parent directory segment: .." + | otherwise = state4 cs -- in a segment which is ok. - state4 [] = Nothing - state4 (c:cs) | c == '.' = state4 cs - | c == '/' = state1 cs - | otherwise = state4 cs + state4 [] = Nothing + state4 (c : cs) + | c == '.' = state4 cs + | c == '/' = state1 cs + | otherwise = state4 cs -- after initial . - state5 [] = Nothing -- "." - state5 (c:cs) | c == '.' = state3 cs - | c == '/' = state1 cs - | otherwise = state4 cs + state5 [] = Nothing -- "." + state5 (c : cs) + | c == '.' = state3 cs + | c == '/' = state1 cs + | otherwise = state4 cs -- [Note: Good relative paths] -- @@ -384,4 +410,3 @@ isGoodRelativeDirectoryPath = state0 -- | x <= CSlash -> 1 -- | otherwise -> 4 -- @ - diff --git a/Cabal/src/Distribution/PackageDescription/Check/Target.hs b/Cabal/src/Distribution/PackageDescription/Check/Target.hs index aefe9d4b936..e4219bb4e75 100644 --- a/Cabal/src/Distribution/PackageDescription/Check/Target.hs +++ b/Cabal/src/Distribution/PackageDescription/Check/Target.hs @@ -1,4 +1,3 @@ ------------------------------------------------------------------------------ -- | -- Module : Distribution.PackageDescription.Check.Target -- Copyright : Lennart Kolmodin 2008, Francesco Ariis 2023 @@ -8,14 +7,13 @@ -- Portability : portable -- -- Fully-realised target (library, executable, …) checking functions. - -module Distribution.PackageDescription.Check.Target ( - checkLibrary, - checkForeignLib, - checkExecutable, - checkTestSuite, - checkBenchmark, - ) where +module Distribution.PackageDescription.Check.Target + ( checkLibrary + , checkForeignLib + , checkExecutable + , checkTestSuite + , checkBenchmark + ) where import Distribution.Compat.Prelude import Prelude () @@ -23,7 +21,6 @@ import Prelude () import Distribution.CabalSpecVersion import Distribution.Compat.Lens import Distribution.Compiler -import Language.Haskell.Extension import Distribution.ModuleName (ModuleName) import Distribution.Package import Distribution.PackageDescription @@ -31,198 +28,274 @@ import Distribution.PackageDescription.Check.Common import Distribution.PackageDescription.Check.Monad import Distribution.PackageDescription.Check.Paths import Distribution.Pretty (prettyShow) -import Distribution.Simple.BuildPaths (autogenPathsModuleName, - autogenPackageInfoModuleName) +import Distribution.Simple.BuildPaths + ( autogenPackageInfoModuleName + , autogenPathsModuleName + ) import Distribution.Simple.Utils hiding (findPackageDesc, notice) -import Distribution.Version import Distribution.Types.PackageName.Magic import Distribution.Utils.Path +import Distribution.Version +import Language.Haskell.Extension import System.FilePath (takeExtension) import Control.Monad -import qualified Distribution.Types.BuildInfo.Lens as L - - - -checkLibrary :: Monad m => - Bool -> -- Is this a sublibrary? - [AssocDep] -> -- “Inherited” dependencies for PVP checks. - Library -> - CheckM m () -checkLibrary isSub ads lib@(Library - libName_ _exposedModules_ reexportedModules_ - signatures_ _libExposed_ _libVisibility_ - libBuildInfo_) = do - checkP (libName_ == LMainLibName && isSub) - (PackageBuildImpossible UnnamedInternal) - -- TODO: bogus if a required-signature was passed through. - checkP (null (explicitLibModules lib) && null reexportedModules_) - (PackageDistSuspiciousWarn (NoModulesExposed libName_)) - -- TODO parse-caught check, can safely remove. - checkSpecVer CabalSpecV2_0 (not . null $ signatures_) - (PackageDistInexcusable SignaturesCabal2) - -- autogen/includes checks. - checkP (not $ all (flip elem (explicitLibModules lib)) - (libModulesAutogen lib)) - (PackageBuildImpossible AutogenNotExposed) - -- check that all autogen-includes appear on includes or - -- install-includes. - checkP (not $ all (flip elem (allExplicitIncludes lib)) - (view L.autogenIncludes lib)) $ - (PackageBuildImpossible AutogenIncludesNotIncluded) - - -- § Build infos. - checkBuildInfo (CETLibrary libName_) - (explicitLibModules lib) - ads - libBuildInfo_ - - -- Feature checks. - -- check use of reexported-modules sections - checkSpecVer CabalSpecV1_22 (not . null $ reexportedModules_) - (PackageDistInexcusable CVReexported) +import qualified Distribution.Types.BuildInfo.Lens as L + +checkLibrary + :: Monad m + => Bool -- Is this a sublibrary? + -> [AssocDep] -- “Inherited” dependencies for PVP checks. + -> Library + -> CheckM m () +checkLibrary + isSub + ads + lib@( Library + libName_ + _exposedModules_ + reexportedModules_ + signatures_ + _libExposed_ + _libVisibility_ + libBuildInfo_ + ) = do + checkP + (libName_ == LMainLibName && isSub) + (PackageBuildImpossible UnnamedInternal) + -- TODO: bogus if a required-signature was passed through. + checkP + (null (explicitLibModules lib) && null reexportedModules_) + (PackageDistSuspiciousWarn (NoModulesExposed libName_)) + -- TODO parse-caught check, can safely remove. + checkSpecVer + CabalSpecV2_0 + (not . null $ signatures_) + (PackageDistInexcusable SignaturesCabal2) + -- autogen/includes checks. + checkP + ( not $ + all + (flip elem (explicitLibModules lib)) + (libModulesAutogen lib) + ) + (PackageBuildImpossible AutogenNotExposed) + -- check that all autogen-includes appear on includes or + -- install-includes. + checkP + ( not $ + all + (flip elem (allExplicitIncludes lib)) + (view L.autogenIncludes lib) + ) + $ (PackageBuildImpossible AutogenIncludesNotIncluded) + + -- § Build infos. + checkBuildInfo + (CETLibrary libName_) + (explicitLibModules lib) + ads + libBuildInfo_ + + -- Feature checks. + -- check use of reexported-modules sections + checkSpecVer + CabalSpecV1_22 + (not . null $ reexportedModules_) + (PackageDistInexcusable CVReexported) where - allExplicitIncludes :: L.HasBuildInfo a => a -> [FilePath] - allExplicitIncludes x = view L.includes x ++ - view L.installIncludes x + allExplicitIncludes :: L.HasBuildInfo a => a -> [FilePath] + allExplicitIncludes x = + view L.includes x + ++ view L.installIncludes x checkForeignLib :: Monad m => ForeignLib -> CheckM m () -checkForeignLib (ForeignLib - foreignLibName_ _foreignLibType_ _foreignLibOptions_ - foreignLibBuildInfo_ _foreignLibVersionInfo_ - _foreignLibVersionLinux_ _foreignLibModDefFile_) = do - - checkBuildInfo (CETForeignLibrary foreignLibName_) - [] - [] - foreignLibBuildInfo_ - -checkExecutable :: Monad m => - PackageId -> - [AssocDep] -> -- “Inherited” dependencies for PVP checks. - Executable -> - CheckM m () -checkExecutable pid ads exe@(Executable - exeName_ modulePath_ - _exeScope_ buildInfo_) = do - - -- Target type/name (exe). - let cet = CETExecutable exeName_ - - -- § Exe specific checks - checkP (null modulePath_) - (PackageBuildImpossible (NoMainIs exeName_)) - -- This check does not apply to scripts. - checkP (pid /= fakePackageId && - not (null modulePath_) && - not (fileExtensionSupportedLanguage $ modulePath_)) - (PackageBuildImpossible NoHsLhsMain) - - -- § Features check - checkSpecVer CabalSpecV1_18 - (fileExtensionSupportedLanguage modulePath_ && - takeExtension modulePath_ `notElem` [".hs", ".lhs"]) - (PackageDistInexcusable MainCCabal1_18) - - -- Alas exeModules ad exeModulesAutogen (exported from - -- Distribution.Types.Executable) take `Executable` as a parameter. - checkP (not $ all (flip elem (exeModules exe)) (exeModulesAutogen exe)) - (PackageBuildImpossible $ AutogenNoOther cet) - checkP (not $ all (flip elem (view L.includes exe)) - (view L.autogenIncludes exe)) - (PackageBuildImpossible AutogenIncludesNotIncludedExe) - - -- § Build info checks. - checkBuildInfo cet [] ads buildInfo_ - -checkTestSuite :: Monad m => - [AssocDep] -> -- “Inherited” dependencies for PVP checks. - TestSuite -> - CheckM m () -checkTestSuite ads ts@(TestSuite - testName_ testInterface_ testBuildInfo_ - _testCodeGenerators_) = do - - -- Target type/name (test). - let cet = CETTest testName_ - - -- § TS specific checks. - -- TODO caught by the parser, can remove safely +checkForeignLib + ( ForeignLib + foreignLibName_ + _foreignLibType_ + _foreignLibOptions_ + foreignLibBuildInfo_ + _foreignLibVersionInfo_ + _foreignLibVersionLinux_ + _foreignLibModDefFile_ + ) = do + checkBuildInfo + (CETForeignLibrary foreignLibName_) + [] + [] + foreignLibBuildInfo_ + +checkExecutable + :: Monad m + => PackageId + -> [AssocDep] -- “Inherited” dependencies for PVP checks. + -> Executable + -> CheckM m () +checkExecutable + pid + ads + exe@( Executable + exeName_ + modulePath_ + _exeScope_ + buildInfo_ + ) = do + -- Target type/name (exe). + let cet = CETExecutable exeName_ + + -- § Exe specific checks + checkP + (null modulePath_) + (PackageBuildImpossible (NoMainIs exeName_)) + -- This check does not apply to scripts. + checkP + ( pid /= fakePackageId + && not (null modulePath_) + && not (fileExtensionSupportedLanguage $ modulePath_) + ) + (PackageBuildImpossible NoHsLhsMain) + + -- § Features check + checkSpecVer + CabalSpecV1_18 + ( fileExtensionSupportedLanguage modulePath_ + && takeExtension modulePath_ `notElem` [".hs", ".lhs"] + ) + (PackageDistInexcusable MainCCabal1_18) + + -- Alas exeModules ad exeModulesAutogen (exported from + -- Distribution.Types.Executable) take `Executable` as a parameter. + checkP + (not $ all (flip elem (exeModules exe)) (exeModulesAutogen exe)) + (PackageBuildImpossible $ AutogenNoOther cet) + checkP + ( not $ + all + (flip elem (view L.includes exe)) + (view L.autogenIncludes exe) + ) + (PackageBuildImpossible AutogenIncludesNotIncludedExe) + + -- § Build info checks. + checkBuildInfo cet [] ads buildInfo_ + +checkTestSuite + :: Monad m + => [AssocDep] -- “Inherited” dependencies for PVP checks. + -> TestSuite + -> CheckM m () +checkTestSuite + ads + ts@( TestSuite + testName_ + testInterface_ + testBuildInfo_ + _testCodeGenerators_ + ) = do + -- Target type/name (test). + let cet = CETTest testName_ + + -- § TS specific checks. + -- TODO caught by the parser, can remove safely + case testInterface_ of + TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> + tellP (PackageBuildWarning $ TestsuiteTypeNotKnown tt) + TestSuiteUnsupported tt -> + tellP (PackageBuildWarning $ TestsuiteNotSupported tt) + _ -> return () + checkP + mainIsWrongExt + (PackageBuildImpossible NoHsLhsMain) + checkP + ( not $ + all + (flip elem (testModules ts)) + (testModulesAutogen ts) + ) + (PackageBuildImpossible $ AutogenNoOther cet) + checkP + ( not $ + all + (flip elem (view L.includes ts)) + (view L.autogenIncludes ts) + ) + (PackageBuildImpossible AutogenIncludesNotIncludedExe) + + -- § Feature checks. + checkSpecVer + CabalSpecV1_18 + (mainIsNotHsExt && not mainIsWrongExt) + (PackageDistInexcusable MainCCabal1_18) + + -- § Build info checks. + checkBuildInfo cet [] ads testBuildInfo_ + where + mainIsWrongExt = case testInterface_ of - TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> - tellP (PackageBuildWarning $ TestsuiteTypeNotKnown tt) - TestSuiteUnsupported tt -> - tellP (PackageBuildWarning $ TestsuiteNotSupported tt) - _ -> return () - checkP mainIsWrongExt - (PackageBuildImpossible NoHsLhsMain) - checkP (not $ all (flip elem (testModules ts)) - (testModulesAutogen ts)) - (PackageBuildImpossible $ AutogenNoOther cet) - checkP (not $ all (flip elem (view L.includes ts)) - (view L.autogenIncludes ts)) - (PackageBuildImpossible AutogenIncludesNotIncludedExe) - - -- § Feature checks. - checkSpecVer CabalSpecV1_18 - (mainIsNotHsExt && not mainIsWrongExt) - (PackageDistInexcusable MainCCabal1_18) - - -- § Build info checks. - checkBuildInfo cet [] ads testBuildInfo_ - where - mainIsWrongExt = - case testInterface_ of - TestSuiteExeV10 _ f -> not (fileExtensionSupportedLanguage f) - _ -> False - - mainIsNotHsExt = - case testInterface_ of - TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] - _ -> False - -checkBenchmark :: Monad m => - [AssocDep] -> -- “Inherited” dependencies for PVP checks. - Benchmark -> - CheckM m () -checkBenchmark ads bm@(Benchmark - benchmarkName_ benchmarkInterface_ - benchmarkBuildInfo_) = do + TestSuiteExeV10 _ f -> not (fileExtensionSupportedLanguage f) + _ -> False - -- Target type/name (benchmark). - let cet = CETBenchmark benchmarkName_ - - -- § Interface & bm specific tests. - case benchmarkInterface_ of - BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> - tellP (PackageBuildWarning $ BenchmarkTypeNotKnown tt) - BenchmarkUnsupported tt -> - tellP (PackageBuildWarning $ BenchmarkNotSupported tt) - _ -> return () - checkP mainIsWrongExt - (PackageBuildImpossible NoHsLhsMainBench) - - checkP (not $ all (flip elem (benchmarkModules bm)) - (benchmarkModulesAutogen bm)) - (PackageBuildImpossible $ AutogenNoOther cet) - - checkP (not $ all (flip elem (view L.includes bm)) - (view L.autogenIncludes bm)) - (PackageBuildImpossible AutogenIncludesNotIncludedExe) - - -- § BuildInfo checks. - checkBuildInfo cet [] ads benchmarkBuildInfo_ + mainIsNotHsExt = + case testInterface_ of + TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] + _ -> False + +checkBenchmark + :: Monad m + => [AssocDep] -- “Inherited” dependencies for PVP checks. + -> Benchmark + -> CheckM m () +checkBenchmark + ads + bm@( Benchmark + benchmarkName_ + benchmarkInterface_ + benchmarkBuildInfo_ + ) = do + -- Target type/name (benchmark). + let cet = CETBenchmark benchmarkName_ + + -- § Interface & bm specific tests. + case benchmarkInterface_ of + BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> + tellP (PackageBuildWarning $ BenchmarkTypeNotKnown tt) + BenchmarkUnsupported tt -> + tellP (PackageBuildWarning $ BenchmarkNotSupported tt) + _ -> return () + checkP + mainIsWrongExt + (PackageBuildImpossible NoHsLhsMainBench) + + checkP + ( not $ + all + (flip elem (benchmarkModules bm)) + (benchmarkModulesAutogen bm) + ) + (PackageBuildImpossible $ AutogenNoOther cet) + + checkP + ( not $ + all + (flip elem (view L.includes bm)) + (view L.autogenIncludes bm) + ) + (PackageBuildImpossible AutogenIncludesNotIncludedExe) + + -- § BuildInfo checks. + checkBuildInfo cet [] ads benchmarkBuildInfo_ where - -- Cannot abstract with similar function in checkTestSuite, - -- they are different. - mainIsWrongExt = - case benchmarkInterface_ of - BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] - _ -> False + -- Cannot abstract with similar function in checkTestSuite, + -- they are different. + mainIsWrongExt = + case benchmarkInterface_ of + BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] + _ -> False -- ------------------------------------------------------------ --- * Build info +-- Build info -- ------------------------------------------------------------ -- Check a great deal of things in buildInfo. @@ -233,289 +306,403 @@ checkBenchmark ads bm@(Benchmark -- Duplicating the effort here means risk of diverging definitions for -- little gain (most likely if a field is added to BI, the relevant -- function will be tweaked in Distribution.Types.BuildInfo too). -checkBuildInfo :: Monad m => - CEType -> -- Name and type of the target. - [ModuleName] -> -- Additional module names which cannot be - -- extracted from BuildInfo (mainly: exposed - -- library modules). - [AssocDep] -> -- Inherited “internal” (main lib, named - -- internal libs) dependencies. - BuildInfo -> - CheckM m () +checkBuildInfo + :: Monad m + => CEType -- Name and type of the target. + -> [ModuleName] -- Additional module names which cannot be + -- extracted from BuildInfo (mainly: exposed + -- library modules). + -> [AssocDep] -- Inherited “internal” (main lib, named + -- internal libs) dependencies. + -> BuildInfo + -> CheckM m () checkBuildInfo cet ams ads bi = do - - -- For the sake of clarity, we split che checks in various - -- (top level) functions, even if we are not actually going - -- deeper in the traversal. - - checkBuildInfoOptions (cet2bit cet) bi - checkBuildInfoPathsContent bi - checkBuildInfoPathsWellFormedness bi - - sv <- asksCM ccSpecVersion - checkBuildInfoFeatures bi sv - - checkAutogenModules ams bi - - -- PVP: we check for base and all other deps. - (ids, rds) <- partitionDeps ads [mkUnqualComponentName "base"] - (mergeDependencies $ targetBuildDepends bi) - let ick = const (PackageDistInexcusable BaseNoUpperBounds) - rck = PackageDistSuspiciousWarn . MissingUpperBounds cet - checkPVP ick ids - checkPVPs rck rds - - -- Custom fields well-formedness (ASCII). - mapM_ checkCustomField (customFieldsBI bi) - - -- Content. - mapM_ (checkLocalPathExist "extra-lib-dirs") (extraLibDirs bi) - mapM_ (checkLocalPathExist "extra-lib-dirs-static") - (extraLibDirsStatic bi) - mapM_ (checkLocalPathExist "extra-framework-dirs") - (extraFrameworkDirs bi) - mapM_ (checkLocalPathExist "include-dirs") (includeDirs bi) - mapM_ (checkLocalPathExist "hs-source-dirs") - (map getSymbolicPath $ hsSourceDirs bi) + -- For the sake of clarity, we split che checks in various + -- (top level) functions, even if we are not actually going + -- deeper in the traversal. + + checkBuildInfoOptions (cet2bit cet) bi + checkBuildInfoPathsContent bi + checkBuildInfoPathsWellFormedness bi + + sv <- asksCM ccSpecVersion + checkBuildInfoFeatures bi sv + + checkAutogenModules ams bi + + -- PVP: we check for base and all other deps. + (ids, rds) <- + partitionDeps + ads + [mkUnqualComponentName "base"] + (mergeDependencies $ targetBuildDepends bi) + let ick = const (PackageDistInexcusable BaseNoUpperBounds) + rck = PackageDistSuspiciousWarn . MissingUpperBounds cet + checkPVP ick ids + checkPVPs rck rds + + -- Custom fields well-formedness (ASCII). + mapM_ checkCustomField (customFieldsBI bi) + + -- Content. + mapM_ (checkLocalPathExist "extra-lib-dirs") (extraLibDirs bi) + mapM_ + (checkLocalPathExist "extra-lib-dirs-static") + (extraLibDirsStatic bi) + mapM_ + (checkLocalPathExist "extra-framework-dirs") + (extraFrameworkDirs bi) + mapM_ (checkLocalPathExist "include-dirs") (includeDirs bi) + mapM_ + (checkLocalPathExist "hs-source-dirs") + (map getSymbolicPath $ hsSourceDirs bi) -- Well formedness of BI contents (no `Haskell2015`, no deprecated -- extensions etc). checkBuildInfoPathsContent :: Monad m => BuildInfo -> CheckM m () checkBuildInfoPathsContent bi = do - mapM_ checkLang (allLanguages bi) - mapM_ checkExt (allExtensions bi) - mapM_ checkDep (targetBuildDepends bi) - df <- asksCM ccDesugar - -- This way we can use the same function for legacy&non exedeps. - let ds = buildToolDepends bi ++ catMaybes (map df $ buildTools bi) - mapM_ checkBTDep ds - where - checkLang :: Monad m => Language -> CheckM m () - checkLang (UnknownLanguage n) = - tellP (PackageBuildWarning (UnknownLanguages [n])) - checkLang _ = return () - - checkExt :: Monad m => Extension -> CheckM m () - checkExt (UnknownExtension n) - | n `elem` map prettyShow knownLanguages = - tellP (PackageBuildWarning (LanguagesAsExtension [n])) - | otherwise = - tellP (PackageBuildWarning (UnknownExtensions [n])) - checkExt n = do - let dss = filter (\(a, _) -> a == n) deprecatedExtensions - checkP (not . null $ dss) - (PackageDistSuspicious $ DeprecatedExtensions dss) - - checkDep :: Monad m => Dependency -> CheckM m () - checkDep d@(Dependency name vrange _) = do - mpn <- asksCM (packageNameToUnqualComponentName . pkgName . - pnPackageId . ccNames) - lns <- asksCM (pnSubLibs . ccNames) - pVer <- asksCM (pkgVersion . pnPackageId . ccNames) - let allLibNs = mpn : lns - when (packageNameToUnqualComponentName name `elem` allLibNs) - (checkP (not $ pVer `withinRange` vrange) - (PackageBuildImpossible $ ImpossibleInternalDep [d])) - - checkBTDep :: Monad m => ExeDependency -> CheckM m () - checkBTDep ed@(ExeDependency n name vrange) = do - exns <- asksCM (pnExecs . ccNames) - pVer <- asksCM (pkgVersion . pnPackageId . ccNames) - pNam <- asksCM (pkgName . pnPackageId . ccNames) - checkP (n == pNam && -- internal - name `notElem`exns) -- not present - (PackageBuildImpossible $ MissingInternalExe [ed]) - when (name `elem` exns) - (checkP (not $ pVer `withinRange` vrange) - (PackageBuildImpossible $ ImpossibleInternalExe [ed])) + mapM_ checkLang (allLanguages bi) + mapM_ checkExt (allExtensions bi) + mapM_ checkDep (targetBuildDepends bi) + df <- asksCM ccDesugar + -- This way we can use the same function for legacy&non exedeps. + let ds = buildToolDepends bi ++ catMaybes (map df $ buildTools bi) + mapM_ checkBTDep ds + where + checkLang :: Monad m => Language -> CheckM m () + checkLang (UnknownLanguage n) = + tellP (PackageBuildWarning (UnknownLanguages [n])) + checkLang _ = return () + + checkExt :: Monad m => Extension -> CheckM m () + checkExt (UnknownExtension n) + | n `elem` map prettyShow knownLanguages = + tellP (PackageBuildWarning (LanguagesAsExtension [n])) + | otherwise = + tellP (PackageBuildWarning (UnknownExtensions [n])) + checkExt n = do + let dss = filter (\(a, _) -> a == n) deprecatedExtensions + checkP + (not . null $ dss) + (PackageDistSuspicious $ DeprecatedExtensions dss) + + checkDep :: Monad m => Dependency -> CheckM m () + checkDep d@(Dependency name vrange _) = do + mpn <- + asksCM + ( packageNameToUnqualComponentName + . pkgName + . pnPackageId + . ccNames + ) + lns <- asksCM (pnSubLibs . ccNames) + pVer <- asksCM (pkgVersion . pnPackageId . ccNames) + let allLibNs = mpn : lns + when + (packageNameToUnqualComponentName name `elem` allLibNs) + ( checkP + (not $ pVer `withinRange` vrange) + (PackageBuildImpossible $ ImpossibleInternalDep [d]) + ) + + checkBTDep :: Monad m => ExeDependency -> CheckM m () + checkBTDep ed@(ExeDependency n name vrange) = do + exns <- asksCM (pnExecs . ccNames) + pVer <- asksCM (pkgVersion . pnPackageId . ccNames) + pNam <- asksCM (pkgName . pnPackageId . ccNames) + checkP + ( n == pNam + && name `notElem` exns -- internal + -- not present + ) + (PackageBuildImpossible $ MissingInternalExe [ed]) + when + (name `elem` exns) + ( checkP + (not $ pVer `withinRange` vrange) + (PackageBuildImpossible $ ImpossibleInternalExe [ed]) + ) -- Paths well-formedness check for BuildInfo. checkBuildInfoPathsWellFormedness :: Monad m => BuildInfo -> CheckM m () checkBuildInfoPathsWellFormedness bi = do - mapM_ (checkPath False "asm-sources" PathKindFile) (asmSources bi) - mapM_ (checkPath False "cmm-sources" PathKindFile) (cmmSources bi) - mapM_ (checkPath False "c-sources" PathKindFile) (cSources bi) - mapM_ (checkPath False "cxx-sources" PathKindFile) (cxxSources bi) - mapM_ (checkPath False "js-sources" PathKindFile) (jsSources bi) - mapM_ (checkPath False "install-includes" PathKindFile) - (installIncludes bi) - mapM_ (checkPath False "hs-source-dirs" PathKindDirectory) - (map getSymbolicPath $ hsSourceDirs bi) - -- Possibly absolute paths. - mapM_ (checkPath True "includes" PathKindFile) (includes bi) - mapM_ (checkPath True "include-dirs" PathKindDirectory) - (includeDirs bi) - mapM_ (checkPath True "extra-lib-dirs" PathKindDirectory) - (extraLibDirs bi) - mapM_ (checkPath True "extra-lib-dirs-static" PathKindDirectory) - (extraLibDirsStatic bi) - mapM_ checkOptionPath (perCompilerFlavorToList $ options bi) - where - checkOptionPath :: Monad m => (CompilerFlavor, [FilePath]) -> - CheckM m () - checkOptionPath (GHC, paths) = mapM_ (\path -> - checkP (isInsideDist path) - (PackageDistInexcusable $ DistPoint Nothing path)) - paths - checkOptionPath _ = return () + mapM_ (checkPath False "asm-sources" PathKindFile) (asmSources bi) + mapM_ (checkPath False "cmm-sources" PathKindFile) (cmmSources bi) + mapM_ (checkPath False "c-sources" PathKindFile) (cSources bi) + mapM_ (checkPath False "cxx-sources" PathKindFile) (cxxSources bi) + mapM_ (checkPath False "js-sources" PathKindFile) (jsSources bi) + mapM_ + (checkPath False "install-includes" PathKindFile) + (installIncludes bi) + mapM_ + (checkPath False "hs-source-dirs" PathKindDirectory) + (map getSymbolicPath $ hsSourceDirs bi) + -- Possibly absolute paths. + mapM_ (checkPath True "includes" PathKindFile) (includes bi) + mapM_ + (checkPath True "include-dirs" PathKindDirectory) + (includeDirs bi) + mapM_ + (checkPath True "extra-lib-dirs" PathKindDirectory) + (extraLibDirs bi) + mapM_ + (checkPath True "extra-lib-dirs-static" PathKindDirectory) + (extraLibDirsStatic bi) + mapM_ checkOptionPath (perCompilerFlavorToList $ options bi) + where + checkOptionPath + :: Monad m + => (CompilerFlavor, [FilePath]) + -> CheckM m () + checkOptionPath (GHC, paths) = + mapM_ + ( \path -> + checkP + (isInsideDist path) + (PackageDistInexcusable $ DistPoint Nothing path) + ) + paths + checkOptionPath _ = return () -- Checks for features that can be present in BuildInfo only with certain -- CabalSpecVersion. -checkBuildInfoFeatures :: Monad m => BuildInfo -> CabalSpecVersion -> - CheckM m () +checkBuildInfoFeatures + :: Monad m + => BuildInfo + -> CabalSpecVersion + -> CheckM m () checkBuildInfoFeatures bi sv = do - - -- Default language can be used only w/ spec ≥ 1.10 - checkSpecVer CabalSpecV1_10 (isJust $ defaultLanguage bi) - (PackageBuildWarning CVDefaultLanguage) - -- CheckSpecVer sv. - checkP (sv >= CabalSpecV1_10 && sv < CabalSpecV3_4 && - isNothing (defaultLanguage bi)) - (PackageBuildWarning CVDefaultLanguageComponent) - -- Check use of 'extra-framework-dirs' field. - checkSpecVer CabalSpecV1_24 (not . null $ extraFrameworkDirs bi) - (PackageDistSuspiciousWarn CVExtraFrameworkDirs) - -- Check use of default-extensions field don't need to do the - -- equivalent check for other-extensions. - checkSpecVer CabalSpecV1_10 (not . null $ defaultExtensions bi) - (PackageBuildWarning CVDefaultExtensions) - -- Check use of extensions field - checkP (sv >= CabalSpecV1_10 && (not . null $ oldExtensions bi)) - (PackageBuildWarning CVExtensionsDeprecated) - - -- asm-sources, cmm-sources and friends only w/ spec ≥ 1.10 - checkCVSources (asmSources bi) - checkCVSources (cmmSources bi) - checkCVSources (extraBundledLibs bi) - checkCVSources (extraLibFlavours bi) - - -- extra-dynamic-library-flavours requires ≥ 3.0 - checkSpecVer CabalSpecV3_0 (not . null $ extraDynLibFlavours bi) - (PackageDistInexcusable $ CVExtraDynamic [extraDynLibFlavours bi]) - -- virtual-modules requires ≥ 2.2 - checkSpecVer CabalSpecV2_2 (not . null $ virtualModules bi) $ - (PackageDistInexcusable CVVirtualModules) - -- Check use of thinning and renaming. - checkSpecVer CabalSpecV2_0 (not . null $ mixins bi) - (PackageDistInexcusable CVMixins) - - checkBuildInfoExtensions bi - where - checkCVSources :: Monad m => [FilePath] -> CheckM m () - checkCVSources cvs = - checkSpecVer CabalSpecV3_0 (not . null $ cvs) - (PackageDistInexcusable CVSources) + -- Default language can be used only w/ spec ≥ 1.10 + checkSpecVer + CabalSpecV1_10 + (isJust $ defaultLanguage bi) + (PackageBuildWarning CVDefaultLanguage) + -- CheckSpecVer sv. + checkP + ( sv >= CabalSpecV1_10 + && sv < CabalSpecV3_4 + && isNothing (defaultLanguage bi) + ) + (PackageBuildWarning CVDefaultLanguageComponent) + -- Check use of 'extra-framework-dirs' field. + checkSpecVer + CabalSpecV1_24 + (not . null $ extraFrameworkDirs bi) + (PackageDistSuspiciousWarn CVExtraFrameworkDirs) + -- Check use of default-extensions field don't need to do the + -- equivalent check for other-extensions. + checkSpecVer + CabalSpecV1_10 + (not . null $ defaultExtensions bi) + (PackageBuildWarning CVDefaultExtensions) + -- Check use of extensions field + checkP + (sv >= CabalSpecV1_10 && (not . null $ oldExtensions bi)) + (PackageBuildWarning CVExtensionsDeprecated) + + -- asm-sources, cmm-sources and friends only w/ spec ≥ 1.10 + checkCVSources (asmSources bi) + checkCVSources (cmmSources bi) + checkCVSources (extraBundledLibs bi) + checkCVSources (extraLibFlavours bi) + + -- extra-dynamic-library-flavours requires ≥ 3.0 + checkSpecVer + CabalSpecV3_0 + (not . null $ extraDynLibFlavours bi) + (PackageDistInexcusable $ CVExtraDynamic [extraDynLibFlavours bi]) + -- virtual-modules requires ≥ 2.2 + checkSpecVer CabalSpecV2_2 (not . null $ virtualModules bi) $ + (PackageDistInexcusable CVVirtualModules) + -- Check use of thinning and renaming. + checkSpecVer + CabalSpecV2_0 + (not . null $ mixins bi) + (PackageDistInexcusable CVMixins) + + checkBuildInfoExtensions bi + where + checkCVSources :: Monad m => [FilePath] -> CheckM m () + checkCVSources cvs = + checkSpecVer + CabalSpecV3_0 + (not . null $ cvs) + (PackageDistInexcusable CVSources) -- Tests for extensions usage which can break Cabal < 1.4. checkBuildInfoExtensions :: Monad m => BuildInfo -> CheckM m () checkBuildInfoExtensions bi = do - let exts = allExtensions bi - extCabal1_2 = nub $ filter (`elem` compatExtensionsExtra) exts - extCabal1_4 = nub $ filter (`notElem` compatExtensions) exts - -- As of Cabal-1.4 we can add new extensions without worrying - -- about breaking old versions of cabal. - checkSpecVer CabalSpecV1_2 (not . null $ extCabal1_2) - (PackageDistInexcusable $ - CVExtensions CabalSpecV1_2 extCabal1_2) - checkSpecVer CabalSpecV1_4 (not . null $ extCabal1_4) - (PackageDistInexcusable $ - CVExtensions CabalSpecV1_4 extCabal1_4) - where - -- The known extensions in Cabal-1.2.3 - compatExtensions :: [Extension] - compatExtensions = - map EnableExtension - [OverlappingInstances, UndecidableInstances, IncoherentInstances - , RecursiveDo, ParallelListComp, MultiParamTypeClasses - , FunctionalDependencies, Rank2Types - , RankNTypes, PolymorphicComponents, ExistentialQuantification - , ScopedTypeVariables, ImplicitParams, FlexibleContexts - , FlexibleInstances, EmptyDataDecls, CPP, BangPatterns - , TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface - , Arrows, Generics, NamedFieldPuns, PatternGuards - , GeneralizedNewtypeDeriving, ExtensibleRecords - , RestrictedTypeSynonyms, HereDocuments] ++ - map DisableExtension - [MonomorphismRestriction, ImplicitPrelude] ++ - compatExtensionsExtra - - -- The extra known extensions in Cabal-1.2.3 vs Cabal-1.1.6 - -- (Cabal-1.1.6 came with ghc-6.6. Cabal-1.2 came with ghc-6.8) - compatExtensionsExtra :: [Extension] - compatExtensionsExtra = - map EnableExtension - [KindSignatures, MagicHash, TypeFamilies, StandaloneDeriving - , UnicodeSyntax, PatternSignatures, UnliftedFFITypes - , LiberalTypeSynonyms, TypeOperators, RecordWildCards, RecordPuns - , DisambiguateRecordFields, OverloadedStrings, GADTs - , RelaxedPolyRec, ExtendedDefaultRules, UnboxedTuples - , DeriveDataTypeable, ConstrainedClassMethods] ++ - map DisableExtension - [MonoPatBinds] + let exts = allExtensions bi + extCabal1_2 = nub $ filter (`elem` compatExtensionsExtra) exts + extCabal1_4 = nub $ filter (`notElem` compatExtensions) exts + -- As of Cabal-1.4 we can add new extensions without worrying + -- about breaking old versions of cabal. + checkSpecVer + CabalSpecV1_2 + (not . null $ extCabal1_2) + ( PackageDistInexcusable $ + CVExtensions CabalSpecV1_2 extCabal1_2 + ) + checkSpecVer + CabalSpecV1_4 + (not . null $ extCabal1_4) + ( PackageDistInexcusable $ + CVExtensions CabalSpecV1_4 extCabal1_4 + ) + where + -- The known extensions in Cabal-1.2.3 + compatExtensions :: [Extension] + compatExtensions = + map + EnableExtension + [ OverlappingInstances + , UndecidableInstances + , IncoherentInstances + , RecursiveDo + , ParallelListComp + , MultiParamTypeClasses + , FunctionalDependencies + , Rank2Types + , RankNTypes + , PolymorphicComponents + , ExistentialQuantification + , ScopedTypeVariables + , ImplicitParams + , FlexibleContexts + , FlexibleInstances + , EmptyDataDecls + , CPP + , BangPatterns + , TypeSynonymInstances + , TemplateHaskell + , ForeignFunctionInterface + , Arrows + , Generics + , NamedFieldPuns + , PatternGuards + , GeneralizedNewtypeDeriving + , ExtensibleRecords + , RestrictedTypeSynonyms + , HereDocuments + ] + ++ map + DisableExtension + [MonomorphismRestriction, ImplicitPrelude] + ++ compatExtensionsExtra + + -- The extra known extensions in Cabal-1.2.3 vs Cabal-1.1.6 + -- (Cabal-1.1.6 came with ghc-6.6. Cabal-1.2 came with ghc-6.8) + compatExtensionsExtra :: [Extension] + compatExtensionsExtra = + map + EnableExtension + [ KindSignatures + , MagicHash + , TypeFamilies + , StandaloneDeriving + , UnicodeSyntax + , PatternSignatures + , UnliftedFFITypes + , LiberalTypeSynonyms + , TypeOperators + , RecordWildCards + , RecordPuns + , DisambiguateRecordFields + , OverloadedStrings + , GADTs + , RelaxedPolyRec + , ExtendedDefaultRules + , UnboxedTuples + , DeriveDataTypeable + , ConstrainedClassMethods + ] + ++ map + DisableExtension + [MonoPatBinds] -- Autogenerated modules (Paths_, PackageInfo_) checks. We could pass this -- function something more specific than the whole BuildInfo, but it would be -- a tuple of [ModuleName] lists, error prone. -checkAutogenModules :: Monad m => - [ModuleName] -> -- Additional modules not present - -- in BuildInfo (e.g. exposed library - -- modules). - BuildInfo -> CheckM m () +checkAutogenModules + :: Monad m + => [ModuleName] -- Additional modules not present + -- in BuildInfo (e.g. exposed library + -- modules). + -> BuildInfo + -> CheckM m () checkAutogenModules ams bi = do - pkgId <- asksCM (pnPackageId . ccNames) - let -- It is an unfortunate reality that autogenPathsModuleName - -- and autogenPackageInfoModuleName work on PackageDescription - -- while not needing it all, but just the `package` bit. - minimalPD = emptyPackageDescription { package = pkgId } - autoPathsName = autogenPathsModuleName minimalPD - autoInfoModuleName = autogenPackageInfoModuleName minimalPD - - -- Autogenerated module + some default extension build failure. - autogenCheck autoPathsName CVAutogenPaths - rebindableClashCheck autoPathsName RebindableClashPaths - - -- Paths_* module + some default extension build failure. - autogenCheck autoInfoModuleName CVAutogenPackageInfo - rebindableClashCheck autoInfoModuleName RebindableClashPackageInfo - where - autogenCheck :: Monad m => ModuleName -> CheckExplanation -> - CheckM m () - autogenCheck name warning = do - sv <- asksCM ccSpecVersion - let allModsForAuto = ams ++ otherModules bi - checkP (sv >= CabalSpecV2_0 && - elem name allModsForAuto && - notElem name (autogenModules bi)) - (PackageDistInexcusable warning) - - rebindableClashCheck :: Monad m => ModuleName -> CheckExplanation -> - CheckM m () - rebindableClashCheck name warning = do - checkSpecVer CabalSpecV2_2 - ((name `elem` otherModules bi || - name `elem` autogenModules bi) && checkExts) - (PackageBuildImpossible warning) - - -- Do we have some peculiar extensions active which would interfere - -- (cabal-version <2.2) with Paths_modules? - checkExts :: Bool - checkExts = let exts = defaultExtensions bi - in rebind `elem` exts && - (strings `elem` exts || lists `elem` exts) - where - rebind = EnableExtension RebindableSyntax - strings = EnableExtension OverloadedStrings - lists = EnableExtension OverloadedLists - -checkLocalPathExist :: Monad m => - String -> -- .cabal field where we found the error. - FilePath -> - CheckM m () + pkgId <- asksCM (pnPackageId . ccNames) + let + -- It is an unfortunate reality that autogenPathsModuleName + -- and autogenPackageInfoModuleName work on PackageDescription + -- while not needing it all, but just the `package` bit. + minimalPD = emptyPackageDescription{package = pkgId} + autoPathsName = autogenPathsModuleName minimalPD + autoInfoModuleName = autogenPackageInfoModuleName minimalPD + + -- Autogenerated module + some default extension build failure. + autogenCheck autoPathsName CVAutogenPaths + rebindableClashCheck autoPathsName RebindableClashPaths + + -- Paths_* module + some default extension build failure. + autogenCheck autoInfoModuleName CVAutogenPackageInfo + rebindableClashCheck autoInfoModuleName RebindableClashPackageInfo + where + autogenCheck + :: Monad m + => ModuleName + -> CheckExplanation + -> CheckM m () + autogenCheck name warning = do + sv <- asksCM ccSpecVersion + let allModsForAuto = ams ++ otherModules bi + checkP + ( sv >= CabalSpecV2_0 + && elem name allModsForAuto + && notElem name (autogenModules bi) + ) + (PackageDistInexcusable warning) + + rebindableClashCheck + :: Monad m + => ModuleName + -> CheckExplanation + -> CheckM m () + rebindableClashCheck name warning = do + checkSpecVer + CabalSpecV2_2 + ( ( name `elem` otherModules bi + || name `elem` autogenModules bi + ) + && checkExts + ) + (PackageBuildImpossible warning) + + -- Do we have some peculiar extensions active which would interfere + -- (cabal-version <2.2) with Paths_modules? + checkExts :: Bool + checkExts = + let exts = defaultExtensions bi + in rebind `elem` exts + && (strings `elem` exts || lists `elem` exts) + where + rebind = EnableExtension RebindableSyntax + strings = EnableExtension OverloadedStrings + lists = EnableExtension OverloadedLists + +checkLocalPathExist + :: Monad m + => String -- .cabal field where we found the error. + -> FilePath + -> CheckM m () checkLocalPathExist title dir = - checkPkg (\ops -> do dn <- not <$> doesDirectoryExist ops dir - let rp = not (isAbsoluteOnAnyPlatform dir) - return (rp && dn)) - (PackageBuildWarning $ UnknownDirectory title dir) + checkPkg + ( \ops -> do + dn <- not <$> doesDirectoryExist ops dir + let rp = not (isAbsoluteOnAnyPlatform dir) + return (rp && dn) + ) + (PackageBuildWarning $ UnknownDirectory title dir) -- PVP -- @@ -528,238 +715,319 @@ checkLocalPathExist title dir = -- dependencies order in the list (better UX). mergeDependencies :: [Dependency] -> [Dependency] mergeDependencies [] = [] -mergeDependencies l@(d:_) = - let (sames, diffs) = partition ((== depName d) . depName) l - merged = Dependency (depPkgName d) - (foldl intersectVersionRanges anyVersion $ - map depVerRange sames) - (depLibraries d) - in merged : mergeDependencies diffs - where - depName :: Dependency -> String - depName wd = unPackageName . depPkgName $ wd +mergeDependencies l@(d : _) = + let (sames, diffs) = partition ((== depName d) . depName) l + merged = + Dependency + (depPkgName d) + ( foldl intersectVersionRanges anyVersion $ + map depVerRange sames + ) + (depLibraries d) + in merged : mergeDependencies diffs + where + depName :: Dependency -> String + depName wd = unPackageName . depPkgName $ wd -- ------------------------------------------------------------ --- * Options +-- Options -- ------------------------------------------------------------ -- Target type for option checking. data BITarget = BITLib | BITTestBench | BITOther - deriving (Eq, Show) + deriving (Eq, Show) cet2bit :: CEType -> BITarget -cet2bit (CETLibrary {}) = BITLib -cet2bit (CETForeignLibrary {}) = BITLib -cet2bit (CETExecutable {}) = BITOther -cet2bit (CETTest {}) = BITTestBench -cet2bit (CETBenchmark {}) = BITTestBench +cet2bit (CETLibrary{}) = BITLib +cet2bit (CETForeignLibrary{}) = BITLib +cet2bit (CETExecutable{}) = BITOther +cet2bit (CETTest{}) = BITTestBench +cet2bit (CETBenchmark{}) = BITTestBench cet2bit CETSetup = BITOther -- General check on all options (ghc, C, C++, …) for common inaccuracies. checkBuildInfoOptions :: Monad m => BITarget -> BuildInfo -> CheckM m () checkBuildInfoOptions t bi = do - checkGHCOptions "ghc-options" t (hcOptions GHC bi) - checkGHCOptions "ghc-prof-options" t (hcProfOptions GHC bi) - checkGHCOptions "ghc-shared-options" t (hcSharedOptions GHC bi) - let ldOpts = ldOptions bi - checkCLikeOptions LangC "cc-options" (ccOptions bi) ldOpts - checkCLikeOptions LangCPlusPlus "cxx-options" (cxxOptions bi) ldOpts - checkCPPOptions (cppOptions bi) + checkGHCOptions "ghc-options" t (hcOptions GHC bi) + checkGHCOptions "ghc-prof-options" t (hcProfOptions GHC bi) + checkGHCOptions "ghc-shared-options" t (hcSharedOptions GHC bi) + let ldOpts = ldOptions bi + checkCLikeOptions LangC "cc-options" (ccOptions bi) ldOpts + checkCLikeOptions LangCPlusPlus "cxx-options" (cxxOptions bi) ldOpts + checkCPPOptions (cppOptions bi) -- | Checks GHC options for commonly misused or non-portable flags. -checkGHCOptions :: Monad m => - CabalField -> -- .cabal field name where we found the error. - BITarget -> -- Target type. - [String] -> -- Options (alas in String form). - CheckM m () +checkGHCOptions + :: Monad m + => CabalField -- .cabal field name where we found the error. + -> BITarget -- Target type. + -> [String] -- Options (alas in String form). + -> CheckM m () checkGHCOptions title t opts = do - checkGeneral - case t of - BITLib -> sequence_ [checkLib, checkNonTestBench] - BITTestBench -> checkTestBench - BITOther -> checkNonTestBench - where - checkFlags :: Monad m => [String] -> PackageCheck -> CheckM m () - checkFlags fs ck = checkP (any (`elem` fs) opts) ck - - checkFlagsP :: Monad m => (String -> Bool) -> - (String -> PackageCheck) -> CheckM m () - checkFlagsP p ckc = - case filter p opts of - [] -> return () - (_:_) -> tellP (ckc title) - - checkGeneral = do - checkFlags ["-fasm"] - (PackageDistInexcusable $ OptFasm title) - checkFlags ["-fvia-C"] - (PackageDistSuspicious $ OptViaC title) - checkFlags ["-fhpc"] - (PackageDistInexcusable $ OptHpc title) - checkFlags ["-prof"] - (PackageBuildWarning $ OptProf title) - checkFlags ["-o"] - (PackageBuildWarning $ OptO title) - checkFlags ["-hide-package"] - (PackageBuildWarning $ OptHide title) - checkFlags ["--make"] - (PackageBuildWarning $ OptMake title) - checkFlags [ "-O", "-O1"] - (PackageDistInexcusable $ OptOOne title) - checkFlags ["-O2"] - (PackageDistSuspiciousWarn $ OptOTwo title) - checkFlags ["-split-sections"] - (PackageBuildWarning $ OptSplitSections title) - checkFlags ["-split-objs"] - (PackageBuildWarning $ OptSplitObjs title) - checkFlags ["-optl-Wl,-s", "-optl-s"] - (PackageDistInexcusable $ OptWls title) - checkFlags ["-fglasgow-exts"] - (PackageDistSuspicious $ OptExts title) - let ghcNoRts = rmRtsOpts opts - checkAlternatives title "extensions" - [(flag, prettyShow extension) - | flag <- ghcNoRts - , Just extension <- [ghcExtension flag]] - checkAlternatives title "extensions" - [(flag, extension) - | flag@('-':'X':extension) <- ghcNoRts] - checkAlternatives title "cpp-options" - ([(flag, flag) | flag@('-':'D':_) <- ghcNoRts] ++ - [(flag, flag) | flag@('-':'U':_) <- ghcNoRts]) - checkAlternatives title "include-dirs" - [(flag, dir) | flag@('-':'I':dir) <- ghcNoRts] - checkAlternatives title "extra-libraries" - [(flag, lib) | flag@('-':'l':lib) <- ghcNoRts] - checkAlternatives title "extra-libraries-static" - [(flag, lib) | flag@('-':'l':lib) <- ghcNoRts] - checkAlternatives title "extra-lib-dirs" - [(flag, dir) | flag@('-':'L':dir) <- ghcNoRts] - checkAlternatives title "extra-lib-dirs-static" - [(flag, dir) | flag@('-':'L':dir) <- ghcNoRts] - checkAlternatives title "frameworks" - [(flag, fmwk) - | (flag@"-framework", fmwk) <- - zip ghcNoRts (safeTail ghcNoRts)] - checkAlternatives title "extra-framework-dirs" - [(flag, dir) - | (flag@"-framework-path", dir) <- - zip ghcNoRts (safeTail ghcNoRts)] - -- Old `checkDevelopmentOnlyFlagsOptions` section - checkFlags ["-Werror"] - (PackageDistInexcusable $ WErrorUnneeded title) - checkFlags ["-fdefer-type-errors"] - (PackageDistInexcusable $ FDeferTypeErrorsUnneeded title) - checkFlags ["-fprof-auto", "-fprof-auto-top", "-fprof-auto-calls", - "-fprof-cafs", "-fno-prof-count-entries", "-auto-all", - "-auto", "-caf-all"] - (PackageDistSuspicious $ ProfilingUnneeded title) - checkFlagsP (\opt -> "-d" `isPrefixOf` opt && - opt /= "-dynamic") - (PackageDistInexcusable . DynamicUnneeded) - checkFlagsP (\opt -> case opt of - "-j" -> True - ('-' : 'j' : d : _) -> isDigit d - _ -> False) - (PackageDistInexcusable . JUnneeded) - - checkLib = do - checkP ("-rtsopts" `elem` opts) $ - (PackageBuildWarning $ OptRts title) - checkP (any (\opt -> "-with-rtsopts" `isPrefixOf` opt) opts) - (PackageBuildWarning $ OptWithRts title) - - checkTestBench = do - checkFlags ["-O0", "-Onot"] - (PackageDistSuspiciousWarn $ OptONot title) - - checkNonTestBench = do - checkFlags ["-O0", "-Onot"] - (PackageDistSuspicious $ OptONot title) - - ghcExtension ('-':'f':name) = case name of - "allow-overlapping-instances" -> enable OverlappingInstances - "no-allow-overlapping-instances" -> disable OverlappingInstances - "th" -> enable TemplateHaskell - "no-th" -> disable TemplateHaskell - "ffi" -> enable ForeignFunctionInterface - "no-ffi" -> disable ForeignFunctionInterface - "fi" -> enable ForeignFunctionInterface - "no-fi" -> disable ForeignFunctionInterface - "monomorphism-restriction" -> enable MonomorphismRestriction - "no-monomorphism-restriction" -> disable MonomorphismRestriction - "mono-pat-binds" -> enable MonoPatBinds - "no-mono-pat-binds" -> disable MonoPatBinds - "allow-undecidable-instances" -> enable UndecidableInstances - "no-allow-undecidable-instances" -> disable UndecidableInstances - "allow-incoherent-instances" -> enable IncoherentInstances - "no-allow-incoherent-instances" -> disable IncoherentInstances - "arrows" -> enable Arrows - "no-arrows" -> disable Arrows - "generics" -> enable Generics - "no-generics" -> disable Generics - "implicit-prelude" -> enable ImplicitPrelude - "no-implicit-prelude" -> disable ImplicitPrelude - "implicit-params" -> enable ImplicitParams - "no-implicit-params" -> disable ImplicitParams - "bang-patterns" -> enable BangPatterns - "no-bang-patterns" -> disable BangPatterns - "scoped-type-variables" -> enable ScopedTypeVariables - "no-scoped-type-variables" -> disable ScopedTypeVariables - "extended-default-rules" -> enable ExtendedDefaultRules - "no-extended-default-rules" -> disable ExtendedDefaultRules - _ -> Nothing - ghcExtension "-cpp" = enable CPP - ghcExtension _ = Nothing - - enable e = Just (EnableExtension e) - disable e = Just (DisableExtension e) - - rmRtsOpts :: [String] -> [String] - rmRtsOpts ("-with-rtsopts":_:xs) = rmRtsOpts xs - rmRtsOpts (x:xs) = x : rmRtsOpts xs - rmRtsOpts [] = [] - -checkCLikeOptions :: Monad m => - WarnLang -> -- Language we are warning about (C or C++). - CabalField -> -- Field where we found the error. - [String] -> -- Options in string form. - [String] -> -- Link options in String form. - CheckM m () + checkGeneral + case t of + BITLib -> sequence_ [checkLib, checkNonTestBench] + BITTestBench -> checkTestBench + BITOther -> checkNonTestBench + where + checkFlags :: Monad m => [String] -> PackageCheck -> CheckM m () + checkFlags fs ck = checkP (any (`elem` fs) opts) ck + + checkFlagsP + :: Monad m + => (String -> Bool) + -> (String -> PackageCheck) + -> CheckM m () + checkFlagsP p ckc = + case filter p opts of + [] -> return () + (_ : _) -> tellP (ckc title) + + checkGeneral = do + checkFlags + ["-fasm"] + (PackageDistInexcusable $ OptFasm title) + checkFlags + ["-fvia-C"] + (PackageDistSuspicious $ OptViaC title) + checkFlags + ["-fhpc"] + (PackageDistInexcusable $ OptHpc title) + checkFlags + ["-prof"] + (PackageBuildWarning $ OptProf title) + checkFlags + ["-o"] + (PackageBuildWarning $ OptO title) + checkFlags + ["-hide-package"] + (PackageBuildWarning $ OptHide title) + checkFlags + ["--make"] + (PackageBuildWarning $ OptMake title) + checkFlags + ["-O", "-O1"] + (PackageDistInexcusable $ OptOOne title) + checkFlags + ["-O2"] + (PackageDistSuspiciousWarn $ OptOTwo title) + checkFlags + ["-split-sections"] + (PackageBuildWarning $ OptSplitSections title) + checkFlags + ["-split-objs"] + (PackageBuildWarning $ OptSplitObjs title) + checkFlags + ["-optl-Wl,-s", "-optl-s"] + (PackageDistInexcusable $ OptWls title) + checkFlags + ["-fglasgow-exts"] + (PackageDistSuspicious $ OptExts title) + let ghcNoRts = rmRtsOpts opts + checkAlternatives + title + "extensions" + [ (flag, prettyShow extension) + | flag <- ghcNoRts + , Just extension <- [ghcExtension flag] + ] + checkAlternatives + title + "extensions" + [ (flag, extension) + | flag@('-' : 'X' : extension) <- ghcNoRts + ] + checkAlternatives + title + "cpp-options" + ( [(flag, flag) | flag@('-' : 'D' : _) <- ghcNoRts] + ++ [(flag, flag) | flag@('-' : 'U' : _) <- ghcNoRts] + ) + checkAlternatives + title + "include-dirs" + [(flag, dir) | flag@('-' : 'I' : dir) <- ghcNoRts] + checkAlternatives + title + "extra-libraries" + [(flag, lib) | flag@('-' : 'l' : lib) <- ghcNoRts] + checkAlternatives + title + "extra-libraries-static" + [(flag, lib) | flag@('-' : 'l' : lib) <- ghcNoRts] + checkAlternatives + title + "extra-lib-dirs" + [(flag, dir) | flag@('-' : 'L' : dir) <- ghcNoRts] + checkAlternatives + title + "extra-lib-dirs-static" + [(flag, dir) | flag@('-' : 'L' : dir) <- ghcNoRts] + checkAlternatives + title + "frameworks" + [ (flag, fmwk) + | (flag@"-framework", fmwk) <- + zip ghcNoRts (safeTail ghcNoRts) + ] + checkAlternatives + title + "extra-framework-dirs" + [ (flag, dir) + | (flag@"-framework-path", dir) <- + zip ghcNoRts (safeTail ghcNoRts) + ] + -- Old `checkDevelopmentOnlyFlagsOptions` section + checkFlags + ["-Werror"] + (PackageDistInexcusable $ WErrorUnneeded title) + checkFlags + ["-fdefer-type-errors"] + (PackageDistInexcusable $ FDeferTypeErrorsUnneeded title) + checkFlags + [ "-fprof-auto" + , "-fprof-auto-top" + , "-fprof-auto-calls" + , "-fprof-cafs" + , "-fno-prof-count-entries" + , "-auto-all" + , "-auto" + , "-caf-all" + ] + (PackageDistSuspicious $ ProfilingUnneeded title) + checkFlagsP + ( \opt -> + "-d" `isPrefixOf` opt + && opt /= "-dynamic" + ) + (PackageDistInexcusable . DynamicUnneeded) + checkFlagsP + ( \opt -> case opt of + "-j" -> True + ('-' : 'j' : d : _) -> isDigit d + _ -> False + ) + (PackageDistInexcusable . JUnneeded) + + checkLib = do + checkP ("-rtsopts" `elem` opts) $ + (PackageBuildWarning $ OptRts title) + checkP + (any (\opt -> "-with-rtsopts" `isPrefixOf` opt) opts) + (PackageBuildWarning $ OptWithRts title) + + checkTestBench = do + checkFlags + ["-O0", "-Onot"] + (PackageDistSuspiciousWarn $ OptONot title) + + checkNonTestBench = do + checkFlags + ["-O0", "-Onot"] + (PackageDistSuspicious $ OptONot title) + + ghcExtension ('-' : 'f' : name) = case name of + "allow-overlapping-instances" -> enable OverlappingInstances + "no-allow-overlapping-instances" -> disable OverlappingInstances + "th" -> enable TemplateHaskell + "no-th" -> disable TemplateHaskell + "ffi" -> enable ForeignFunctionInterface + "no-ffi" -> disable ForeignFunctionInterface + "fi" -> enable ForeignFunctionInterface + "no-fi" -> disable ForeignFunctionInterface + "monomorphism-restriction" -> enable MonomorphismRestriction + "no-monomorphism-restriction" -> disable MonomorphismRestriction + "mono-pat-binds" -> enable MonoPatBinds + "no-mono-pat-binds" -> disable MonoPatBinds + "allow-undecidable-instances" -> enable UndecidableInstances + "no-allow-undecidable-instances" -> disable UndecidableInstances + "allow-incoherent-instances" -> enable IncoherentInstances + "no-allow-incoherent-instances" -> disable IncoherentInstances + "arrows" -> enable Arrows + "no-arrows" -> disable Arrows + "generics" -> enable Generics + "no-generics" -> disable Generics + "implicit-prelude" -> enable ImplicitPrelude + "no-implicit-prelude" -> disable ImplicitPrelude + "implicit-params" -> enable ImplicitParams + "no-implicit-params" -> disable ImplicitParams + "bang-patterns" -> enable BangPatterns + "no-bang-patterns" -> disable BangPatterns + "scoped-type-variables" -> enable ScopedTypeVariables + "no-scoped-type-variables" -> disable ScopedTypeVariables + "extended-default-rules" -> enable ExtendedDefaultRules + "no-extended-default-rules" -> disable ExtendedDefaultRules + _ -> Nothing + ghcExtension "-cpp" = enable CPP + ghcExtension _ = Nothing + + enable e = Just (EnableExtension e) + disable e = Just (DisableExtension e) + + rmRtsOpts :: [String] -> [String] + rmRtsOpts ("-with-rtsopts" : _ : xs) = rmRtsOpts xs + rmRtsOpts (x : xs) = x : rmRtsOpts xs + rmRtsOpts [] = [] + +checkCLikeOptions + :: Monad m + => WarnLang -- Language we are warning about (C or C++). + -> CabalField -- Field where we found the error. + -> [String] -- Options in string form. + -> [String] -- Link options in String form. + -> CheckM m () checkCLikeOptions label prefix opts ldOpts = do - - checkAlternatives prefix "include-dirs" - [(flag, dir) | flag@('-':'I':dir) <- opts] - checkAlternatives prefix "extra-libraries" - [(flag, lib) | flag@('-':'l':lib) <- opts] - checkAlternatives prefix "extra-lib-dirs" - [(flag, dir) | flag@('-':'L':dir) <- opts] - - checkAlternatives "ld-options" "extra-libraries" - [(flag, lib) | flag@('-':'l':lib) <- ldOpts] - checkAlternatives "ld-options" "extra-lib-dirs" - [(flag, dir) | flag@('-':'L':dir) <- ldOpts] - - checkP (any (`elem` ["-O", "-Os", "-O0", "-O1", "-O2", "-O3"]) opts) - (PackageDistSuspicious $ COptONumber prefix label) - -checkAlternatives :: Monad m => - CabalField -> -- Wrong field. - CabalField -> -- Appropriate field. - [(String, String)] -> -- List of good and bad flags. - CheckM m () + checkAlternatives + prefix + "include-dirs" + [(flag, dir) | flag@('-' : 'I' : dir) <- opts] + checkAlternatives + prefix + "extra-libraries" + [(flag, lib) | flag@('-' : 'l' : lib) <- opts] + checkAlternatives + prefix + "extra-lib-dirs" + [(flag, dir) | flag@('-' : 'L' : dir) <- opts] + + checkAlternatives + "ld-options" + "extra-libraries" + [(flag, lib) | flag@('-' : 'l' : lib) <- ldOpts] + checkAlternatives + "ld-options" + "extra-lib-dirs" + [(flag, dir) | flag@('-' : 'L' : dir) <- ldOpts] + + checkP + (any (`elem` ["-O", "-Os", "-O0", "-O1", "-O2", "-O3"]) opts) + (PackageDistSuspicious $ COptONumber prefix label) + +checkAlternatives + :: Monad m + => CabalField -- Wrong field. + -> CabalField -- Appropriate field. + -> [(String, String)] -- List of good and bad flags. + -> CheckM m () checkAlternatives badField goodField flags = do - let (badFlags, _) = unzip flags - checkP (not $ null badFlags) - (PackageBuildWarning $ OptAlternatives badField goodField flags) - -checkCPPOptions :: Monad m => - [String] -> -- Options in String form. - CheckM m () + let (badFlags, _) = unzip flags + checkP + (not $ null badFlags) + (PackageBuildWarning $ OptAlternatives badField goodField flags) + +checkCPPOptions + :: Monad m + => [String] -- Options in String form. + -> CheckM m () checkCPPOptions opts = do - checkAlternatives "cpp-options" "include-dirs" - [(flag, dir) | flag@('-':'I':dir) <- opts] - mapM_ (\opt -> checkP (not $ any(`isPrefixOf` opt) ["-D", "-U", "-I"]) - (PackageBuildWarning (COptCPP opt))) - opts - + checkAlternatives + "cpp-options" + "include-dirs" + [(flag, dir) | flag@('-' : 'I' : dir) <- opts] + mapM_ + ( \opt -> + checkP + (not $ any (`isPrefixOf` opt) ["-D", "-U", "-I"]) + (PackageBuildWarning (COptCPP opt)) + ) + opts diff --git a/Cabal/src/Distribution/PackageDescription/Check/Warning.hs b/Cabal/src/Distribution/PackageDescription/Check/Warning.hs index ec2f175799c..c56c6b4329e 100644 --- a/Cabal/src/Distribution/PackageDescription/Check/Warning.hs +++ b/Cabal/src/Distribution/PackageDescription/Check/Warning.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------ -- | -- Module : Distribution.PackageDescription.Check.Warning -- Copyright : Francesco Ariis 2022 @@ -12,20 +11,19 @@ -- Portability : portable -- -- Warning types, messages, severity and associated functions. - module Distribution.PackageDescription.Check.Warning - ( -- * Types and constructors - PackageCheck(..), - CheckExplanation(..), - CEField(..), - CEType(..), - WarnLang(..), + ( -- * Types and constructors + PackageCheck (..) + , CheckExplanation (..) + , CEField (..) + , CEType (..) + , WarnLang (..) - -- * Operations - ppPackageCheck, - isHackageDistError, - extractCheckExplantion - ) where + -- * Operations + , ppPackageCheck + , isHackageDistError + , extractCheckExplantion + ) where import Distribution.Compat.Prelude import Prelude () @@ -36,24 +34,27 @@ import Distribution.ModuleName (ModuleName) import Distribution.Parsec.Warning (PWarning, showPWarning) import Distribution.Pretty (prettyShow) import Distribution.Types.BenchmarkType (BenchmarkType, knownBenchmarkTypes) -import Distribution.Types.Dependency (Dependency(..)) +import Distribution.Types.Dependency (Dependency (..)) import Distribution.Types.ExeDependency (ExeDependency) import Distribution.Types.Flag (FlagName, unFlagName) +import Distribution.Types.LibraryName (LibraryName (..), showLibraryName) import Distribution.Types.PackageName (PackageName) -import Distribution.Types.LibraryName (LibraryName(..), showLibraryName) import Distribution.Types.TestType (TestType, knownTestTypes) import Distribution.Types.UnqualComponentName import Distribution.Types.Version (Version) -import Distribution.Utils.Path (LicenseFile, PackageDir, SymbolicPath, - getSymbolicPath) +import Distribution.Utils.Path + ( LicenseFile + , PackageDir + , SymbolicPath + , getSymbolicPath + ) import Language.Haskell.Extension (Extension) import qualified Data.List as List import qualified Data.Set as Set - -- ------------------------------------------------------------ --- * Check types and explanations +-- Check types and explanations -- ------------------------------------------------------------ -- | Results of some kind of failed package check. @@ -62,204 +63,198 @@ import qualified Data.Set as Set -- All of them come with a human readable explanation. In future we may augment -- them with more machine readable explanations, for example to help an IDE -- suggest automatic corrections. --- -data PackageCheck = - - -- | This package description is no good. There's no way it's going to - -- build sensibly. This should give an error at configure time. - PackageBuildImpossible { explanation :: CheckExplanation } - - -- | A problem that is likely to affect building the package, or an - -- issue that we'd like every package author to be aware of, even if - -- the package is never distributed. - | PackageBuildWarning { explanation :: CheckExplanation } - - -- | An issue that might not be a problem for the package author but - -- might be annoying or detrimental when the package is distributed to - -- users. We should encourage distributed packages to be free from these - -- issues, but occasionally there are justifiable reasons so we cannot - -- ban them entirely. - | PackageDistSuspicious { explanation :: CheckExplanation } - - -- | Like PackageDistSuspicious but will only display warnings - -- rather than causing abnormal exit when you run 'cabal check'. - | PackageDistSuspiciousWarn { explanation :: CheckExplanation } - - -- | An issue that is OK in the author's environment but is almost - -- certain to be a portability problem for other environments. We can - -- quite legitimately refuse to publicly distribute packages with these - -- problems. - | PackageDistInexcusable { explanation :: CheckExplanation } +data PackageCheck + = -- | This package description is no good. There's no way it's going to + -- build sensibly. This should give an error at configure time. + PackageBuildImpossible {explanation :: CheckExplanation} + | -- | A problem that is likely to affect building the package, or an + -- issue that we'd like every package author to be aware of, even if + -- the package is never distributed. + PackageBuildWarning {explanation :: CheckExplanation} + | -- | An issue that might not be a problem for the package author but + -- might be annoying or detrimental when the package is distributed to + -- users. We should encourage distributed packages to be free from these + -- issues, but occasionally there are justifiable reasons so we cannot + -- ban them entirely. + PackageDistSuspicious {explanation :: CheckExplanation} + | -- | Like PackageDistSuspicious but will only display warnings + -- rather than causing abnormal exit when you run 'cabal check'. + PackageDistSuspiciousWarn {explanation :: CheckExplanation} + | -- | An issue that is OK in the author's environment but is almost + -- certain to be a portability problem for other environments. We can + -- quite legitimately refuse to publicly distribute packages with these + -- problems. + PackageDistInexcusable {explanation :: CheckExplanation} deriving (Eq, Ord) -- | Pretty printing 'PackageCheck'. --- ppPackageCheck :: PackageCheck -> String ppPackageCheck e = ppExplanation (explanation e) -- | Broken 'Show' instance (not bijective with Read), alas external packages -- depend on it. instance Show PackageCheck where - show notice = ppPackageCheck notice + show notice = ppPackageCheck notice -- | Would Hackage refuse a package because of this error? isHackageDistError :: PackageCheck -> Bool isHackageDistError = \case - (PackageBuildImpossible {}) -> True - (PackageBuildWarning {}) -> True - (PackageDistInexcusable {}) -> True - (PackageDistSuspicious {}) -> False - (PackageDistSuspiciousWarn {}) -> False + (PackageBuildImpossible{}) -> True + (PackageBuildWarning{}) -> True + (PackageDistInexcusable{}) -> True + (PackageDistSuspicious{}) -> False + (PackageDistSuspiciousWarn{}) -> False -- | Explanations of 'PackageCheck`'s errors/warnings. -- -- ☞ N.B: if you add a constructor here, remeber to change the documentation -- in @doc/cabal-commands.rst@! Same if you modify it, you need to adjust the -- documentation! -data CheckExplanation = - ParseWarning FilePath PWarning - | NoNameField - | NoVersionField - | NoTarget - | UnnamedInternal - | DuplicateSections [UnqualComponentName] - | IllegalLibraryName PackageName - | NoModulesExposed LibraryName - | SignaturesCabal2 - | AutogenNotExposed - | AutogenIncludesNotIncluded - | NoMainIs UnqualComponentName - | NoHsLhsMain - | MainCCabal1_18 - | AutogenNoOther CEType - | AutogenIncludesNotIncludedExe - | TestsuiteTypeNotKnown TestType - | TestsuiteNotSupported TestType - | BenchmarkTypeNotKnown BenchmarkType - | BenchmarkNotSupported BenchmarkType - | NoHsLhsMainBench - | InvalidNameWin PackageName - | ZPrefix - | NoBuildType - | NoCustomSetup - | UnknownCompilers [String] - | UnknownLanguages [String] - | UnknownExtensions [String] - | LanguagesAsExtension [String] - | DeprecatedExtensions [(Extension, Maybe Extension)] - | MissingField CEField - | SynopsisTooLong - | ShortDesc - | InvalidTestWith [Dependency] - | ImpossibleInternalDep [Dependency] - | ImpossibleInternalExe [ExeDependency] - | MissingInternalExe [ExeDependency] - | NONELicense - | NoLicense - | AllRightsReservedLicense - | LicenseMessParse License - | UnrecognisedLicense String - | UncommonBSD4 - | UnknownLicenseVersion License [Version] - | NoLicenseFile - | UnrecognisedSourceRepo String - | MissingType - | MissingLocation - | MissingModule - | MissingTag - | SubdirRelPath - | SubdirGoodRelPath String - | OptFasm String - | OptViaC String - | OptHpc String - | OptProf String - | OptO String - | OptHide String - | OptMake String - | OptONot String - | OptOOne String - | OptOTwo String - | OptSplitSections String - | OptSplitObjs String - | OptWls String - | OptExts String - | OptRts String - | OptWithRts String - | COptONumber String WarnLang - | COptCPP String - | OptAlternatives String String [(String, String)] - | RelativeOutside String FilePath - | AbsolutePath String FilePath - | BadRelativePath String FilePath String - | DistPoint (Maybe String) FilePath - | GlobSyntaxError String String - | RecursiveGlobInRoot String FilePath - | InvalidOnWin [FilePath] - | FilePathTooLong FilePath - | FilePathNameTooLong FilePath - | FilePathSplitTooLong FilePath - | FilePathEmpty - | CVTestSuite - | CVDefaultLanguage - | CVDefaultLanguageComponent - | CVExtraDocFiles - | CVMultiLib - | CVReexported - | CVMixins - | CVExtraFrameworkDirs - | CVDefaultExtensions - | CVExtensionsDeprecated - | CVSources - | CVExtraDynamic [[String]] - | CVVirtualModules - | CVSourceRepository - | CVExtensions CabalSpecVersion [Extension] - | CVCustomSetup - | CVExpliticDepsCustomSetup - | CVAutogenPaths - | CVAutogenPackageInfo - | GlobNoMatch String String - | GlobExactMatch String String FilePath - | GlobNoDir String String FilePath - | UnknownOS [String] - | UnknownArch [String] - | UnknownCompiler [String] - | BaseNoUpperBounds - | MissingUpperBounds CEType [String] - | SuspiciousFlagName [String] - | DeclaredUsedFlags (Set.Set FlagName) (Set.Set FlagName) - | NonASCIICustomField [String] - | RebindableClashPaths - | RebindableClashPackageInfo - | WErrorUnneeded String - | JUnneeded String - | FDeferTypeErrorsUnneeded String - | DynamicUnneeded String - | ProfilingUnneeded String - | UpperBoundSetup String - | DuplicateModule String [ModuleName] - | PotentialDupModule String [ModuleName] - | BOMStart FilePath - | NotPackageName FilePath String - | NoDesc - | MultiDesc [String] - | UnknownFile String (SymbolicPath PackageDir LicenseFile) - | MissingSetupFile - | MissingConfigureScript - | UnknownDirectory String FilePath - | MissingSourceControl - | MissingExpectedDocFiles Bool [FilePath] - | WrongFieldForExpectedDocFiles Bool String [FilePath] - deriving (Eq, Ord, Show) - -- TODO Some checks have a constructor in list form - -- (e.g. `SomeWarn [n]`), CheckM m () correctly catches warnings in - -- different stanzas in different checks (so it is not one soup). - -- - -- Ideally [SomeWar [a], SomeWar [b]] would be translated into - -- SomeWar [a,b] in the few cases where it is appropriate for UX - -- and left separated otherwise. - -- To achieve this the Writer part of CheckM could be modified - -- to be a ad hoc monoid. +data CheckExplanation + = ParseWarning FilePath PWarning + | NoNameField + | NoVersionField + | NoTarget + | UnnamedInternal + | DuplicateSections [UnqualComponentName] + | IllegalLibraryName PackageName + | NoModulesExposed LibraryName + | SignaturesCabal2 + | AutogenNotExposed + | AutogenIncludesNotIncluded + | NoMainIs UnqualComponentName + | NoHsLhsMain + | MainCCabal1_18 + | AutogenNoOther CEType + | AutogenIncludesNotIncludedExe + | TestsuiteTypeNotKnown TestType + | TestsuiteNotSupported TestType + | BenchmarkTypeNotKnown BenchmarkType + | BenchmarkNotSupported BenchmarkType + | NoHsLhsMainBench + | InvalidNameWin PackageName + | ZPrefix + | NoBuildType + | NoCustomSetup + | UnknownCompilers [String] + | UnknownLanguages [String] + | UnknownExtensions [String] + | LanguagesAsExtension [String] + | DeprecatedExtensions [(Extension, Maybe Extension)] + | MissingField CEField + | SynopsisTooLong + | ShortDesc + | InvalidTestWith [Dependency] + | ImpossibleInternalDep [Dependency] + | ImpossibleInternalExe [ExeDependency] + | MissingInternalExe [ExeDependency] + | NONELicense + | NoLicense + | AllRightsReservedLicense + | LicenseMessParse License + | UnrecognisedLicense String + | UncommonBSD4 + | UnknownLicenseVersion License [Version] + | NoLicenseFile + | UnrecognisedSourceRepo String + | MissingType + | MissingLocation + | MissingModule + | MissingTag + | SubdirRelPath + | SubdirGoodRelPath String + | OptFasm String + | OptViaC String + | OptHpc String + | OptProf String + | OptO String + | OptHide String + | OptMake String + | OptONot String + | OptOOne String + | OptOTwo String + | OptSplitSections String + | OptSplitObjs String + | OptWls String + | OptExts String + | OptRts String + | OptWithRts String + | COptONumber String WarnLang + | COptCPP String + | OptAlternatives String String [(String, String)] + | RelativeOutside String FilePath + | AbsolutePath String FilePath + | BadRelativePath String FilePath String + | DistPoint (Maybe String) FilePath + | GlobSyntaxError String String + | RecursiveGlobInRoot String FilePath + | InvalidOnWin [FilePath] + | FilePathTooLong FilePath + | FilePathNameTooLong FilePath + | FilePathSplitTooLong FilePath + | FilePathEmpty + | CVTestSuite + | CVDefaultLanguage + | CVDefaultLanguageComponent + | CVExtraDocFiles + | CVMultiLib + | CVReexported + | CVMixins + | CVExtraFrameworkDirs + | CVDefaultExtensions + | CVExtensionsDeprecated + | CVSources + | CVExtraDynamic [[String]] + | CVVirtualModules + | CVSourceRepository + | CVExtensions CabalSpecVersion [Extension] + | CVCustomSetup + | CVExpliticDepsCustomSetup + | CVAutogenPaths + | CVAutogenPackageInfo + | GlobNoMatch String String + | GlobExactMatch String String FilePath + | GlobNoDir String String FilePath + | UnknownOS [String] + | UnknownArch [String] + | UnknownCompiler [String] + | BaseNoUpperBounds + | MissingUpperBounds CEType [String] + | SuspiciousFlagName [String] + | DeclaredUsedFlags (Set.Set FlagName) (Set.Set FlagName) + | NonASCIICustomField [String] + | RebindableClashPaths + | RebindableClashPackageInfo + | WErrorUnneeded String + | JUnneeded String + | FDeferTypeErrorsUnneeded String + | DynamicUnneeded String + | ProfilingUnneeded String + | UpperBoundSetup String + | DuplicateModule String [ModuleName] + | PotentialDupModule String [ModuleName] + | BOMStart FilePath + | NotPackageName FilePath String + | NoDesc + | MultiDesc [String] + | UnknownFile String (SymbolicPath PackageDir LicenseFile) + | MissingSetupFile + | MissingConfigureScript + | UnknownDirectory String FilePath + | MissingSourceControl + | MissingExpectedDocFiles Bool [FilePath] + | WrongFieldForExpectedDocFiles Bool String [FilePath] + deriving (Eq, Ord, Show) + +-- TODO Some checks have a constructor in list form +-- (e.g. `SomeWarn [n]`), CheckM m () correctly catches warnings in +-- different stanzas in different checks (so it is not one soup). +-- +-- Ideally [SomeWar [a], SomeWar [b]] would be translated into +-- SomeWar [a,b] in the few cases where it is appropriate for UX +-- and left separated otherwise. +-- To achieve this the Writer part of CheckM could be modified +-- to be a ad hoc monoid. -- Convenience. extractCheckExplantion :: PackageCheck -> CheckExplanation @@ -270,38 +265,38 @@ extractCheckExplantion (PackageDistSuspiciousWarn e) = e extractCheckExplantion (PackageDistInexcusable e) = e -- | Which stanza does `CheckExplanation` refer to? --- -data CEType = - CETLibrary LibraryName - | CETForeignLibrary UnqualComponentName - | CETExecutable UnqualComponentName - | CETTest UnqualComponentName - | CETBenchmark UnqualComponentName - | CETSetup - deriving (Eq, Ord, Show) +data CEType + = CETLibrary LibraryName + | CETForeignLibrary UnqualComponentName + | CETExecutable UnqualComponentName + | CETTest UnqualComponentName + | CETBenchmark UnqualComponentName + | CETSetup + deriving (Eq, Ord, Show) -- | Pretty printing `CEType`. --- ppCET :: CEType -> String ppCET cet = case cet of - CETLibrary ln -> showLibraryName ln - CETForeignLibrary n -> "foreign library" ++ qn n - CETExecutable n -> "executable" ++ qn n - CETTest n -> "test suite" ++ qn n - CETBenchmark n -> "benchmark" ++ qn n - CETSetup -> "custom-setup" - where - qn :: UnqualComponentName -> String - qn wn = (" "++) . quote . prettyShow $ wn + CETLibrary ln -> showLibraryName ln + CETForeignLibrary n -> "foreign library" ++ qn n + CETExecutable n -> "executable" ++ qn n + CETTest n -> "test suite" ++ qn n + CETBenchmark n -> "benchmark" ++ qn n + CETSetup -> "custom-setup" + where + qn :: UnqualComponentName -> String + qn wn = (" " ++) . quote . prettyShow $ wn -- | Which field does `CheckExplanation` refer to? --- -data CEField = CEFCategory | CEFMaintainer | CEFSynopsis - | CEFDescription | CEFSynOrDesc - deriving (Eq, Ord, Show) +data CEField + = CEFCategory + | CEFMaintainer + | CEFSynopsis + | CEFDescription + | CEFSynOrDesc + deriving (Eq, Ord, Show) -- | Pretty printing `CEField`. --- ppCEField :: CEField -> String ppCEField CEFCategory = "category" ppCEField CEFMaintainer = "maintainer" @@ -310,490 +305,607 @@ ppCEField CEFDescription = "description" ppCEField CEFSynOrDesc = "synopsis' or 'description" -- | Which language are we referring to in our warning message? --- data WarnLang = LangC | LangCPlusPlus - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show) -- | Pretty printing `WarnLang`. --- ppWarnLang :: WarnLang -> String ppWarnLang LangC = "C" ppWarnLang LangCPlusPlus = "C++" -- | Pretty printing `CheckExplanation`. --- ppExplanation :: CheckExplanation -> String ppExplanation (ParseWarning fp pp) = showPWarning fp pp ppExplanation NoNameField = "No 'name' field." ppExplanation NoVersionField = "No 'version' field." ppExplanation NoTarget = - "No executables, libraries, tests, or benchmarks found. Nothing to do." + "No executables, libraries, tests, or benchmarks found. Nothing to do." ppExplanation UnnamedInternal = - "Found one or more unnamed internal libraries. Only the non-internal" - ++ " library can have the same name as the package." + "Found one or more unnamed internal libraries. Only the non-internal" + ++ " library can have the same name as the package." ppExplanation (DuplicateSections duplicateNames) = - "Duplicate sections: " - ++ commaSep (map unUnqualComponentName duplicateNames) - ++ ". The name of every library, executable, test suite," - ++ " and benchmark section in the package must be unique." + "Duplicate sections: " + ++ commaSep (map unUnqualComponentName duplicateNames) + ++ ". The name of every library, executable, test suite," + ++ " and benchmark section in the package must be unique." ppExplanation (IllegalLibraryName pname) = - "Illegal internal library name " - ++ prettyShow pname - ++ ". Internal libraries cannot have the same name as the package." - ++ " Maybe you wanted a non-internal library?" - ++ " If so, rewrite the section stanza" - ++ " from 'library: '" ++ prettyShow pname - ++ "' to 'library'." + "Illegal internal library name " + ++ prettyShow pname + ++ ". Internal libraries cannot have the same name as the package." + ++ " Maybe you wanted a non-internal library?" + ++ " If so, rewrite the section stanza" + ++ " from 'library: '" + ++ prettyShow pname + ++ "' to 'library'." ppExplanation (NoModulesExposed lName) = - showLibraryName lName ++ " does not expose any modules" + showLibraryName lName ++ " does not expose any modules" ppExplanation SignaturesCabal2 = - "To use the 'signatures' field the package needs to specify " - ++ "at least 'cabal-version: 2.0'." + "To use the 'signatures' field the package needs to specify " + ++ "at least 'cabal-version: 2.0'." ppExplanation AutogenNotExposed = - "An 'autogen-module' is neither on 'exposed-modules' or 'other-modules'." + "An 'autogen-module' is neither on 'exposed-modules' or 'other-modules'." ppExplanation AutogenIncludesNotIncluded = - "An include in 'autogen-includes' is neither in 'includes' or " - ++ "'install-includes'." + "An include in 'autogen-includes' is neither in 'includes' or " + ++ "'install-includes'." ppExplanation (NoMainIs eName) = - "No 'main-is' field found for executable " ++ prettyShow eName + "No 'main-is' field found for executable " ++ prettyShow eName ppExplanation NoHsLhsMain = - "The 'main-is' field must specify a '.hs' or '.lhs' file " - ++ "(even if it is generated by a preprocessor), " - ++ "or it may specify a C/C++/obj-C source file." + "The 'main-is' field must specify a '.hs' or '.lhs' file " + ++ "(even if it is generated by a preprocessor), " + ++ "or it may specify a C/C++/obj-C source file." ppExplanation MainCCabal1_18 = - "The package uses a C/C++/obj-C source file for the 'main-is' field. " - ++ "To use this feature you need to specify 'cabal-version: 1.18' or" - ++ " higher." + "The package uses a C/C++/obj-C source file for the 'main-is' field. " + ++ "To use this feature you need to specify 'cabal-version: 1.18' or" + ++ " higher." ppExplanation (AutogenNoOther ct) = - "On " ++ ppCET ct ++ " an 'autogen-module'" - ++ " is not on 'other-modules'" + "On " + ++ ppCET ct + ++ " an 'autogen-module'" + ++ " is not on 'other-modules'" ppExplanation AutogenIncludesNotIncludedExe = - "An include in 'autogen-includes' is not in 'includes'." + "An include in 'autogen-includes' is not in 'includes'." ppExplanation (TestsuiteTypeNotKnown tt) = - quote (prettyShow tt) ++ " is not a known type of test suite. " - ++ "Either remove the 'type' field or use a known type. " - ++ "The known test suite types are: " - ++ commaSep (map prettyShow knownTestTypes) + quote (prettyShow tt) + ++ " is not a known type of test suite. " + ++ "Either remove the 'type' field or use a known type. " + ++ "The known test suite types are: " + ++ commaSep (map prettyShow knownTestTypes) ppExplanation (TestsuiteNotSupported tt) = - quote (prettyShow tt) ++ " is not a supported test suite version. " - ++ "Either remove the 'type' field or use a known type. " - ++ "The known test suite types are: " - ++ commaSep (map prettyShow knownTestTypes) + quote (prettyShow tt) + ++ " is not a supported test suite version. " + ++ "Either remove the 'type' field or use a known type. " + ++ "The known test suite types are: " + ++ commaSep (map prettyShow knownTestTypes) ppExplanation (BenchmarkTypeNotKnown tt) = - quote (prettyShow tt) ++ " is not a known type of benchmark. " - ++ "Either remove the 'type' field or use a known type. " - ++ "The known benchmark types are: " - ++ commaSep (map prettyShow knownBenchmarkTypes) + quote (prettyShow tt) + ++ " is not a known type of benchmark. " + ++ "Either remove the 'type' field or use a known type. " + ++ "The known benchmark types are: " + ++ commaSep (map prettyShow knownBenchmarkTypes) ppExplanation (BenchmarkNotSupported tt) = - quote (prettyShow tt) ++ " is not a supported benchmark version. " - ++ "Either remove the 'type' field or use a known type. " - ++ "The known benchmark types are: " - ++ commaSep (map prettyShow knownBenchmarkTypes) + quote (prettyShow tt) + ++ " is not a supported benchmark version. " + ++ "Either remove the 'type' field or use a known type. " + ++ "The known benchmark types are: " + ++ commaSep (map prettyShow knownBenchmarkTypes) ppExplanation NoHsLhsMainBench = - "The 'main-is' field must specify a '.hs' or '.lhs' file " - ++ "(even if it is generated by a preprocessor)." + "The 'main-is' field must specify a '.hs' or '.lhs' file " + ++ "(even if it is generated by a preprocessor)." ppExplanation (InvalidNameWin pkg) = - "The package name '" ++ prettyShow pkg ++ "' is " - ++ "invalid on Windows. Many tools need to convert package names to " - ++ "file names so using this name would cause problems." + "The package name '" + ++ prettyShow pkg + ++ "' is " + ++ "invalid on Windows. Many tools need to convert package names to " + ++ "file names so using this name would cause problems." ppExplanation ZPrefix = - "Package names with the prefix 'z-' are reserved by Cabal and " - ++ "cannot be used." + "Package names with the prefix 'z-' are reserved by Cabal and " + ++ "cannot be used." ppExplanation NoBuildType = - "No 'build-type' specified. If you do not need a custom Setup.hs or " - ++ "./configure script then use 'build-type: Simple'." + "No 'build-type' specified. If you do not need a custom Setup.hs or " + ++ "./configure script then use 'build-type: Simple'." ppExplanation NoCustomSetup = - "Ignoring the 'custom-setup' section because the 'build-type' is " - ++ "not 'Custom'. Use 'build-type: Custom' if you need to use a " - ++ "custom Setup.hs script." + "Ignoring the 'custom-setup' section because the 'build-type' is " + ++ "not 'Custom'. Use 'build-type: Custom' if you need to use a " + ++ "custom Setup.hs script." ppExplanation (UnknownCompilers unknownCompilers) = - "Unknown compiler " ++ commaSep (map quote unknownCompilers) - ++ " in 'tested-with' field." + "Unknown compiler " + ++ commaSep (map quote unknownCompilers) + ++ " in 'tested-with' field." ppExplanation (UnknownLanguages unknownLanguages) = - "Unknown languages: " ++ commaSep unknownLanguages + "Unknown languages: " ++ commaSep unknownLanguages ppExplanation (UnknownExtensions unknownExtensions) = - "Unknown extensions: " ++ commaSep unknownExtensions + "Unknown extensions: " ++ commaSep unknownExtensions ppExplanation (LanguagesAsExtension languagesUsedAsExtensions) = - "Languages listed as extensions: " - ++ commaSep languagesUsedAsExtensions - ++ ". Languages must be specified in either the 'default-language' " - ++ " or the 'other-languages' field." + "Languages listed as extensions: " + ++ commaSep languagesUsedAsExtensions + ++ ". Languages must be specified in either the 'default-language' " + ++ " or the 'other-languages' field." ppExplanation (DeprecatedExtensions ourDeprecatedExtensions) = - "Deprecated extensions: " - ++ commaSep (map (quote . prettyShow . fst) ourDeprecatedExtensions) - ++ ". " ++ unwords - [ "Instead of '" ++ prettyShow ext - ++ "' use '" ++ prettyShow replacement ++ "'." - | (ext, Just replacement) <- ourDeprecatedExtensions ] + "Deprecated extensions: " + ++ commaSep (map (quote . prettyShow . fst) ourDeprecatedExtensions) + ++ ". " + ++ unwords + [ "Instead of '" + ++ prettyShow ext + ++ "' use '" + ++ prettyShow replacement + ++ "'." + | (ext, Just replacement) <- ourDeprecatedExtensions + ] ppExplanation (MissingField cef) = - "No '" ++ ppCEField cef ++ "' field." + "No '" ++ ppCEField cef ++ "' field." ppExplanation SynopsisTooLong = - "The 'synopsis' field is rather long (max 80 chars is recommended)." + "The 'synopsis' field is rather long (max 80 chars is recommended)." ppExplanation ShortDesc = - "The 'description' field should be longer than the 'synopsis' field. " - ++ "It's useful to provide an informative 'description' to allow " - ++ "Haskell programmers who have never heard about your package to " - ++ "understand the purpose of your package. " - ++ "The 'description' field content is typically shown by tooling " - ++ "(e.g. 'cabal info', Haddock, Hackage) below the 'synopsis' which " - ++ "serves as a headline. " - ++ "Please refer to for more details." + "The 'description' field should be longer than the 'synopsis' field. " + ++ "It's useful to provide an informative 'description' to allow " + ++ "Haskell programmers who have never heard about your package to " + ++ "understand the purpose of your package. " + ++ "The 'description' field content is typically shown by tooling " + ++ "(e.g. 'cabal info', Haddock, Hackage) below the 'synopsis' which " + ++ "serves as a headline. " + ++ "Please refer to for more details." ppExplanation (InvalidTestWith testedWithImpossibleRanges) = - "Invalid 'tested-with' version range: " - ++ commaSep (map prettyShow testedWithImpossibleRanges) - ++ ". To indicate that you have tested a package with multiple " - ++ "different versions of the same compiler use multiple entries, " - ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not " - ++ "'tested-with: GHC==6.10.4 && ==6.12.3'." + "Invalid 'tested-with' version range: " + ++ commaSep (map prettyShow testedWithImpossibleRanges) + ++ ". To indicate that you have tested a package with multiple " + ++ "different versions of the same compiler use multiple entries, " + ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not " + ++ "'tested-with: GHC==6.10.4 && ==6.12.3'." ppExplanation (ImpossibleInternalDep depInternalLibWithImpossibleVersion) = - "The package has an impossible version range for a dependency on an " - ++ "internal library: " - ++ commaSep (map prettyShow depInternalLibWithImpossibleVersion) - ++ ". This version range does not include the current package, and must " - ++ "be removed as the current package's library will always be used." + "The package has an impossible version range for a dependency on an " + ++ "internal library: " + ++ commaSep (map prettyShow depInternalLibWithImpossibleVersion) + ++ ". This version range does not include the current package, and must " + ++ "be removed as the current package's library will always be used." ppExplanation (ImpossibleInternalExe depInternalExecWithImpossibleVersion) = - "The package has an impossible version range for a dependency on an " - ++ "internal executable: " - ++ commaSep (map prettyShow depInternalExecWithImpossibleVersion) - ++ ". This version range does not include the current package, and must " - ++ "be removed as the current package's executable will always be used." + "The package has an impossible version range for a dependency on an " + ++ "internal executable: " + ++ commaSep (map prettyShow depInternalExecWithImpossibleVersion) + ++ ". This version range does not include the current package, and must " + ++ "be removed as the current package's executable will always be used." ppExplanation (MissingInternalExe depInternalExeWithImpossibleVersion) = - "The package depends on a missing internal executable: " - ++ commaSep (map prettyShow depInternalExeWithImpossibleVersion) + "The package depends on a missing internal executable: " + ++ commaSep (map prettyShow depInternalExeWithImpossibleVersion) ppExplanation NONELicense = "The 'license' field is missing or is NONE." ppExplanation NoLicense = "The 'license' field is missing." ppExplanation AllRightsReservedLicense = - "The 'license' is AllRightsReserved. Is that really what you want?" + "The 'license' is AllRightsReserved. Is that really what you want?" ppExplanation (LicenseMessParse lic) = - "Unfortunately the license " ++ quote (prettyShow lic) - ++ " messes up the parser in earlier Cabal versions so you need to " - ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " - ++ "compatibility with earlier Cabal versions then use 'OtherLicense'." + "Unfortunately the license " + ++ quote (prettyShow lic) + ++ " messes up the parser in earlier Cabal versions so you need to " + ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " + ++ "compatibility with earlier Cabal versions then use 'OtherLicense'." ppExplanation (UnrecognisedLicense l) = - quote ("license: " ++ l) ++ " is not a recognised license. The " - ++ "known licenses are: " ++ commaSep (map prettyShow knownLicenses) + quote ("license: " ++ l) + ++ " is not a recognised license. The " + ++ "known licenses are: " + ++ commaSep (map prettyShow knownLicenses) ppExplanation UncommonBSD4 = - "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' " - ++ "refers to the old 4-clause BSD license with the advertising " - ++ "clause. 'BSD3' refers the new 3-clause BSD license." + "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' " + ++ "refers to the old 4-clause BSD license with the advertising " + ++ "clause. 'BSD3' refers the new 3-clause BSD license." ppExplanation (UnknownLicenseVersion lic known) = - "'license: " ++ prettyShow lic ++ "' is not a known " - ++ "version of that license. The known versions are " - ++ commaSep (map prettyShow known) - ++ ". If this is not a mistake and you think it should be a known " - ++ "version then please file a ticket." + "'license: " + ++ prettyShow lic + ++ "' is not a known " + ++ "version of that license. The known versions are " + ++ commaSep (map prettyShow known) + ++ ". If this is not a mistake and you think it should be a known " + ++ "version then please file a ticket." ppExplanation NoLicenseFile = "A 'license-file' is not specified." ppExplanation (UnrecognisedSourceRepo kind) = - quote kind ++ " is not a recognised kind of source-repository. " - ++ "The repo kind is usually 'head' or 'this'" + quote kind + ++ " is not a recognised kind of source-repository. " + ++ "The repo kind is usually 'head' or 'this'" ppExplanation MissingType = - "The source-repository 'type' is a required field." + "The source-repository 'type' is a required field." ppExplanation MissingLocation = - "The source-repository 'location' is a required field." + "The source-repository 'location' is a required field." ppExplanation MissingModule = - "For a CVS source-repository, the 'module' is a required field." + "For a CVS source-repository, the 'module' is a required field." ppExplanation MissingTag = - "For the 'this' kind of source-repository, the 'tag' is a required " - ++ "field. It should specify the tag corresponding to this version " - ++ "or release of the package." + "For the 'this' kind of source-repository, the 'tag' is a required " + ++ "field. It should specify the tag corresponding to this version " + ++ "or release of the package." ppExplanation SubdirRelPath = - "The 'subdir' field of a source-repository must be a relative path." + "The 'subdir' field of a source-repository must be a relative path." ppExplanation (SubdirGoodRelPath err) = - "The 'subdir' field of a source-repository is not a good relative path: " - ++ show err + "The 'subdir' field of a source-repository is not a good relative path: " + ++ show err ppExplanation (OptFasm fieldName) = - "'" ++ fieldName ++ ": -fasm' is unnecessary and will not work on CPU " - ++ "architectures other than x86, x86-64, ppc or sparc." + "'" + ++ fieldName + ++ ": -fasm' is unnecessary and will not work on CPU " + ++ "architectures other than x86, x86-64, ppc or sparc." ppExplanation (OptViaC fieldName) = - "'" ++ fieldName ++": -fvia-C' is usually unnecessary. If your package " - ++ "needs -via-C for correctness rather than performance then it " - ++ "is using the FFI incorrectly and will probably not work with GHC " - ++ "6.10 or later." + "'" + ++ fieldName + ++ ": -fvia-C' is usually unnecessary. If your package " + ++ "needs -via-C for correctness rather than performance then it " + ++ "is using the FFI incorrectly and will probably not work with GHC " + ++ "6.10 or later." ppExplanation (OptHpc fieldName) = - "'" ++ fieldName ++ ": -fhpc' is not necessary. Use the configure flag " - ++ " --enable-coverage instead." + "'" + ++ fieldName + ++ ": -fhpc' is not necessary. Use the configure flag " + ++ " --enable-coverage instead." ppExplanation (OptProf fieldName) = - "'" ++ fieldName ++ ": -prof' is not necessary and will lead to problems " - ++ "when used on a library. Use the configure flag " - ++ "--enable-library-profiling and/or --enable-profiling." + "'" + ++ fieldName + ++ ": -prof' is not necessary and will lead to problems " + ++ "when used on a library. Use the configure flag " + ++ "--enable-library-profiling and/or --enable-profiling." ppExplanation (OptO fieldName) = - "'" ++ fieldName ++ ": -o' is not needed. " - ++ "The output files are named automatically." + "'" + ++ fieldName + ++ ": -o' is not needed. " + ++ "The output files are named automatically." ppExplanation (OptHide fieldName) = - "'" ++ fieldName ++ ": -hide-package' is never needed. " - ++ "Cabal hides all packages." + "'" + ++ fieldName + ++ ": -hide-package' is never needed. " + ++ "Cabal hides all packages." ppExplanation (OptMake fieldName) = - "'" ++ fieldName - ++ ": --make' is never needed. Cabal uses this automatically." + "'" + ++ fieldName + ++ ": --make' is never needed. Cabal uses this automatically." ppExplanation (OptONot fieldName) = - "'" ++ fieldName ++ ": -O0' is not needed. " - ++ "Use the --disable-optimization configure flag." + "'" + ++ fieldName + ++ ": -O0' is not needed. " + ++ "Use the --disable-optimization configure flag." ppExplanation (OptOOne fieldName) = - "'" ++ fieldName ++ ": -O' is not needed. " - ++ "Cabal automatically adds the '-O' flag. " - ++ "Setting it yourself interferes with the --disable-optimization flag." + "'" + ++ fieldName + ++ ": -O' is not needed. " + ++ "Cabal automatically adds the '-O' flag. " + ++ "Setting it yourself interferes with the --disable-optimization flag." ppExplanation (OptOTwo fieldName) = - "'" ++ fieldName ++ ": -O2' is rarely needed. " - ++ "Check that it is giving a real benefit " - ++ "and not just imposing longer compile times on your users." + "'" + ++ fieldName + ++ ": -O2' is rarely needed. " + ++ "Check that it is giving a real benefit " + ++ "and not just imposing longer compile times on your users." ppExplanation (OptSplitSections fieldName) = - "'" ++ fieldName ++ ": -split-sections' is not needed. " - ++ "Use the --enable-split-sections configure flag." + "'" + ++ fieldName + ++ ": -split-sections' is not needed. " + ++ "Use the --enable-split-sections configure flag." ppExplanation (OptSplitObjs fieldName) = - "'" ++ fieldName ++ ": -split-objs' is not needed. " - ++ "Use the --enable-split-objs configure flag." + "'" + ++ fieldName + ++ ": -split-objs' is not needed. " + ++ "Use the --enable-split-objs configure flag." ppExplanation (OptWls fieldName) = - "'" ++ fieldName ++ ": -optl-Wl,-s' is not needed and is not portable to" - ++ " all operating systems. Cabal 1.4 and later automatically strip" - ++ " executables. Cabal also has a flag --disable-executable-stripping" - ++ " which is necessary when building packages for some Linux" - ++ " distributions and using '-optl-Wl,-s' prevents that from working." + "'" + ++ fieldName + ++ ": -optl-Wl,-s' is not needed and is not portable to" + ++ " all operating systems. Cabal 1.4 and later automatically strip" + ++ " executables. Cabal also has a flag --disable-executable-stripping" + ++ " which is necessary when building packages for some Linux" + ++ " distributions and using '-optl-Wl,-s' prevents that from working." ppExplanation (OptExts fieldName) = - "Instead of '" ++ fieldName ++ ": -fglasgow-exts' it is preferable to use " - ++ "the 'extensions' field." + "Instead of '" + ++ fieldName + ++ ": -fglasgow-exts' it is preferable to use " + ++ "the 'extensions' field." ppExplanation (OptRts fieldName) = - "'" ++ fieldName ++ ": -rtsopts' has no effect for libraries. It should " - ++ "only be used for executables." + "'" + ++ fieldName + ++ ": -rtsopts' has no effect for libraries. It should " + ++ "only be used for executables." ppExplanation (OptWithRts fieldName) = - "'" ++ fieldName ++ ": -with-rtsopts' has no effect for libraries. It " - ++ "should only be used for executables." + "'" + ++ fieldName + ++ ": -with-rtsopts' has no effect for libraries. It " + ++ "should only be used for executables." ppExplanation (COptONumber prefix label) = - "'" ++ prefix ++": -O[n]' is generally not needed. When building with " - ++ " optimisations Cabal automatically adds '-O2' for " ++ - ppWarnLang label ++ " code. Setting it yourself interferes with the" - ++ " --disable-optimization flag." + "'" + ++ prefix + ++ ": -O[n]' is generally not needed. When building with " + ++ " optimisations Cabal automatically adds '-O2' for " + ++ ppWarnLang label + ++ " code. Setting it yourself interferes with the" + ++ " --disable-optimization flag." ppExplanation (COptCPP opt) = - "'cpp-options: " ++ opt ++ "' is not a portable C-preprocessor flag." + "'cpp-options: " ++ opt ++ "' is not a portable C-preprocessor flag." ppExplanation (OptAlternatives badField goodField flags) = - "Instead of " ++ quote (badField ++ ": " ++ unwords badFlags) - ++ " use " ++ quote (goodField ++ ": " ++ unwords goodFlags) - where (badFlags, goodFlags) = unzip flags + "Instead of " + ++ quote (badField ++ ": " ++ unwords badFlags) + ++ " use " + ++ quote (goodField ++ ": " ++ unwords goodFlags) + where + (badFlags, goodFlags) = unzip flags ppExplanation (RelativeOutside field path) = - quote (field ++ ": " ++ path) - ++ " is a relative path outside of the source tree. " - ++ "This will not work when generating a tarball with 'sdist'." + quote (field ++ ": " ++ path) + ++ " is a relative path outside of the source tree. " + ++ "This will not work when generating a tarball with 'sdist'." ppExplanation (AbsolutePath field path) = - quote (field ++ ": " ++ path) ++ " specifies an absolute path, but the " - ++ quote field ++ " field must use relative paths." + quote (field ++ ": " ++ path) + ++ " specifies an absolute path, but the " + ++ quote field + ++ " field must use relative paths." ppExplanation (BadRelativePath field path err) = - quote (field ++ ": " ++ path) - ++ " is not a good relative path: " ++ show err + quote (field ++ ": " ++ path) + ++ " is not a good relative path: " + ++ show err ppExplanation (DistPoint mfield path) = - incipit ++ " points inside the 'dist' " - ++ "directory. This is not reliable because the location of this " - ++ "directory is configurable by the user (or package manager). In " - ++ "addition the layout of the 'dist' directory is subject to change " - ++ "in future versions of Cabal." - where -- mfiled Nothing -> the path is inside `ghc-options` - incipit = maybe ("'ghc-options' path " ++ quote path) - (\field -> quote (field ++ ": " ++ path)) - mfield + incipit + ++ " points inside the 'dist' " + ++ "directory. This is not reliable because the location of this " + ++ "directory is configurable by the user (or package manager). In " + ++ "addition the layout of the 'dist' directory is subject to change " + ++ "in future versions of Cabal." + where + -- mfiled Nothing -> the path is inside `ghc-options` + incipit = + maybe + ("'ghc-options' path " ++ quote path) + (\field -> quote (field ++ ": " ++ path)) + mfield ppExplanation (GlobSyntaxError field expl) = - "In the '" ++ field ++ "' field: " ++ expl + "In the '" ++ field ++ "' field: " ++ expl ppExplanation (RecursiveGlobInRoot field glob) = - "In the '" ++ field ++ "': glob '" ++ glob + "In the '" + ++ field + ++ "': glob '" + ++ glob ++ "' starts at project root directory, this might " ++ "include `.git/`, ``dist-newstyle/``, or other large directories!" ppExplanation (InvalidOnWin paths) = - "The " ++ quotes paths ++ " invalid on Windows, which " - ++ "would cause portability problems for this package. Windows file " - ++ "names cannot contain any of the characters \":*?<>|\" and there " - ++ "a few reserved names including \"aux\", \"nul\", \"con\", " - ++ "\"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"." - where quotes [failed] = "path " ++ quote failed ++ " is" - quotes failed = "paths " ++ commaSep (map quote failed) - ++ " are" + "The " + ++ quotes paths + ++ " invalid on Windows, which " + ++ "would cause portability problems for this package. Windows file " + ++ "names cannot contain any of the characters \":*?<>|\" and there " + ++ "a few reserved names including \"aux\", \"nul\", \"con\", " + ++ "\"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"." + where + quotes [failed] = "path " ++ quote failed ++ " is" + quotes failed = + "paths " + ++ commaSep (map quote failed) + ++ " are" ppExplanation (FilePathTooLong path) = - "The following file name is too long to store in a portable POSIX " - ++ "format tar archive. The maximum length is 255 ASCII characters.\n" - ++ "The file in question is:\n " ++ path + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. The maximum length is 255 ASCII characters.\n" + ++ "The file in question is:\n " + ++ path ppExplanation (FilePathNameTooLong path) = - "The following file name is too long to store in a portable POSIX " - ++ "format tar archive. The maximum length for the name part (including " - ++ "extension) is 100 ASCII characters. The maximum length for any " - ++ "individual directory component is 155.\n" - ++ "The file in question is:\n " ++ path + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. The maximum length for the name part (including " + ++ "extension) is 100 ASCII characters. The maximum length for any " + ++ "individual directory component is 155.\n" + ++ "The file in question is:\n " + ++ path ppExplanation (FilePathSplitTooLong path) = - "The following file name is too long to store in a portable POSIX " - ++ "format tar archive. While the total length is less than 255 ASCII " - ++ "characters, there are unfortunately further restrictions. It has to " - ++ "be possible to split the file path on a directory separator into " - ++ "two parts such that the first part fits in 155 characters or less " - ++ "and the second part fits in 100 characters or less. Basically you " - ++ "have to make the file name or directory names shorter, or you could " - ++ "split a long directory name into nested subdirectories with shorter " - ++ "names.\nThe file in question is:\n " ++ path + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. While the total length is less than 255 ASCII " + ++ "characters, there are unfortunately further restrictions. It has to " + ++ "be possible to split the file path on a directory separator into " + ++ "two parts such that the first part fits in 155 characters or less " + ++ "and the second part fits in 100 characters or less. Basically you " + ++ "have to make the file name or directory names shorter, or you could " + ++ "split a long directory name into nested subdirectories with shorter " + ++ "names.\nThe file in question is:\n " + ++ path ppExplanation FilePathEmpty = - "Encountered a file with an empty name, something is very wrong! " - ++ "Files with an empty name cannot be stored in a tar archive or in " - ++ "standard file systems." + "Encountered a file with an empty name, something is very wrong! " + ++ "Files with an empty name cannot be stored in a tar archive or in " + ++ "standard file systems." ppExplanation CVTestSuite = - "The 'test-suite' section is new in Cabal 1.10. " - ++ "Unfortunately it messes up the parser in older Cabal versions " - ++ "so you must specify at least 'cabal-version: >= 1.8', but note " - ++ "that only Cabal 1.10 and later can actually run such test suites." + "The 'test-suite' section is new in Cabal 1.10. " + ++ "Unfortunately it messes up the parser in older Cabal versions " + ++ "so you must specify at least 'cabal-version: >= 1.8', but note " + ++ "that only Cabal 1.10 and later can actually run such test suites." ppExplanation CVDefaultLanguage = - "To use the 'default-language' field the package needs to specify " - ++ "at least 'cabal-version: >= 1.10'." + "To use the 'default-language' field the package needs to specify " + ++ "at least 'cabal-version: >= 1.10'." ppExplanation CVDefaultLanguageComponent = - "Packages using 'cabal-version: >= 1.10' and before 'cabal-version: 3.4' " - ++ "must specify the 'default-language' field for each component (e.g. " - ++ "Haskell98 or Haskell2010). If a component uses different languages " - ++ "in different modules then list the other ones in the " - ++ "'other-languages' field." + "Packages using 'cabal-version: >= 1.10' and before 'cabal-version: 3.4' " + ++ "must specify the 'default-language' field for each component (e.g. " + ++ "Haskell98 or Haskell2010). If a component uses different languages " + ++ "in different modules then list the other ones in the " + ++ "'other-languages' field." ppExplanation CVExtraDocFiles = - "To use the 'extra-doc-files' field the package needs to specify " - ++ "'cabal-version: 1.18' or higher." + "To use the 'extra-doc-files' field the package needs to specify " + ++ "'cabal-version: 1.18' or higher." ppExplanation CVMultiLib = - "To use multiple 'library' sections or a named library section " - ++ "the package needs to specify at least 'cabal-version: 2.0'." + "To use multiple 'library' sections or a named library section " + ++ "the package needs to specify at least 'cabal-version: 2.0'." ppExplanation CVReexported = - "To use the 'reexported-module' field the package needs to specify " - ++ "'cabal-version: 1.22' or higher." + "To use the 'reexported-module' field the package needs to specify " + ++ "'cabal-version: 1.22' or higher." ppExplanation CVMixins = - "To use the 'mixins' field the package needs to specify " - ++ "at least 'cabal-version: 2.0'." + "To use the 'mixins' field the package needs to specify " + ++ "at least 'cabal-version: 2.0'." ppExplanation CVExtraFrameworkDirs = - "To use the 'extra-framework-dirs' field the package needs to specify" - ++ " 'cabal-version: 1.24' or higher." + "To use the 'extra-framework-dirs' field the package needs to specify" + ++ " 'cabal-version: 1.24' or higher." ppExplanation CVDefaultExtensions = - "To use the 'default-extensions' field the package needs to specify " - ++ "at least 'cabal-version: >= 1.10'." + "To use the 'default-extensions' field the package needs to specify " + ++ "at least 'cabal-version: >= 1.10'." ppExplanation CVExtensionsDeprecated = - "For packages using 'cabal-version: >= 1.10' the 'extensions' " - ++ "field is deprecated. The new 'default-extensions' field lists " - ++ "extensions that are used in all modules in the component, while " - ++ "the 'other-extensions' field lists extensions that are used in " - ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma." + "For packages using 'cabal-version: >= 1.10' the 'extensions' " + ++ "field is deprecated. The new 'default-extensions' field lists " + ++ "extensions that are used in all modules in the component, while " + ++ "the 'other-extensions' field lists extensions that are used in " + ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma." ppExplanation CVSources = - "The use of 'asm-sources', 'cmm-sources', 'extra-bundled-libraries' " - ++ " and 'extra-library-flavours' requires the package " - ++ " to specify at least 'cabal-version: 3.0'." + "The use of 'asm-sources', 'cmm-sources', 'extra-bundled-libraries' " + ++ " and 'extra-library-flavours' requires the package " + ++ " to specify at least 'cabal-version: 3.0'." ppExplanation (CVExtraDynamic flavs) = - "The use of 'extra-dynamic-library-flavours' requires the package " - ++ " to specify at least 'cabal-version: 3.0'. The flavours are: " - ++ commaSep (concat flavs) + "The use of 'extra-dynamic-library-flavours' requires the package " + ++ " to specify at least 'cabal-version: 3.0'. The flavours are: " + ++ commaSep (concat flavs) ppExplanation CVVirtualModules = - "The use of 'virtual-modules' requires the package " - ++ " to specify at least 'cabal-version: 2.2'." + "The use of 'virtual-modules' requires the package " + ++ " to specify at least 'cabal-version: 2.2'." ppExplanation CVSourceRepository = - "The 'source-repository' section is new in Cabal 1.6. " - ++ "Unfortunately it messes up the parser in earlier Cabal versions " - ++ "so you need to specify 'cabal-version: >= 1.6'." + "The 'source-repository' section is new in Cabal 1.6. " + ++ "Unfortunately it messes up the parser in earlier Cabal versions " + ++ "so you need to specify 'cabal-version: >= 1.6'." ppExplanation (CVExtensions version extCab12) = - "Unfortunately the language extensions " - ++ commaSep (map (quote . prettyShow) extCab12) - ++ " break the parser in earlier Cabal versions so you need to " - ++ "specify 'cabal-version: >= " ++ showCabalSpecVersion version - ++ "'. Alternatively if you require compatibility with earlier " - ++ "Cabal versions then you may be able to use an equivalent " - ++ "compiler-specific flag." + "Unfortunately the language extensions " + ++ commaSep (map (quote . prettyShow) extCab12) + ++ " break the parser in earlier Cabal versions so you need to " + ++ "specify 'cabal-version: >= " + ++ showCabalSpecVersion version + ++ "'. Alternatively if you require compatibility with earlier " + ++ "Cabal versions then you may be able to use an equivalent " + ++ "compiler-specific flag." ppExplanation CVCustomSetup = - "Packages using 'cabal-version: 1.24' or higher with 'build-type: Custom' " - ++ "must use a 'custom-setup' section with a 'setup-depends' field " - ++ "that specifies the dependencies of the Setup.hs script itself. " - ++ "The 'setup-depends' field uses the same syntax as 'build-depends', " - ++ "so a simple example would be 'setup-depends: base, Cabal'." + "Packages using 'cabal-version: 1.24' or higher with 'build-type: Custom' " + ++ "must use a 'custom-setup' section with a 'setup-depends' field " + ++ "that specifies the dependencies of the Setup.hs script itself. " + ++ "The 'setup-depends' field uses the same syntax as 'build-depends', " + ++ "so a simple example would be 'setup-depends: base, Cabal'." ppExplanation CVExpliticDepsCustomSetup = - "From version 1.24 cabal supports specifying explicit dependencies " - ++ "for Custom setup scripts. Consider using 'cabal-version: 1.24' or " - ++ "higher and adding a 'custom-setup' section with a 'setup-depends' " - ++ "field that specifies the dependencies of the Setup.hs script " - ++ "itself. The 'setup-depends' field uses the same syntax as " - ++ "'build-depends', so a simple example would be 'setup-depends: base, " - ++ "Cabal'." + "From version 1.24 cabal supports specifying explicit dependencies " + ++ "for Custom setup scripts. Consider using 'cabal-version: 1.24' or " + ++ "higher and adding a 'custom-setup' section with a 'setup-depends' " + ++ "field that specifies the dependencies of the Setup.hs script " + ++ "itself. The 'setup-depends' field uses the same syntax as " + ++ "'build-depends', so a simple example would be 'setup-depends: base, " + ++ "Cabal'." ppExplanation CVAutogenPaths = - "Packages using 'cabal-version: 2.0' and the autogenerated " - ++ "module Paths_* must include it also on the 'autogen-modules' field " - ++ "besides 'exposed-modules' and 'other-modules'. This specifies that " - ++ "the module does not come with the package and is generated on " - ++ "setup. Modules built with a custom Setup.hs script also go here " - ++ "to ensure that commands like sdist don't fail." + "Packages using 'cabal-version: 2.0' and the autogenerated " + ++ "module Paths_* must include it also on the 'autogen-modules' field " + ++ "besides 'exposed-modules' and 'other-modules'. This specifies that " + ++ "the module does not come with the package and is generated on " + ++ "setup. Modules built with a custom Setup.hs script also go here " + ++ "to ensure that commands like sdist don't fail." ppExplanation CVAutogenPackageInfo = - "Packages using 'cabal-version: 2.0' and the autogenerated " - ++ "module PackageInfo_* must include it in 'autogen-modules' as well as" - ++ " 'exposed-modules' and 'other-modules'. This specifies that " - ++ "the module does not come with the package and is generated on " - ++ "setup. Modules built with a custom Setup.hs script also go here " - ++ "to ensure that commands like sdist don't fail." + "Packages using 'cabal-version: 2.0' and the autogenerated " + ++ "module PackageInfo_* must include it in 'autogen-modules' as well as" + ++ " 'exposed-modules' and 'other-modules'. This specifies that " + ++ "the module does not come with the package and is generated on " + ++ "setup. Modules built with a custom Setup.hs script also go here " + ++ "to ensure that commands like sdist don't fail." ppExplanation (GlobNoMatch field glob) = - "In '" ++ field ++ "': the pattern '" ++ glob ++ "' does not" - ++ " match any files." + "In '" + ++ field + ++ "': the pattern '" + ++ glob + ++ "' does not" + ++ " match any files." ppExplanation (GlobExactMatch field glob file) = - "In '" ++ field ++ "': the pattern '" ++ glob ++ "' does not" - ++ " match the file '" ++ file ++ "' because the extensions do not" - ++ " exactly match (e.g., foo.en.html does not exactly match *.html)." - ++ " To enable looser suffix-only matching, set 'cabal-version: 2.4' or" - ++ " higher." + "In '" + ++ field + ++ "': the pattern '" + ++ glob + ++ "' does not" + ++ " match the file '" + ++ file + ++ "' because the extensions do not" + ++ " exactly match (e.g., foo.en.html does not exactly match *.html)." + ++ " To enable looser suffix-only matching, set 'cabal-version: 2.4' or" + ++ " higher." ppExplanation (GlobNoDir field glob dir) = - "In '" ++ field ++ "': the pattern '" ++ glob ++ "' attempts to" - ++ " match files in the directory '" ++ dir ++ "', but there is no" - ++ " directory by that name." + "In '" + ++ field + ++ "': the pattern '" + ++ glob + ++ "' attempts to" + ++ " match files in the directory '" + ++ dir + ++ "', but there is no" + ++ " directory by that name." ppExplanation (UnknownOS unknownOSs) = - "Unknown operating system name " ++ commaSep (map quote unknownOSs) + "Unknown operating system name " ++ commaSep (map quote unknownOSs) ppExplanation (UnknownArch unknownArches) = - "Unknown architecture name " ++ commaSep (map quote unknownArches) + "Unknown architecture name " ++ commaSep (map quote unknownArches) ppExplanation (UnknownCompiler unknownImpls) = - "Unknown compiler name " ++ commaSep (map quote unknownImpls) + "Unknown compiler name " ++ commaSep (map quote unknownImpls) ppExplanation BaseNoUpperBounds = - "The dependency 'build-depends: base' does not specify an upper " - ++ "bound on the version number. Each major release of the 'base' " - ++ "package changes the API in various ways and most packages will " - ++ "need some changes to compile with it. The recommended practice " - ++ "is to specify an upper bound on the version of the 'base' " - ++ "package. This ensures your package will continue to build when a " - ++ "new major version of the 'base' package is released. If you are " - ++ "not sure what upper bound to use then use the next major " - ++ "version. For example if you have tested your package with 'base' " - ++ "version 4.5 and 4.6 then use 'build-depends: base >= 4.5 && < 4.7'." + "The dependency 'build-depends: base' does not specify an upper " + ++ "bound on the version number. Each major release of the 'base' " + ++ "package changes the API in various ways and most packages will " + ++ "need some changes to compile with it. The recommended practice " + ++ "is to specify an upper bound on the version of the 'base' " + ++ "package. This ensures your package will continue to build when a " + ++ "new major version of the 'base' package is released. If you are " + ++ "not sure what upper bound to use then use the next major " + ++ "version. For example if you have tested your package with 'base' " + ++ "version 4.5 and 4.6 then use 'build-depends: base >= 4.5 && < 4.7'." ppExplanation (MissingUpperBounds ct names) = - let separator = "\n - " in - "On " ++ ppCET ct ++ ", " ++ - "these packages miss upper bounds:" ++ separator - ++ List.intercalate separator names ++ "\n" - ++ "Please add them. More informations at https://pvp.haskell.org/" + let separator = "\n - " + in "On " + ++ ppCET ct + ++ ", " + ++ "these packages miss upper bounds:" + ++ separator + ++ List.intercalate separator names + ++ "\n" + ++ "Please add them. More informations at https://pvp.haskell.org/" ppExplanation (SuspiciousFlagName invalidFlagNames) = - "Suspicious flag names: " ++ unwords invalidFlagNames ++ ". " - ++ "To avoid ambiguity in command line interfaces, flag shouldn't " - ++ "start with a dash. Also for better compatibility, flag names " - ++ "shouldn't contain non-ascii characters." + "Suspicious flag names: " + ++ unwords invalidFlagNames + ++ ". " + ++ "To avoid ambiguity in command line interfaces, flag shouldn't " + ++ "start with a dash. Also for better compatibility, flag names " + ++ "shouldn't contain non-ascii characters." ppExplanation (DeclaredUsedFlags declared used) = - "Declared and used flag sets differ: " - ++ s declared ++ " /= " ++ s used ++ ". " - where s :: Set.Set FlagName -> String - s = commaSep . map unFlagName . Set.toList + "Declared and used flag sets differ: " + ++ s declared + ++ " /= " + ++ s used + ++ ". " + where + s :: Set.Set FlagName -> String + s = commaSep . map unFlagName . Set.toList ppExplanation (NonASCIICustomField nonAsciiXFields) = - "Non ascii custom fields: " ++ unwords nonAsciiXFields ++ ". " - ++ "For better compatibility, custom field names " - ++ "shouldn't contain non-ascii characters." + "Non ascii custom fields: " + ++ unwords nonAsciiXFields + ++ ". " + ++ "For better compatibility, custom field names " + ++ "shouldn't contain non-ascii characters." ppExplanation RebindableClashPaths = - "Packages using RebindableSyntax with OverloadedStrings or" - ++ " OverloadedLists in default-extensions, in conjunction with the" - ++ " autogenerated module Paths_*, are known to cause compile failures" - ++ " with Cabal < 2.2. To use these default-extensions with a Paths_*" - ++ " autogen module, specify at least 'cabal-version: 2.2'." + "Packages using RebindableSyntax with OverloadedStrings or" + ++ " OverloadedLists in default-extensions, in conjunction with the" + ++ " autogenerated module Paths_*, are known to cause compile failures" + ++ " with Cabal < 2.2. To use these default-extensions with a Paths_*" + ++ " autogen module, specify at least 'cabal-version: 2.2'." ppExplanation RebindableClashPackageInfo = - "Packages using RebindableSyntax with OverloadedStrings or" - ++ " OverloadedLists in default-extensions, in conjunction with the" - ++ " autogenerated module PackageInfo_*, are known to cause compile failures" - ++ " with Cabal < 2.2. To use these default-extensions with a PackageInfo_*" - ++ " autogen module, specify at least 'cabal-version: 2.2'." -ppExplanation (WErrorUnneeded fieldName) = addConditionalExp $ - "'" ++ fieldName ++ ": -Werror' makes the package easy to " + "Packages using RebindableSyntax with OverloadedStrings or" + ++ " OverloadedLists in default-extensions, in conjunction with the" + ++ " autogenerated module PackageInfo_*, are known to cause compile failures" + ++ " with Cabal < 2.2. To use these default-extensions with a PackageInfo_*" + ++ " autogen module, specify at least 'cabal-version: 2.2'." +ppExplanation (WErrorUnneeded fieldName) = + addConditionalExp $ + "'" + ++ fieldName + ++ ": -Werror' makes the package easy to " ++ "break with future GHC versions because new GHC versions often " ++ "add new warnings." -ppExplanation (JUnneeded fieldName) = addConditionalExp $ - "'" ++ fieldName ++ ": -j[N]' can make sense for specific user's setup," +ppExplanation (JUnneeded fieldName) = + addConditionalExp $ + "'" + ++ fieldName + ++ ": -j[N]' can make sense for specific user's setup," ++ " but it is not appropriate for a distributed package." -ppExplanation (FDeferTypeErrorsUnneeded fieldName) = addConditionalExp $ - "'" ++ fieldName ++ ": -fdefer-type-errors' is fine during development " +ppExplanation (FDeferTypeErrorsUnneeded fieldName) = + addConditionalExp $ + "'" + ++ fieldName + ++ ": -fdefer-type-errors' is fine during development " ++ "but is not appropriate for a distributed package." -ppExplanation (DynamicUnneeded fieldName) = addConditionalExp $ - "'" ++ fieldName ++ ": -d*' debug flags are not appropriate " +ppExplanation (DynamicUnneeded fieldName) = + addConditionalExp $ + "'" + ++ fieldName + ++ ": -d*' debug flags are not appropriate " ++ "for a distributed package." -ppExplanation (ProfilingUnneeded fieldName) = addConditionalExp $ - "'" ++ fieldName ++ ": -fprof*' profiling flags are typically not " +ppExplanation (ProfilingUnneeded fieldName) = + addConditionalExp $ + "'" + ++ fieldName + ++ ": -fprof*' profiling flags are typically not " ++ "appropriate for a distributed library package. These flags are " ++ "useful to profile this package, but when profiling other packages " ++ "that use this one these flags clutter the profile output with " @@ -801,65 +913,93 @@ ppExplanation (ProfilingUnneeded fieldName) = addConditionalExp $ ++ "cost centres from this package then use '-fprof-auto-exported' " ++ "which puts cost centres only on exported functions." ppExplanation (UpperBoundSetup nm) = - "The dependency 'setup-depends: '"++nm++"' does not specify an " - ++ "upper bound on the version number. Each major release of the " - ++ "'"++nm++"' package changes the API in various ways and most " - ++ "packages will need some changes to compile with it. If you are " - ++ "not sure what upper bound to use then use the next major " - ++ "version." + "The dependency 'setup-depends: '" + ++ nm + ++ "' does not specify an " + ++ "upper bound on the version number. Each major release of the " + ++ "'" + ++ nm + ++ "' package changes the API in various ways and most " + ++ "packages will need some changes to compile with it. If you are " + ++ "not sure what upper bound to use then use the next major " + ++ "version." ppExplanation (DuplicateModule s dupLibsLax) = - "Duplicate modules in " ++ s ++ ": " - ++ commaSep (map prettyShow dupLibsLax) + "Duplicate modules in " + ++ s + ++ ": " + ++ commaSep (map prettyShow dupLibsLax) ppExplanation (PotentialDupModule s dupLibsStrict) = - "Potential duplicate modules (subject to conditionals) in " ++ s - ++ ": " ++ commaSep (map prettyShow dupLibsStrict) + "Potential duplicate modules (subject to conditionals) in " + ++ s + ++ ": " + ++ commaSep (map prettyShow dupLibsStrict) ppExplanation (BOMStart pdfile) = - pdfile ++ " starts with an Unicode byte order mark (BOM)." - ++ " This may cause problems with older cabal versions." + pdfile + ++ " starts with an Unicode byte order mark (BOM)." + ++ " This may cause problems with older cabal versions." ppExplanation (NotPackageName pdfile expectedCabalname) = - "The filename " ++ quote pdfile ++ " does not match package name " - ++ "(expected: " ++ quote expectedCabalname ++ ")" + "The filename " + ++ quote pdfile + ++ " does not match package name " + ++ "(expected: " + ++ quote expectedCabalname + ++ ")" ppExplanation NoDesc = - "No cabal file found.\n" - ++ "Please create a package description file .cabal" + "No cabal file found.\n" + ++ "Please create a package description file .cabal" ppExplanation (MultiDesc multiple) = - "Multiple cabal files found while checking.\n" - ++ "Please use only one of: " - ++ commaSep multiple + "Multiple cabal files found while checking.\n" + ++ "Please use only one of: " + ++ commaSep multiple ppExplanation (UnknownFile fieldname file) = - "The '" ++ fieldname ++ "' field refers to the file " - ++ quote (getSymbolicPath file) ++ " which does not exist." + "The '" + ++ fieldname + ++ "' field refers to the file " + ++ quote (getSymbolicPath file) + ++ " which does not exist." ppExplanation MissingSetupFile = - "The package is missing a Setup.hs or Setup.lhs script." + "The package is missing a Setup.hs or Setup.lhs script." ppExplanation MissingConfigureScript = - "The 'build-type' is 'Configure' but there is no 'configure' script. " - ++ "You probably need to run 'autoreconf -i' to generate it." + "The 'build-type' is 'Configure' but there is no 'configure' script. " + ++ "You probably need to run 'autoreconf -i' to generate it." ppExplanation (UnknownDirectory kind dir) = - quote (kind ++ ": " ++ dir) - ++ " specifies a directory which does not exist." + quote (kind ++ ": " ++ dir) + ++ " specifies a directory which does not exist." ppExplanation MissingSourceControl = - "When distributing packages it is encouraged to specify source " - ++ "control information in the .cabal file using one or more " - ++ "'source-repository' sections. See the Cabal user guide for " - ++ "details." + "When distributing packages it is encouraged to specify source " + ++ "control information in the .cabal file using one or more " + ++ "'source-repository' sections. See the Cabal user guide for " + ++ "details." ppExplanation (MissingExpectedDocFiles extraDocFileSupport paths) = - "Please consider including the " ++ quotes paths - ++ " in the '" ++ targetField ++ "' section of the .cabal file " - ++ "if it contains useful information for users of the package." - where quotes [p] = "file " ++ quote p - quotes ps = "files " ++ commaSep (map quote ps) - targetField = if extraDocFileSupport - then "extra-doc-files" - else "extra-source-files" + "Please consider including the " + ++ quotes paths + ++ " in the '" + ++ targetField + ++ "' section of the .cabal file " + ++ "if it contains useful information for users of the package." + where + quotes [p] = "file " ++ quote p + quotes ps = "files " ++ commaSep (map quote ps) + targetField = + if extraDocFileSupport + then "extra-doc-files" + else "extra-source-files" ppExplanation (WrongFieldForExpectedDocFiles extraDocFileSupport field paths) = - "Please consider moving the " ++ quotes paths - ++ " from the '" ++ field ++ "' section of the .cabal file " - ++ "to the section '" ++ targetField ++ "'." - where quotes [p] = "file " ++ quote p - quotes ps = "files " ++ commaSep (map quote ps) - targetField = if extraDocFileSupport - then "extra-doc-files" - else "extra-source-files" + "Please consider moving the " + ++ quotes paths + ++ " from the '" + ++ field + ++ "' section of the .cabal file " + ++ "to the section '" + ++ targetField + ++ "'." + where + quotes [p] = "file " ++ quote p + quotes ps = "files " ++ commaSep (map quote ps) + targetField = + if extraDocFileSupport + then "extra-doc-files" + else "extra-source-files" -- * Formatting utilities @@ -870,8 +1010,8 @@ quote :: String -> String quote s = "'" ++ s ++ "'" addConditionalExp :: String -> String -addConditionalExp expl = expl ++ - " Alternatively, if you want to use this, make it conditional based " - ++ "on a Cabal configuration flag (with 'manual: True' and 'default: " - ++ "False') and enable that flag during development." - +addConditionalExp expl = + expl + ++ " Alternatively, if you want to use this, make it conditional based " + ++ "on a Cabal configuration flag (with 'manual: True' and 'default: " + ++ "False') and enable that flag during development." diff --git a/Cabal/src/Distribution/Simple/BuildToolDepends.hs b/Cabal/src/Distribution/Simple/BuildToolDepends.hs index 25bbf960ed6..01592a0970e 100644 --- a/Cabal/src/Distribution/Simple/BuildToolDepends.hs +++ b/Cabal/src/Distribution/Simple/BuildToolDepends.hs @@ -15,20 +15,29 @@ import Distribution.PackageDescription -- | Same as 'desugarBuildTool', but requires atomic informations (package -- name, executable names) instead of a whole 'PackageDescription'. -desugarBuildToolSimple :: PackageName - -> [UnqualComponentName] - -> LegacyExeDependency - -> Maybe ExeDependency +desugarBuildToolSimple + :: PackageName + -> [UnqualComponentName] + -> LegacyExeDependency + -> Maybe ExeDependency desugarBuildToolSimple pname exeNames (LegacyExeDependency name reqVer) - | foundLocal = Just $ ExeDependency pname toolName reqVer - | otherwise = Map.lookup name allowMap + | foundLocal = Just $ ExeDependency pname toolName reqVer + | otherwise = Map.lookup name allowMap where toolName = mkUnqualComponentName name foundLocal = toolName `elem` exeNames - allowlist = [ "hscolour", "haddock", "happy", "alex", "hsc2hs", "c2hs" - , "cpphs", "greencard", "hspec-discover" - ] - allowMap = Map.fromList $ flip map allowlist $ \n -> + allowlist = + [ "hscolour" + , "haddock" + , "happy" + , "alex" + , "hsc2hs" + , "c2hs" + , "cpphs" + , "greencard" + , "hspec-discover" + ] + allowMap = Map.fromList $ flip map allowlist $ \n -> (n, ExeDependency (mkPackageName n) (mkUnqualComponentName n) reqVer) -- | Desugar a "build-tools" entry into a proper executable dependency if @@ -48,10 +57,11 @@ desugarBuildTool :: PackageDescription -> LegacyExeDependency -> Maybe ExeDependency -desugarBuildTool pkg led = desugarBuildToolSimple - (packageName pkg) - (map exeName $ executables pkg) - led +desugarBuildTool pkg led = + desugarBuildToolSimple + (packageName pkg) + (map exeName $ executables pkg) + led -- | Get everything from "build-tool-depends", along with entries from -- "build-tools" that we know how to desugar. diff --git a/cabal-install/src/Distribution/Client/Check.hs b/cabal-install/src/Distribution/Client/Check.hs index 4d63dea5ddc..3a359bfb6b2 100644 --- a/cabal-install/src/Distribution/Client/Check.hs +++ b/cabal-install/src/Distribution/Client/Check.hs @@ -84,34 +84,35 @@ check verbosity = do -- Poor man’s “group checks by constructor”. groupChecks :: [PackageCheck] -> [NE.NonEmpty PackageCheck] -groupChecks ds = NE.groupBy (F.on (==) constInt) - (L.sortBy (F.on compare constInt) ds) - where - constInt :: PackageCheck -> Int - constInt (PackageBuildImpossible {}) = 0 - constInt (PackageBuildWarning {}) = 1 - constInt (PackageDistSuspicious {}) = 2 - constInt (PackageDistSuspiciousWarn {}) = 3 - constInt (PackageDistInexcusable {}) = 4 +groupChecks ds = + NE.groupBy + (F.on (==) constInt) + (L.sortBy (F.on compare constInt) ds) + where + constInt :: PackageCheck -> Int + constInt (PackageBuildImpossible{}) = 0 + constInt (PackageBuildWarning{}) = 1 + constInt (PackageDistSuspicious{}) = 2 + constInt (PackageDistSuspiciousWarn{}) = 3 + constInt (PackageDistInexcusable{}) = 4 groupExplanation :: PackageCheck -> String -groupExplanation (PackageBuildImpossible {}) = "The package will not build sanely due to these errors:" -groupExplanation (PackageBuildWarning {}) = "The following errors are likely to affect your build negatively:" -groupExplanation (PackageDistSuspicious {}) = "These warnings will likely cause trouble when distributing the package:" -groupExplanation (PackageDistSuspiciousWarn {}) = "These warnings may cause trouble when distributing the package:" -groupExplanation (PackageDistInexcusable {}) = "The following errors will cause portability problems on other environments:" +groupExplanation (PackageBuildImpossible{}) = "The package will not build sanely due to these errors:" +groupExplanation (PackageBuildWarning{}) = "The following errors are likely to affect your build negatively:" +groupExplanation (PackageDistSuspicious{}) = "These warnings will likely cause trouble when distributing the package:" +groupExplanation (PackageDistSuspiciousWarn{}) = "These warnings may cause trouble when distributing the package:" +groupExplanation (PackageDistInexcusable{}) = "The following errors will cause portability problems on other environments:" groupOutputFunction :: PackageCheck -> Verbosity -> String -> IO () -groupOutputFunction (PackageBuildImpossible {}) ver = warnError ver -groupOutputFunction (PackageBuildWarning {}) ver = warnError ver -groupOutputFunction (PackageDistSuspicious {}) ver = warn ver -groupOutputFunction (PackageDistSuspiciousWarn {}) ver = warn ver -groupOutputFunction (PackageDistInexcusable {}) ver = warnError ver +groupOutputFunction (PackageBuildImpossible{}) ver = warnError ver +groupOutputFunction (PackageBuildWarning{}) ver = warnError ver +groupOutputFunction (PackageDistSuspicious{}) ver = warn ver +groupOutputFunction (PackageDistSuspiciousWarn{}) ver = warn ver +groupOutputFunction (PackageDistInexcusable{}) ver = warnError ver outputGroupCheck :: Verbosity -> NE.NonEmpty PackageCheck -> IO () outputGroupCheck ver pcs = do - let hp = NE.head pcs - outf = groupOutputFunction hp ver - notice ver (groupExplanation hp) - CM.mapM_ (outf . ppPackageCheck) pcs - + let hp = NE.head pcs + outf = groupOutputFunction hp ver + notice ver (groupExplanation hp) + CM.mapM_ (outf . ppPackageCheck) pcs