diff --git a/Cabal-tests/tests/CheckTests.hs b/Cabal-tests/tests/CheckTests.hs index b9b5d6d94f2..2de1de6bfb7 100644 --- a/Cabal-tests/tests/CheckTests.hs +++ b/Cabal-tests/tests/CheckTests.hs @@ -68,7 +68,7 @@ checkTest fp = cabalGoldenTest fp correct $ do -- Note: parser warnings are reported by `cabal check`, but not by -- D.PD.Check functionality. unlines (map (showPWarning fp) ws) ++ - unlines (map show (checkPackage gpd Nothing)) + unlines (map show (checkPackage gpd)) Left (_, errs) -> unlines $ map (("ERROR: " ++) . showPError fp) $ NE.toList errs where input = "tests" "ParserTests" "regressions" fp diff --git a/Cabal-tests/tests/HackageTests.hs b/Cabal-tests/tests/HackageTests.hs index b33179f724e..c56420b7960 100644 --- a/Cabal-tests/tests/HackageTests.hs +++ b/Cabal-tests/tests/HackageTests.hs @@ -185,7 +185,7 @@ parseCheckTest fpath bs = do Parsec.parseGenericPackageDescription bs case parsec of Right gpd -> do - let checks = checkPackage gpd Nothing + let checks = checkPackage gpd let w [] = 0 w _ = 1 diff --git a/Cabal-tests/tests/ParserTests/regressions/bad-glob-syntax.check b/Cabal-tests/tests/ParserTests/regressions/bad-glob-syntax.check index 5b7a0a12552..5f52530791f 100644 --- a/Cabal-tests/tests/ParserTests/regressions/bad-glob-syntax.check +++ b/Cabal-tests/tests/ParserTests/regressions/bad-glob-syntax.check @@ -1,2 +1,2 @@ -In the 'extra-source-files' field: invalid file glob 'foo/blah-*.hs'. Wildcards '*' may only totally replace the file's base name, not only parts of it. In the 'extra-source-files' field: invalid file glob 'foo/*/bar'. A wildcard '**' is only allowed as the final parent directory. Stars must not otherwise appear in the parent directories. +In the 'extra-source-files' field: invalid file glob 'foo/blah-*.hs'. Wildcards '*' may only totally replace the file's base name, not only parts of it. diff --git a/Cabal-tests/tests/ParserTests/regressions/denormalised-paths.check b/Cabal-tests/tests/ParserTests/regressions/denormalised-paths.check index 84eade4e941..9b631589990 100644 --- a/Cabal-tests/tests/ParserTests/regressions/denormalised-paths.check +++ b/Cabal-tests/tests/ParserTests/regressions/denormalised-paths.check @@ -1,11 +1,14 @@ -The 'subdir' field of a source-repository is not a good relative path: "trailing same directory segment: ." -The paths 'files/<>/*.txt', 'c/**/*.c', 'C:foo/bar', '||s' are 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$". 'hs-source-dirs: ../../assoc/src' is a relative path outside of the source tree. This will not work when generating a tarball with 'sdist'. +The 'subdir' field of a source-repository is not a good relative path: "trailing same directory segment: ." 'extra-source-files: files/**/*.txt/' is not a good relative path: "trailing slash" 'extra-source-files: files/../foo.txt' is not a good relative path: "parent directory segment: .." -'license-file: LICENSE2/' is not a good relative path: "trailing slash" -'license-file: .' is not a good relative path: "trailing dot segment" +'hs-source-dirs: ../../assoc/src' is not a good relative path: "parent directory segment: .." 'hs-source-dirs: src/.' is not a good relative path: "trailing same directory segment: ." -'hs-source-dirs: src/../src' is not a good relative path: "parent directory segment: .." 'hs-source-dirs: src/../../assoc/src' is not a good relative path: "parent directory segment: .." -'hs-source-dirs: ../../assoc/src' is not a good relative path: "parent directory segment: .." +'hs-source-dirs: src/../src' is not a good relative path: "parent directory segment: .." +'license-file: .' is not a good relative path: "trailing dot segment" +'license-file: LICENSE2/' is not a good relative path: "trailing slash" +The path 'C:foo/bar' is 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$". +The path 'c/**/*.c' is 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$". +The path 'files/<>/*.txt' is 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$". +The path '||s' is 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$". diff --git a/Cabal-tests/tests/ParserTests/regressions/issue-774.check b/Cabal-tests/tests/ParserTests/regressions/issue-774.check index a72797cddb0..4f4c227632b 100644 --- a/Cabal-tests/tests/ParserTests/regressions/issue-774.check +++ b/Cabal-tests/tests/ParserTests/regressions/issue-774.check @@ -1,7 +1,7 @@ issue-774.cabal:13:22: Packages with 'cabal-version: 1.12' or later should specify a specific version of the Cabal spec of the form 'cabal-version: x.y'. Use 'cabal-version: 1.12'. -No 'category' field. -No 'maintainer' field. -The 'license' field is missing or is NONE. 'ghc-options: -threaded' has no effect for libraries. It should only be used for executables. 'ghc-options: -rtsopts' has no effect for libraries. It should only be used for executables. 'ghc-options: -with-rtsopts' has no effect for libraries. It should only be used for executables. +No 'category' field. +No 'maintainer' field. +The 'license' field is missing or is NONE. diff --git a/Cabal-tests/tests/ParserTests/regressions/issue-7776-b.check b/Cabal-tests/tests/ParserTests/regressions/issue-7776-b.check index d3839c3621d..7541335aefe 100644 --- a/Cabal-tests/tests/ParserTests/regressions/issue-7776-b.check +++ b/Cabal-tests/tests/ParserTests/regressions/issue-7776-b.check @@ -1 +1 @@ -Potential duplicate modules (subject to conditionals) in benchmark: Data.Hashable.RandomSource +Duplicate modules in library: Data.Hashable.RandomSource diff --git a/Cabal-tests/tests/ParserTests/regressions/pre-2.4-globstar.check b/Cabal-tests/tests/ParserTests/regressions/pre-2.4-globstar.check index 331d5a0ade9..ac3bd4bc76d 100644 --- a/Cabal-tests/tests/ParserTests/regressions/pre-2.4-globstar.check +++ b/Cabal-tests/tests/ParserTests/regressions/pre-2.4-globstar.check @@ -1,3 +1,3 @@ In the 'data-files' field: invalid file glob 'foo/**/*.dat'. Using the double-star syntax requires 'cabal-version: 2.4' or greater. Alternatively, for compatibility with earlier Cabal versions, list the included directories explicitly. -In the 'extra-source-files' field: invalid file glob 'foo/**/*.hs'. Using the double-star syntax requires 'cabal-version: 2.4' or greater. Alternatively, for compatibility with earlier Cabal versions, list the included directories explicitly. In the 'extra-doc-files' field: invalid file glob 'foo/**/*.html'. Using the double-star syntax requires 'cabal-version: 2.4' or greater. Alternatively, for compatibility with earlier Cabal versions, list the included directories explicitly. +In the 'extra-source-files' field: invalid file glob 'foo/**/*.hs'. Using the double-star syntax requires 'cabal-version: 2.4' or greater. Alternatively, for compatibility with earlier Cabal versions, list the included directories explicitly. diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs index 5def0b5421b..4cc2d6bfbbe 100644 --- a/Cabal/src/Distribution/PackageDescription/Check.hs +++ b/Cabal/src/Distribution/PackageDescription/Check.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} + ----------------------------------------------------------------------------- -- | -- Module : Distribution.PackageDescription.Check @@ -39,7 +42,7 @@ module Distribution.PackageDescription.Check ( import Distribution.Compat.Prelude import Prelude () -import Data.List (group) +import Data.List (group, (\\)) import Distribution.CabalSpecVersion import Distribution.Compat.Lens import Distribution.Compiler @@ -47,16 +50,13 @@ import Distribution.License import Distribution.ModuleName (ModuleName) import Distribution.Package import Distribution.PackageDescription -import Distribution.PackageDescription.Configuration import Distribution.Parsec.Warning (PWarning, showPWarning) import Distribution.Pretty (prettyShow) import Distribution.Simple.BuildPaths (autogenPathsModuleName) -import Distribution.Simple.BuildToolDepends import Distribution.Simple.CCompiler import Distribution.Simple.Glob import Distribution.Simple.Utils hiding (findPackageDesc, notice) import Distribution.System -import Distribution.Types.ComponentRequestedSpec import Distribution.Types.PackageName.Magic import Distribution.Utils.Generic (isAscii) import Distribution.Verbosity @@ -67,8 +67,6 @@ import System.FilePath (splitDirectories, splitExtension, splitPath, takeExtension, takeFileName, (<.>), ()) import qualified Data.ByteString.Lazy as BS -import qualified Data.Map as Map -import qualified Distribution.Compat.DList as DList import qualified Distribution.SPDX as SPDX import qualified System.Directory as System @@ -80,11 +78,13 @@ import qualified Distribution.Utils.ShortText as ShortText import qualified Distribution.Types.BuildInfo.Lens as L import qualified Distribution.Types.GenericPackageDescription.Lens as L -import qualified Distribution.Types.PackageDescription.Lens as L + +import Control.Monad.RWS as RWS -- $setup -- >>> import Control.Arrow ((&&&)) + -- ------------------------------------------------------------ -- * Warning messages -- ------------------------------------------------------------ @@ -126,12 +126,12 @@ data CheckExplanation = | NoTarget | UnnamedInternal | DuplicateSections [UnqualComponentName] - | IllegalLibraryName PackageDescription - | NoModulesExposed Library + | IllegalLibraryName PackageName + | NoModulesExposed LibraryName | SignaturesCabal2 | AutogenNotExposed | AutogenIncludesNotIncluded - | NoMainIs Executable + | NoMainIs UnqualComponentName | NoHsLhsMain | MainCCabal1_18 | AutogenNoOther CEType UnqualComponentName @@ -141,7 +141,7 @@ data CheckExplanation = | BenchmarkTypeNotKnown BenchmarkType | BenchmarkNotSupported BenchmarkType | NoHsLhsMainBench - | InvalidNameWin PackageDescription + | InvalidNameWin PackageName | ZPrefix | NoBuildType | NoCustomSetup @@ -160,7 +160,7 @@ data CheckExplanation = | NONELicense | NoLicense | AllRightsReservedLicense - | LicenseMessParse PackageDescription + | LicenseMessParse License | UnrecognisedLicense String | UncommonBSD4 | UnknownLicenseVersion License [Version] @@ -195,7 +195,7 @@ data CheckExplanation = | OptAlternatives String String [(String, String)] | RelativeOutside String FilePath | AbsolutePath String FilePath - | BadRelativePAth String FilePath String + | BadRelativePath String FilePath String | DistPoint (Maybe String) FilePath | GlobSyntaxError String String | InvalidOnWin [FilePath] @@ -250,6 +250,17 @@ data CheckExplanation = | UnknownDirectory String FilePath | MissingSourceControl deriving (Eq, Ord, Show) + -- TODO Some checks have a constructor in list form + -- (e.g. `SomeWarn [n]`). Ideally [SomeWar [a], SomeWar [b]] + -- would be translated into SomeWar [a,b]. + -- To achieve this the Writer part of CheckM could be modified + -- to be a ad hoc monoid. + -- As august 2022 these are the offending constructors: + -- `UnknownCompilers`, `InvalidTestWith`, `DeprecatedExtensions`, + -- `UnknownLanguages`, `LanguagesAsExtension`. + -- Only `DeprecatedExtensions` could reasonably pop up in day-to-day + -- cabal usage, and at minimal UX loss (two distinct warnings + -- instead of a list one). -- | Wraps `ParseWarning` into `PackageCheck`. -- @@ -276,16 +287,16 @@ ppExplanation (DuplicateSections duplicateNames) = ++ commaSep (map unUnqualComponentName duplicateNames) ++ ". The name of every library, executable, test suite," ++ " and benchmark section in the package must be unique." -ppExplanation (IllegalLibraryName pkg) = +ppExplanation (IllegalLibraryName pname) = "Illegal internal library name " - ++ prettyShow (packageName pkg) + ++ 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 (packageName pkg) + ++ " from 'library: '" ++ prettyShow pname ++ "' to 'library'." -ppExplanation (NoModulesExposed lib) = - showLibraryName (libName lib) ++ " does not expose any modules" +ppExplanation (NoModulesExposed lName) = + 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'." @@ -294,8 +305,8 @@ ppExplanation AutogenNotExposed = ppExplanation AutogenIncludesNotIncluded = "An include in 'autogen-includes' is neither in 'includes' or " ++ "'install-includes'." -ppExplanation (NoMainIs exe) = - "No 'main-is' field found for executable " ++ prettyShow (exeName exe) +ppExplanation (NoMainIs 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), " @@ -333,7 +344,7 @@ ppExplanation NoHsLhsMainBench = "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 (packageName pkg) ++ "' is " + "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 = @@ -405,8 +416,8 @@ 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?" -ppExplanation (LicenseMessParse pkg) = - "Unfortunately the license " ++ quote (prettyShow (license pkg)) +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'." @@ -521,7 +532,7 @@ ppExplanation (RelativeOutside field path) = ppExplanation (AbsolutePath field path) = quote (field ++ ": " ++ path) ++ " specifies an absolute path, but the " ++ quote field ++ " field must use relative paths." -ppExplanation (BadRelativePAth field path err) = +ppExplanation (BadRelativePath field path err) = quote (field ++ ": " ++ path) ++ " is not a good relative path: " ++ show err ppExplanation (DistPoint mfield path) = @@ -810,1261 +821,1203 @@ ppPackageCheck e = ppExplanation (explanation e) instance Show PackageCheck where show notice = ppPackageCheck notice -check :: Bool -> PackageCheck -> Maybe PackageCheck -check False _ = Nothing -check True pc = Just pc - -checkSpecVersion :: PackageDescription -> CabalSpecVersion -> Bool -> PackageCheck - -> Maybe PackageCheck -checkSpecVersion pkg specver cond pc - | specVersion pkg >= specver = Nothing - | otherwise = check cond pc -- ------------------------------------------------------------ --- * Standard checks +-- * Conditional trees annotation -- ------------------------------------------------------------ --- | 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'. +-- | 'TarAnn' collects contextual information on the tree: a buildup +-- of the various slices of the target ('a' — a Library, Executable, etc. — +-- is a monoid), dependencies, whether we are under an off-by-default +-- package flag. -- --- It requires the 'GenericPackageDescription' and optionally a particular --- configuration of that package. If you pass 'Nothing' then we just check --- a version of the generic description using 'flattenPackageDescription'. +data TarAnn a = TarAnn { taTarget :: a, + taDependencies :: [Dependency], + taPackageFlag :: Bool } + deriving (Show, Eq, Ord) + +-- | @nf@ function is needed to appropriately name some targets which need +-- to be spoonfed (otherwise name appears as ""). +initTarAnn :: Monoid a => (UnqualComponentName -> a -> a) -> + UnqualComponentName -> TarAnn a +initTarAnn nf n = TarAnn (nf n mempty) [] False + +-- | We “build up” target from various slices, for dependencies +-- the job is already done for us. -- -checkPackage :: GenericPackageDescription - -> Maybe PackageDescription - -> [PackageCheck] -checkPackage gpkg mpkg = - checkConfiguredPackage pkg - ++ checkConditionals gpkg - ++ checkPackageVersions gpkg - ++ checkDevelopmentOnlyFlags gpkg - ++ checkFlagNames gpkg - ++ checkUnusedFlags gpkg - ++ checkUnicodeXFields gpkg - ++ checkPathsModuleExtensions pkg - ++ checkSetupVersions gpkg - ++ checkDuplicateModules gpkg - where - pkg = fromMaybe (flattenPackageDescription gpkg) mpkg - ---TODO: make this variant go away --- we should always know the GenericPackageDescription -checkConfiguredPackage :: PackageDescription -> [PackageCheck] -checkConfiguredPackage pkg = - checkSanity pkg - ++ checkFields pkg - ++ checkLicense pkg - ++ checkSourceRepos pkg - ++ checkAllGhcOptions pkg - ++ checkCCOptions pkg - ++ checkCxxOptions pkg - ++ checkCPPOptions pkg - ++ checkPaths pkg - ++ checkCabalVersion pkg +updateTarAnn :: Monoid a => a -> [Dependency] -> TarAnn a -> TarAnn a +updateTarAnn t ds ta = ta { taTarget = taTarget ta <> t, + taDependencies = ds } +-- | 'annotateTree' takes advantage of 'CondTree' structure for context +-- aware checking. The end goal is is to have terminal leaves with a +-- fully realised target which we can check. +-- + -- xxx questo non è vero +annotateTree :: forall a. Monoid a => [PackageFlag] -> TarAnn a -> + CondTree ConfVar [Dependency] a -> + CondTree ConfVar (TarAnn a) () +annotateTree fs ta (CondNode t ds brs) = + let ta' = updateTarAnn t ds ta + in CondNode () ta' (map (annotateBranch ta') brs) + where + -- Package flags that are off by default. + defOffFlags = map flagName $ filter (not . flagDefault) fs + + -- 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 c) = not (isPkgFlagCond c) + isPkgFlagCond (CAnd ca cb) = isPkgFlagCond ca || isPkgFlagCond cb + isPkgFlagCond (COr ca cb) = isPkgFlagCond ca && isPkgFlagCond cb + + annotateBranch :: TarAnn a -> CondBranch ConfVar [Dependency] a -> + CondBranch ConfVar (TarAnn a) () + annotateBranch wta (CondBranch cond wt mf) = + let uf = isPkgFlagCond cond + wta' = wta { taPackageFlag = taPackageFlag wta || uf } + in CondBranch cond (annotateTree fs wta' wt) + (fmap (annotateTree fs wta') mf) -- ------------------------------------------------------------ --- * Basic sanity checks +-- * Check monad -- ------------------------------------------------------------ --- | Check that this package description is sane. +-- | Context to our checks. +data CheckCtx = CheckCtx { ccFlag :: Bool, + ccNames :: PNames } + -- Admittedly ccNames is not needed but since they pop up + -- in different places and it is a chore to extract them + -- all the time, we put it in CheckCtx. + -- xxx ccNames non sono solo nomi + +pristineCheckCtx :: GenericPackageDescription -> CheckCtx +pristineCheckCtx pd = CheckCtx False (initPNames pd) + +initCheckCtx :: TarAnn a -> CheckCtx -> CheckCtx +initCheckCtx t c = c {ccFlag = taPackageFlag t} + +-- | Convenience, shipping tuples around is boring. +data PNames = PNames { pnSpecVersion :: CabalSpecVersion, + pnPackageId :: PackageIdentifier, + pnSubLibs :: [UnqualComponentName], + pnExecs :: [UnqualComponentName], + pnTests :: [UnqualComponentName], + pnBenchs :: [UnqualComponentName] } + -- xxx rinomina queste cose + + -- xxx qua devi dire perché non solo nomi +initPNames :: GenericPackageDescription -> PNames +initPNames pd = PNames (specVersion . packageDescription $ pd) + (package . packageDescription $ pd) + (map fst $ condSubLibraries pd) + (map fst $ condExecutables pd) + (map fst $ condTestSuites pd) + (map fst $ condBenchmarks pd) + +-- | Check monad, carrying a context, collecting 'PackageCheck's. +-- Using Set for writer (automatic sort) is useful for output stability +-- on different platforms. -- -checkSanity :: PackageDescription -> [PackageCheck] -checkSanity pkg = - catMaybes [ - - check (null . unPackageName . packageName $ pkg) $ - PackageBuildImpossible NoNameField - - , check (nullVersion == packageVersion pkg) $ - PackageBuildImpossible NoVersionField - - , check (all ($ pkg) [ null . executables - , null . testSuites - , null . benchmarks - , null . allLibraries - , null . foreignLibs ]) $ - PackageBuildImpossible NoTarget - - , check (any (== LMainLibName) (map libName $ subLibraries pkg)) $ - PackageBuildImpossible UnnamedInternal - - , check (not (null duplicateNames)) $ - PackageBuildImpossible (DuplicateSections duplicateNames) - - -- NB: but it's OK for executables to have the same name! - -- TODO shouldn't need to compare on the string level - , check (any (== prettyShow (packageName pkg)) - (prettyShow <$> subLibNames)) $ - PackageBuildImpossible (IllegalLibraryName pkg) - ] - --TODO: check for name clashes case insensitively: windows file systems cannot - --cope. - - ++ concatMap (checkLibrary pkg) (allLibraries pkg) - ++ concatMap (checkExecutable pkg) (executables pkg) - ++ concatMap (checkTestSuite pkg) (testSuites pkg) - ++ concatMap (checkBenchmark pkg) (benchmarks pkg) - - where - -- The public 'library' gets special dispensation, because it - -- is common practice to export a library and name the executable - -- the same as the package. - subLibNames = mapMaybe (libraryNameString . libName) $ subLibraries pkg - exeNames = map exeName $ executables pkg - testNames = map testName $ testSuites pkg - bmNames = map benchmarkName $ benchmarks pkg - duplicateNames = dups $ subLibNames ++ exeNames ++ testNames ++ bmNames - -checkLibrary :: PackageDescription -> Library -> [PackageCheck] -checkLibrary pkg lib = - catMaybes [ - - -- TODO: This check is bogus if a required-signature was passed through - check (null (explicitLibModules lib) && null (reexportedModules lib)) $ - PackageDistSuspiciousWarn (NoModulesExposed lib) - - -- check use of signatures sections - , checkVersion CabalSpecV2_0 (not (null (signatures lib))) $ - PackageDistInexcusable SignaturesCabal2 - - -- check that all autogen-modules appear on other-modules or exposed-modules - , check - (not $ and $ map (flip elem (explicitLibModules lib)) (libModulesAutogen lib)) $ - PackageBuildImpossible AutogenNotExposed - - -- check that all autogen-includes appear on includes or install-includes - , check - (not $ and $ map (flip elem (allExplicitIncludes lib)) (view L.autogenIncludes lib)) $ - PackageBuildImpossible AutogenIncludesNotIncluded - ] - - where - checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck - checkVersion ver cond pc - | specVersion pkg >= ver = Nothing - | otherwise = check cond pc - -allExplicitIncludes :: L.HasBuildInfo a => a -> [FilePath] -allExplicitIncludes x = view L.includes x ++ view L.installIncludes x - -checkExecutable :: PackageDescription -> Executable -> [PackageCheck] -checkExecutable pkg exe = - catMaybes [ - - check (null (modulePath exe)) $ - PackageBuildImpossible (NoMainIs exe) - - -- This check does not apply to scripts. - , check (package pkg /= fakePackageId - && not (null (modulePath exe)) - && not (fileExtensionSupportedLanguage $ modulePath exe)) $ - PackageBuildImpossible NoHsLhsMain - - , checkSpecVersion pkg CabalSpecV1_18 - (fileExtensionSupportedLanguage (modulePath exe) - && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $ - PackageDistInexcusable MainCCabal1_18 - - -- check that all autogen-modules appear on other-modules - , check - (not $ and $ map (flip elem (exeModules exe)) (exeModulesAutogen exe)) $ - PackageBuildImpossible (AutogenNoOther CETExecutable (exeName exe)) - - -- check that all autogen-includes appear on includes - , check - (not $ and $ map (flip elem (view L.includes exe)) (view L.autogenIncludes exe)) $ - PackageBuildImpossible AutogenIncludesNotIncludedExe - ] - -checkTestSuite :: PackageDescription -> TestSuite -> [PackageCheck] -checkTestSuite pkg test = - catMaybes [ - - case testInterface test of - TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> Just $ - PackageBuildWarning (TestsuiteTypeNotKnown tt) - - TestSuiteUnsupported tt -> Just $ - PackageBuildWarning (TestsuiteNotSupported tt) - _ -> Nothing - - , check mainIsWrongExt $ - PackageBuildImpossible NoHsLhsMain - - , checkSpecVersion pkg CabalSpecV1_18 (mainIsNotHsExt && not mainIsWrongExt) $ - PackageDistInexcusable MainCCabal1_18 - - -- check that all autogen-modules appear on other-modules - , check - (not $ and $ map (flip elem (testModules test)) (testModulesAutogen test)) $ - PackageBuildImpossible (AutogenNoOther CETTest (testName test)) - - -- check that all autogen-includes appear on includes - , check - (not $ and $ map (flip elem (view L.includes test)) (view L.autogenIncludes test)) $ - PackageBuildImpossible AutogenIncludesNotIncludedExe - ] - where - mainIsWrongExt = case testInterface test of - TestSuiteExeV10 _ f -> not $ fileExtensionSupportedLanguage f - _ -> False - - mainIsNotHsExt = case testInterface test of - TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] - _ -> False - -checkBenchmark :: PackageDescription -> Benchmark -> [PackageCheck] -checkBenchmark _pkg bm = - catMaybes [ - - case benchmarkInterface bm of - BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> Just $ - PackageBuildWarning (BenchmarkTypeNotKnown tt) - - BenchmarkUnsupported tt -> Just $ - PackageBuildWarning (BenchmarkNotSupported tt) - _ -> Nothing - - , check mainIsWrongExt $ - PackageBuildImpossible NoHsLhsMainBench - - -- check that all autogen-modules appear on other-modules - , check - (not $ and $ map (flip elem (benchmarkModules bm)) (benchmarkModulesAutogen bm)) $ - PackageBuildImpossible (AutogenNoOther CETBenchmark (benchmarkName bm)) - - -- check that all autogen-includes appear on includes - , check - (not $ and $ map (flip elem (view L.includes bm)) (view L.autogenIncludes bm)) $ - PackageBuildImpossible AutogenIncludesNotIncludedExe - ] - where - mainIsWrongExt = case benchmarkInterface bm of - BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] - _ -> False +newtype CheckM a = CheckM (RWS.RWS CheckCtx (Set.Set PackageCheck) () a) + deriving (Functor, Applicative, Monad) + -- Not autoderiving MonadReader and MonadWriter gives us better + -- control on the interface of CheckM. + +tellCM :: PackageCheck -> CheckM () +tellCM ck = do + cf <- asksCM ccFlag + unless (cf && (not . isSevereLocal) ck) + -- Do not add this check if the warning is not severe *and* + -- we are under a non-default package flag. + (CheckM $ tell $ Set.singleton ck) + where + isSevereLocal (PackageBuildImpossible _) = True + isSevereLocal (PackageBuildWarning _) = True + isSevereLocal (PackageDistSuspicious _) = False + isSevereLocal (PackageDistSuspiciousWarn _) = False + isSevereLocal (PackageDistInexcusable _) = True + +check :: Bool -> PackageCheck -> CheckM () +check True ck = tellCM ck +check False _ = return () + +localCM :: (CheckCtx -> CheckCtx) -> CheckM () -> CheckM () +localCM cf (CheckM im) = CheckM $ local cf im + +asksCM :: (CheckCtx -> a) -> CheckM a +asksCM f = CheckM $ asks f + +-- vc: version to match +checkSpecVer :: CabalSpecVersion -> Bool -> PackageCheck -> CheckM () +checkSpecVer vc cond c = do + vp <- asksCM (pnSpecVersion . ccNames) + unless (vp >= vc) (check cond c) -- ------------------------------------------------------------ --- * Additional pure checks +-- * Packages -- ------------------------------------------------------------ -checkFields :: PackageDescription -> [PackageCheck] -checkFields pkg = - catMaybes [ - - check (not . FilePath.Windows.isValid . prettyShow . packageName $ pkg) $ - PackageDistInexcusable (InvalidNameWin pkg) - - , check (isPrefixOf "z-" . prettyShow . packageName $ pkg) $ - PackageDistInexcusable ZPrefix - - , check (isNothing (buildTypeRaw pkg) && specVersion pkg < CabalSpecV2_2) $ - PackageBuildWarning NoBuildType - - , check (isJust (setupBuildInfo pkg) && buildType pkg /= Custom) $ - PackageBuildWarning NoCustomSetup - - , check (not (null unknownCompilers)) $ - PackageBuildWarning (UnknownCompilers unknownCompilers) - - , check (not (null unknownLanguages)) $ - PackageBuildWarning (UnknownLanguages unknownLanguages) - - , check (not (null unknownExtensions)) $ - PackageBuildWarning (UnknownExtensions unknownExtensions) - - , check (not (null languagesUsedAsExtensions)) $ - PackageBuildWarning (LanguagesAsExtension languagesUsedAsExtensions) - - , check (not (null ourDeprecatedExtensions)) $ - PackageDistSuspicious (DeprecatedExtensions ourDeprecatedExtensions) - - , check (ShortText.null (category pkg)) $ - PackageDistSuspicious (MissingField CEFCategory) - - , check (ShortText.null (maintainer pkg)) $ - PackageDistSuspicious (MissingField CEFMaintainer) - - , check (ShortText.null (synopsis pkg) && ShortText.null (description pkg)) $ - PackageDistInexcusable (MissingField CEFSynOrDesc) - - , check (ShortText.null (description pkg) && not (ShortText.null (synopsis pkg))) $ - PackageDistSuspicious (MissingField CEFDescription) - - , check (ShortText.null (synopsis pkg) && not (ShortText.null (description pkg))) $ - PackageDistSuspicious (MissingField CEFSynopsis) - - --TODO: recommend the bug reports URL, author and homepage fields - --TODO: recommend not using the stability field - --TODO: recommend specifying a source repo - - , check (ShortText.length (synopsis pkg) > 80) $ - PackageDistSuspicious SynopsisTooLong - - -- See also https://github.com/haskell/cabal/pull/3479 - , check (not (ShortText.null (description pkg)) - && ShortText.length (description pkg) <= ShortText.length (synopsis pkg)) $ - PackageDistSuspicious ShortDesc - - -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12" - , check (not (null testedWithImpossibleRanges)) $ - PackageDistInexcusable (InvalidTestWith testedWithImpossibleRanges) - - -- for more details on why the following was commented out, - -- check https://github.com/haskell/cabal/pull/7470#issuecomment-875878507 - -- , check (not (null depInternalLibraryWithExtraVersion)) $ - -- PackageBuildWarning $ - -- "The package has an extraneous version range for a dependency on an " - -- ++ "internal library: " - -- ++ commaSep (map prettyShow depInternalLibraryWithExtraVersion) - -- ++ ". This version range includes the current package but isn't needed " - -- ++ "as the current package's library will always be used." - - , check (not (null depInternalLibraryWithImpossibleVersion)) $ - PackageBuildImpossible - (ImpossibleInternalDep depInternalLibraryWithImpossibleVersion) - - -- , check (not (null depInternalExecutableWithExtraVersion)) $ - -- PackageBuildWarning $ - -- "The package has an extraneous version range for a dependency on an " - -- ++ "internal executable: " - -- ++ commaSep (map prettyShow depInternalExecutableWithExtraVersion) - -- ++ ". This version range includes the current package but isn't needed " - -- ++ "as the current package's executable will always be used." - - , check (not (null depInternalExecutableWithImpossibleVersion)) $ - PackageBuildImpossible - (ImpossibleInternalExe depInternalExecutableWithImpossibleVersion) - - , check (not (null depMissingInternalExecutable)) $ - PackageBuildImpossible (MissingInternalExe depMissingInternalExecutable) - ] - where - unknownCompilers = [ name | (OtherCompiler name, _) <- testedWith pkg ] - unknownLanguages = [ name | bi <- allBuildInfo pkg - , UnknownLanguage name <- allLanguages bi ] - unknownExtensions = [ name | bi <- allBuildInfo pkg - , UnknownExtension name <- allExtensions bi - , name `notElem` map prettyShow knownLanguages ] - ourDeprecatedExtensions = nub $ catMaybes - [ find ((==ext) . fst) deprecatedExtensions - | bi <- allBuildInfo pkg - , ext <- allExtensions bi ] - languagesUsedAsExtensions = - [ name | bi <- allBuildInfo pkg - , UnknownExtension name <- allExtensions bi - , name `elem` map prettyShow knownLanguages ] - - testedWithImpossibleRanges = - [ Dependency (mkPackageName (prettyShow compiler)) vr mainLibSet - | (compiler, vr) <- testedWith pkg - , isNoVersion vr ] - - internalLibraries = - map (maybe (packageName pkg) unqualComponentNameToPackageName . libraryNameString . libName) - (allLibraries pkg) - - internalExecutables = map exeName $ executables pkg - - internalLibDeps = - [ dep - | bi <- allBuildInfo pkg - , dep@(Dependency name _ _) <- targetBuildDepends bi - , name `elem` internalLibraries - ] - - internalExeDeps = - [ dep - | bi <- allBuildInfo pkg - , dep <- getAllToolDependencies pkg bi - , isInternal pkg dep - ] - - -- depInternalLibraryWithExtraVersion = - -- [ dep - -- | dep@(Dependency _ versionRange _) <- internalLibDeps - -- , not $ isAnyVersion versionRange - -- , packageVersion pkg `withinRange` versionRange - -- ] - - depInternalLibraryWithImpossibleVersion = - [ dep - | dep@(Dependency _ versionRange _) <- internalLibDeps - , not $ packageVersion pkg `withinRange` versionRange - ] - - -- depInternalExecutableWithExtraVersion = - -- [ dep - -- | dep@(ExeDependency _ _ versionRange) <- internalExeDeps - -- , not $ isAnyVersion versionRange - -- , packageVersion pkg `withinRange` versionRange - -- ] - - depInternalExecutableWithImpossibleVersion = - [ dep - | dep@(ExeDependency _ _ versionRange) <- internalExeDeps - , not $ packageVersion pkg `withinRange` versionRange - ] +-- | 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 = + let (CheckM cm) = checkGenericPackageDescription gpd + (_, cs) = RWS.evalRWS cm (pristineCheckCtx gpd) () + in Set.toList cs + -- todo see configure part (three x in commit) and test whether it + -- works. + +-- | Pattern matching variables convention: matching accessor + underscore. +-- This way it is easier to see which one we are missing if we run into +-- an “GPD should have 20 arguments but has been given only 19" error. +-- +-- Remember -- that for historical quirks in the cabal codebase we have both +-- GenericPackageDescription and PackageDescription: PD is both a field of +-- GPD and a concept of its own, i.e. a fully realised GPD. +-- In this case we are checking (correctly) GPD, so for target info/checks +-- you should walk condLibrary_ etc. and *not* the (empty) target info in +-- PD. +checkGenericPackageDescription :: GenericPackageDescription -> CheckM () +checkGenericPackageDescription + gpd@(GenericPackageDescription + packageDescription_ _gpdScannedVersion_ genPackageFlags_ + condLibrary_ condSubLibraries_ condForeignLibs_ condExecutables_ + condTestSuites_ condBenchmarks_) + = do + checkPackageDescription packageDescription_ + + let condAllLibraries = maybeToList condLibrary_ ++ + (map snd condSubLibraries_) + check (and [null condExecutables_, null condTestSuites_, + null condBenchmarks_, null condAllLibraries, + null condForeignLibs_]) + (PackageBuildImpossible NoTarget) + + -- 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 + check (not . null $ dups names) + (PackageBuildImpossible $ DuplicateSections dupes) + + -- Feature checks. + checkSpecVer CabalSpecV2_0 (not . null $ condSubLibraries_) + (PackageDistInexcusable CVMultiLib) + checkSpecVer CabalSpecV1_8 (not . null $ condTestSuites_) + (PackageDistInexcusable CVTestSuite) + + -- Flag names. + mapM_ checkFlagName genPackageFlags_ + + case condLibrary_ of + Just cl -> checkCondTarget + genPackageFlags_ + (checkLibrary False) + (const id) (mempty, cl) + Nothing -> return () + + mapM_ (checkCondTarget genPackageFlags_ + (checkLibrary False) + (\u l -> l {libName = maybeToLibraryName (Just u)})) + condSubLibraries_ + mapM_ (checkCondTarget genPackageFlags_ + checkForeignLib + (const id)) + condForeignLibs_ + mapM_ (checkCondTarget genPackageFlags_ + (checkExecutable (package packageDescription_)) + (const id)) + condExecutables_ + mapM_ (checkCondTarget genPackageFlags_ + checkTestSuite + (\u l -> l {testName = u})) + condTestSuites_ + mapM_ (checkCondTarget genPackageFlags_ + checkBenchmark + (\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. + check (decFlags /= usedFlags) + (PackageDistSuspicious $ DeclaredUsedFlags decFlags usedFlags) + where + -- todo is this caught at parse time? + checkFlagName :: PackageFlag -> CheckM () + checkFlagName pf = + let fn = unFlagName . flagName $ pf + + invalidFlagName ('-':_) = True -- starts with dash + invalidFlagName cs = any (not . isAscii) cs -- non ASCII + in check (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 :: PackageDescription -> CheckM () +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 + + let pn = packageName package_ + + -- todo `name` is caught at parse level, remove this test + check (null . unPackageName $ pn) + (PackageBuildImpossible NoNameField) + -- todo `version` is caught at parse level, remove this test + check (nullVersion == packageVersion package_) + (PackageBuildImpossible NoVersionField) + + -- But it is OK for executables to have the same name. + nsubs <- asksCM (pnSubLibs . ccNames) + check (any (== prettyShow pn) (prettyShow <$> nsubs)) + (PackageBuildImpossible $ IllegalLibraryName pn) + + -- Fields check. + checkNull category_ + (PackageDistSuspicious $ MissingField CEFCategory) + checkNull maintainer_ + (PackageDistSuspicious $ MissingField CEFMaintainer) + check (ShortText.null synopsis_ && not (ShortText.null description_)) + (PackageDistSuspicious $ MissingField CEFSynopsis) + check (ShortText.null description_ && not (ShortText.null synopsis_)) + (PackageDistSuspicious $ MissingField CEFDescription) + check (all ShortText.null [synopsis_, description_]) + (PackageDistInexcusable $ MissingField CEFSynOrDesc) + check (ShortText.length synopsis_ > 80) + (PackageDistSuspicious SynopsisTooLong) + check (not (ShortText.null description_) && + ShortText.length description_ <= ShortText.length synopsis_) + (PackageDistSuspicious ShortDesc) + + checkPackageId package_ + + -- 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 + + -- glob syntax check + -- xxx mettili in checkpath? + mapM_ (checkGlob "data-files") dataFiles_ + mapM_ (checkGlob "extra-source-files") extraSrcFiles_ + mapM_ (checkGlob "extra-doc-files") extraDocFiles_ + + check (isNothing buildTypeRaw_ && specVersion_ < CabalSpecV2_2) + (PackageBuildWarning NoBuildType) + check (isJust setupBuildInfo_ && buildType pkg /= Custom) + (PackageBuildWarning NoCustomSetup) + + checkSetupBuildInfo setupBuildInfo_ + + -- Feature checks. + checkSpecVer CabalSpecV1_18 (not . null $ extraDocFiles_) + (PackageDistInexcusable CVExtraDocFiles) + checkSpecVer CabalSpecV1_6 (not . null $ sourceRepos_) + (PackageDistInexcusable CVSourceRepository) + check (specVersion_ >= CabalSpecV1_24 && + isNothing setupBuildInfo_ && + buildTypeRaw_ == Just Custom) + (PackageBuildWarning CVCustomSetup) + checkSpecVer CabalSpecV1_24 + (isNothing setupBuildInfo_ && + buildTypeRaw_ == Just Custom) + (PackageDistSuspiciousWarn CVExpliticDepsCustomSetup) + + mapM_ checkTestedWith testedWith_ + + either checkNewLicense + (checkOldLicense $ null licenseFiles_) + licenseRaw_ + + mapM_ checkSourceRepos sourceRepos_ + + mapM_ checkCustomField customFieldsPD_ + + where + checkNull :: ShortText.ShortText -> PackageCheck -> CheckM () + checkNull st c = check (ShortText.null st) c + + checkTestedWith :: (CompilerFlavor, VersionRange) -> CheckM () + checkTestedWith (OtherCompiler n, _) = + tellCM (PackageBuildWarning $ UnknownCompilers [n]) + checkTestedWith (compiler, versionRange) = + checkVersionRange compiler versionRange + + checkVersionRange :: CompilerFlavor -> VersionRange -> CheckM () + checkVersionRange cmp vr = + when (isNoVersion vr) + (let dep = [Dependency (mkPackageName (prettyShow cmp)) + vr mainLibSet] + in tellCM (PackageDistInexcusable (InvalidTestWith dep))) + +checkSetupBuildInfo :: Maybe SetupBuildInfo -> CheckM () +checkSetupBuildInfo Nothing = return () +checkSetupBuildInfo (Just (SetupBuildInfo ds _)) = do + -- todo abstract for multiple dep names + let fck = PackageDistInexcusable . UpperBoundSetup + mapM_ (checkPVP "base" fck) ds + mapM_ (checkPVP "Cabal" fck) ds + +checkPackageId :: PackageIdentifier -> CheckM () +checkPackageId (PackageIdentifier pkgName_ _pkgVersion_) = do + check (not . FilePath.Windows.isValid . prettyShow $ pkgName_) + (PackageDistInexcusable $ InvalidNameWin pkgName_) + check (isPrefixOf "z-" . prettyShow $ pkgName_) $ + (PackageDistInexcusable ZPrefix) + +checkNewLicense :: SPDX.License -> CheckM () +checkNewLicense lic = do + check (lic == SPDX.NONE) + (PackageDistInexcusable NONELicense) + +checkOldLicense :: Bool -> License -> CheckM () +checkOldLicense nullLicFiles lic = do + check (lic == UnspecifiedLicense) + (PackageDistInexcusable NoLicense) + check (lic == AllRightsReserved) + (PackageDistSuspicious AllRightsReservedLicense) + checkSpecVer CabalSpecV1_4 (lic `notElem` compatLicenses) + (PackageDistInexcusable (LicenseMessParse lic)) + check (lic == BSD4) + (PackageDistSuspicious UncommonBSD4) + case lic of + UnknownLicense l -> + tellCM (PackageBuildWarning (UnrecognisedLicense l)) + _ -> return () + check (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 -> tellCM + (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 :: SourceRepo -> CheckM () +checkSourceRepos (SourceRepo repoKind_ repoType_ repoLocation_ + repoModule_ _repoBranch_ repoTag_ repoSubdir_) = do + + case repoKind_ of + RepoKindUnknown kind -> tellCM + (PackageDistInexcusable $ UnrecognisedSourceRepo kind) + _ -> return () + + check (isNothing repoType_) + (PackageDistInexcusable MissingType) + + check (isNothing repoLocation_) + (PackageDistInexcusable MissingLocation) + + check (repoType_ == Just (KnownRepoType CVS) && isNothing repoModule_) + (PackageDistInexcusable MissingModule) + + check (repoKind_ == RepoThis && isNothing repoTag_) + (PackageDistInexcusable MissingTag) + + check (any isAbsoluteOnAnyPlatform repoSubdir_) + (PackageDistInexcusable SubdirRelPath) + + case join . fmap isGoodRelativeDirectoryPath $ repoSubdir_ of + Just err -> tellCM + (PackageDistInexcusable $ SubdirGoodRelPath err) + Nothing -> return () - depMissingInternalExecutable = - [ dep - | dep@(ExeDependency _ eName _) <- internalExeDeps - , not $ eName `elem` internalExecutables - ] +-- ------------------------------------------------------------ +-- * Targets +-- ------------------------------------------------------------ -checkLicense :: PackageDescription -> [PackageCheck] -checkLicense pkg = case licenseRaw pkg of - Right l -> checkOldLicense pkg l - Left l -> checkNewLicense pkg l - -checkNewLicense :: PackageDescription -> SPDX.License -> [PackageCheck] -checkNewLicense _pkg lic = catMaybes - [ check (lic == SPDX.NONE) $ - PackageDistInexcusable NONELicense ] - -checkOldLicense :: PackageDescription -> License -> [PackageCheck] -checkOldLicense pkg lic = catMaybes - [ check (lic == UnspecifiedLicense) $ - PackageDistInexcusable NoLicense - - , check (lic == AllRightsReserved) $ - PackageDistSuspicious AllRightsReservedLicense - - , checkVersion CabalSpecV1_4 (lic `notElem` compatLicenses) $ - PackageDistInexcusable (LicenseMessParse pkg) - - , case lic of - UnknownLicense l -> Just $ PackageBuildWarning (UnrecognisedLicense l) - _ -> Nothing - - , check (lic == BSD4) $ - PackageDistSuspicious UncommonBSD4 - - , case unknownLicenseVersion lic of - Just knownVersions -> Just $ - PackageDistSuspicious (UnknownLicenseVersion lic knownVersions) - _ -> Nothing - - , check (lic `notElem` [ AllRightsReserved - , UnspecifiedLicense, PublicDomain] - -- AllRightsReserved and PublicDomain are not strictly - -- licenses so don't need license files. - && null (licenseFiles pkg)) $ - PackageDistSuspicious NoLicenseFile - ] +-- | 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 a. Monoid a => + [PackageFlag] -> + (a -> CheckM ()) -> + (UnqualComponentName -> a -> a) -> + (UnqualComponentName, CondTree ConfVar [Dependency] a) -> + CheckM () +checkCondTarget fs cf nf (unqualName, ct) = + let ct' = annotateTree fs (initTarAnn nf unqualName) ct + in vNode ct' + where + vNode :: CondTree ConfVar (TarAnn a) () -> CheckM () + vNode (CondNode _ wta []) = + -- Conditional-less target, we are sure it is well formed, + -- start inspecting. + localCM (initCheckCtx wta) (cf $ taTarget wta) + vNode (CondNode _ _ wbs) = mapM_ vBranc wbs + + -- Conditional branches are the correct spot where to check + -- for suspicious variables, etc. + vBranc :: CondBranch ConfVar (TarAnn a) () -> CheckM () + vBranc (CondBranch cond t mt) = do + checkCondVars cond + sequence_ [vNode t, maybe (return ()) vNode mt] + +checkCondVars :: Condition ConfVar -> CheckM () +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 :: ConfVar -> CheckM () + vcheck (OS (OtherOS os)) = + tellCM (PackageDistInexcusable $ UnknownOS [os]) + vcheck (Arch (OtherArch arch)) = + tellCM (PackageDistInexcusable $ UnknownArch [arch]) + vcheck (Impl (OtherCompiler os) _) = + tellCM (PackageDistInexcusable $ UnknownCompiler [os]) + vcheck _ = return () + +checkLibrary :: Bool -> Library -> CheckM () +checkLibrary isSub lib@(Library + libName_ _exposedModules_ reexportedModules_ + signatures_ _libExposed_ _libVisibility_ + libBuildInfo_) = do + + check (libName_ == LMainLibName && isSub) + (PackageBuildImpossible UnnamedInternal) + + -- TODO: bogus if a required-signature was passed through. + check (null (explicitLibModules lib) && null reexportedModules_) + (PackageDistSuspiciousWarn (NoModulesExposed libName_)) + + -- TODO parse-caught check, can safely remove. + checkSpecVer CabalSpecV2_0 (not . null $ signatures_) + (PackageDistInexcusable SignaturesCabal2) + + check (not $ all (flip elem (explicitLibModules lib)) + (libModulesAutogen lib)) + (PackageBuildImpossible AutogenNotExposed) + + -- check that all autogen-includes appear on includes or + -- install-includes. + check (not $ all (flip elem (allExplicitIncludes lib)) + (view L.autogenIncludes lib)) $ + (PackageBuildImpossible AutogenIncludesNotIncluded) + + let rs = map moduleReexportName reexportedModules_ + checkBuildInfo BITLib (explicitLibModules lib, rs) 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 + +checkForeignLib :: ForeignLib -> CheckM () +checkForeignLib (ForeignLib + _foreignLibName_ _foreignLibType_ _foreignLibOptions_ + foreignLibBuildInfo_ _foreignLibVersionInfo_ + _foreignLibVersionLinux_ _foreignLibModDefFile_) = do + + checkBuildInfo BITLib ([], []) foreignLibBuildInfo_ + +checkExecutable :: PackageId -> Executable -> CheckM () +checkExecutable pid exe@(Executable + exeName_ modulePath_ _exeScope_ buildInfo_) = do + + check (null modulePath_) + (PackageBuildImpossible (NoMainIs exeName_)) + + -- This check does not apply to scripts. + check (pid /= fakePackageId && + not (null modulePath_) && + not (fileExtensionSupportedLanguage $ modulePath_)) + (PackageBuildImpossible NoHsLhsMain) + + 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. + check (not $ all (flip elem (exeModules exe)) (exeModulesAutogen exe)) + (PackageBuildImpossible $ AutogenNoOther CETExecutable exeName_) + + check (not $ all (flip elem (view L.includes exe)) + (view L.autogenIncludes exe)) + (PackageBuildImpossible AutogenIncludesNotIncludedExe) + + checkBuildInfo BITOther ([], []) buildInfo_ + -- xxx astrai buildinfo? + +checkTestSuite :: TestSuite -> CheckM () +checkTestSuite ts@(TestSuite + testName_ testInterface_ testBuildInfo_ + _testCodeGenerators_) = do + + -- todo caught by the parser, can remove safely + case testInterface_ of + TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> + tellCM (PackageBuildWarning $ TestsuiteTypeNotKnown tt) + TestSuiteUnsupported tt -> + tellCM (PackageBuildWarning $ TestsuiteNotSupported tt) + _ -> return () + + check mainIsWrongExt + (PackageBuildImpossible NoHsLhsMain) + + checkSpecVer CabalSpecV1_18 + (mainIsNotHsExt && not mainIsWrongExt) + (PackageDistInexcusable MainCCabal1_18) + + check (not $ all (flip elem (testModules ts)) + (testModulesAutogen ts)) + (PackageBuildImpossible (AutogenNoOther CETTest $ testName_)) + + check (not $ all (flip elem (view L.includes ts)) + (view L.autogenIncludes ts)) + (PackageBuildImpossible AutogenIncludesNotIncludedExe) + + checkBuildInfo BITTestBench ([], []) testBuildInfo_ where - 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 - - checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck - checkVersion ver cond pc - | specVersion pkg >= ver = Nothing - | otherwise = check cond pc - - compatLicenses = [ GPL Nothing, LGPL Nothing, AGPL Nothing, BSD3, BSD4 - , PublicDomain, AllRightsReserved - , UnspecifiedLicense, OtherLicense ] - -checkSourceRepos :: PackageDescription -> [PackageCheck] -checkSourceRepos pkg = - catMaybes $ concat [[ - - case repoKind repo of - RepoKindUnknown kind -> Just $ PackageDistInexcusable $ - UnrecognisedSourceRepo kind - _ -> Nothing - - , check (isNothing (repoType repo)) $ - PackageDistInexcusable MissingType - - , check (isNothing (repoLocation repo)) $ - PackageDistInexcusable MissingLocation - - , check (repoType repo == Just (KnownRepoType CVS) && isNothing (repoModule repo)) $ - PackageDistInexcusable MissingModule - - , check (repoKind repo == RepoThis && isNothing (repoTag repo)) $ - PackageDistInexcusable MissingTag - - , check (maybe False isAbsoluteOnAnyPlatform (repoSubdir repo)) $ - PackageDistInexcusable SubdirRelPath - - , do - subdir <- repoSubdir repo - err <- isGoodRelativeDirectoryPath subdir - return $ PackageDistInexcusable (SubdirGoodRelPath err) - ] - | repo <- sourceRepos pkg ] - ---TODO: check location looks like a URL for some repo types. - --- | Checks GHC options from all ghc-*-options fields in the given --- PackageDescription and reports commonly misused or non-portable flags -checkAllGhcOptions :: PackageDescription -> [PackageCheck] -checkAllGhcOptions pkg = - checkGhcOptions "ghc-options" (hcOptions GHC) pkg - ++ checkGhcOptions "ghc-prof-options" (hcProfOptions GHC) pkg - ++ checkGhcOptions "ghc-shared-options" (hcSharedOptions GHC) pkg - --- | Extracts GHC options belonging to the given field from the given --- PackageDescription using given function and checks them for commonly misused --- or non-portable flags -checkGhcOptions :: String -> (BuildInfo -> [String]) -> PackageDescription -> [PackageCheck] -checkGhcOptions fieldName getOptions pkg = - catMaybes [ - - checkFlags ["-fasm"] $ - PackageDistInexcusable (OptFasm fieldName) - - , checkFlags ["-fvia-C"] $ - PackageDistSuspicious (OptViaC fieldName) - - , checkFlags ["-fhpc"] $ - PackageDistInexcusable (OptHpc fieldName) - - , checkFlags ["-prof"] $ - PackageBuildWarning (OptProf fieldName) - - , checkFlags ["-o"] $ - PackageBuildWarning (OptO fieldName) - - , checkFlags ["-hide-package"] $ - PackageBuildWarning (OptHide fieldName) - - , checkFlags ["--make"] $ - PackageBuildWarning (OptMake fieldName) - - , checkFlags ["-main-is"] $ - PackageDistSuspicious (OptMain fieldName) - - , checkNonTestAndBenchmarkFlags ["-O0", "-Onot"] $ - PackageDistSuspicious (OptONot fieldName) - - , checkTestAndBenchmarkFlags ["-O0", "-Onot"] $ - PackageDistSuspiciousWarn (OptONot fieldName) - - , checkFlags [ "-O", "-O1"] $ - PackageDistInexcusable (OptOOne fieldName) - - , checkFlags ["-O2"] $ - PackageDistSuspiciousWarn (OptOTwo fieldName) - - , checkFlags ["-split-sections"] $ - PackageBuildWarning (OptSplitSections fieldName) - - , checkFlags ["-split-objs"] $ - PackageBuildWarning (OptSplitObjs fieldName) - - , checkFlags ["-optl-Wl,-s", "-optl-s"] $ - PackageDistInexcusable (OptWls fieldName) - - , checkFlags ["-fglasgow-exts"] $ - PackageDistSuspicious (OptExts fieldName) - - , check ("-threaded" `elem` lib_ghc_options) $ - PackageBuildWarning (OptThreaded fieldName) - - , check ("-rtsopts" `elem` lib_ghc_options) $ - PackageBuildWarning (OptRts fieldName) - - , check (any (\opt -> "-with-rtsopts" `isPrefixOf` opt) lib_ghc_options) $ - PackageBuildWarning (OptWithRts fieldName) - - , checkAlternatives fieldName "extensions" - [ (flag, prettyShow extension) | flag <- ghc_options_no_rtsopts - , Just extension <- [ghcExtension flag] ] - - , checkAlternatives fieldName "extensions" - [ (flag, extension) | flag@('-':'X':extension) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "cpp-options" $ - [ (flag, flag) | flag@('-':'D':_) <- ghc_options_no_rtsopts ] - ++ [ (flag, flag) | flag@('-':'U':_) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "include-dirs" - [ (flag, dir) | flag@('-':'I':dir) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "extra-libraries" - [ (flag, lib) | flag@('-':'l':lib) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "extra-libraries-static" - [ (flag, lib) | flag@('-':'l':lib) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "extra-lib-dirs" - [ (flag, dir) | flag@('-':'L':dir) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "extra-lib-dirs-static" - [ (flag, dir) | flag@('-':'L':dir) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "frameworks" - [ (flag, fmwk) | (flag@"-framework", fmwk) <- - zip ghc_options_no_rtsopts (safeTail ghc_options_no_rtsopts) ] - - , checkAlternatives fieldName "extra-framework-dirs" - [ (flag, dir) | (flag@"-framework-path", dir) <- - zip ghc_options_no_rtsopts (safeTail ghc_options_no_rtsopts) ] - ] + mainIsWrongExt = + case testInterface_ of + TestSuiteExeV10 _ f -> not (fileExtensionSupportedLanguage f) + _ -> False + + mainIsNotHsExt = + case testInterface_ of + TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] + _ -> False + +checkBenchmark :: Benchmark -> CheckM () +checkBenchmark bm@(Benchmark + benchmarkName_ benchmarkInterface_ + benchmarkBuildInfo_) = do + + case benchmarkInterface_ of + BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> + tellCM (PackageBuildWarning $ BenchmarkTypeNotKnown tt) + BenchmarkUnsupported tt -> + tellCM (PackageBuildWarning $ BenchmarkNotSupported tt) + _ -> return () + + check mainIsWrongExt + (PackageBuildImpossible NoHsLhsMainBench) + + check (not $ all (flip elem (benchmarkModules bm)) + (benchmarkModulesAutogen bm)) + (PackageBuildImpossible $ AutogenNoOther CETBenchmark benchmarkName_) + + check (not $ all (flip elem (view L.includes bm)) + (view L.autogenIncludes bm)) + (PackageBuildImpossible AutogenIncludesNotIncludedExe) + + checkBuildInfo BITTestBench ([], []) benchmarkBuildInfo_ + where + -- Cannot abstract with similar function in checkTestSuite, + -- they are different. + mainIsWrongExt = + case benchmarkInterface_ of + BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] + _ -> False + +data BITarget = BITLib | BITTestBench | BITOther + +ppBITarget :: BITarget -> String +ppBITarget BITLib = "library" +ppBITarget BITTestBench = "test/benchmark" +ppBITarget BITOther = "executable" + +-- | `ams` are additional module names that are not present in buildinfo +-- (mainly: exposed library modules). `rms` are reexports. +checkBuildInfo :: BITarget -> ([ModuleName], [ModuleName]) -> BuildInfo -> CheckM () +checkBuildInfo t (ams, rms) bi = do + -- xxx add why you did not deconstruct + -- (allbuildDepends) + -- Options. + 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 "C" "cc-options" (ccOptions bi) ldOpts + checkCLikeOptions "C++" "cxx-options" (cxxOptions bi) ldOpts + checkCPPOptions (cppOptions bi) + -- xxx anche C options hanno di questi problemi a vs [a] + + -- Paths: content. + mapM_ checkLang (allLanguages bi) + mapM_ checkExt (allExtensions bi) + mapM_ checkDep (targetBuildDepends bi) + mapM_ checkBTDep (buildToolDepends bi) + + -- Paths: well formedness + 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) + -- (Paths: well formedness, strictly non-absolute paths.) + mapM_ (checkPath False "includes" PathKindFile) (includes bi) + mapM_ (checkPath False "include-dirs" PathKindDirectory) + (includeDirs bi) + mapM_ (checkPath False "extra-lib-dirs" PathKindDirectory) + (extraLibDirs bi) + mapM_ (checkPath False "extra-lib-dirs-static" PathKindDirectory) + (extraLibDirsStatic bi) + mapM_ checkOptionPath (perCompilerFlavorToList $ options bi) + + -- Feature checks -- + -- xxx any not null feature astrai + sv <- asksCM (pnSpecVersion . ccNames) + checkSpecVer CabalSpecV1_10 (isJust $ defaultLanguage bi) + (PackageBuildWarning CVDefaultLanguage) + -- checkSpecVer sv + check (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) + -- Just a warning, because this won't break on old Cabal versions. + (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 + check (sv >= CabalSpecV1_10 && (not . null $ oldExtensions bi)) + (PackageBuildWarning CVExtensionsDeprecated) + checkCVSources (asmSources bi) + checkCVSources (cmmSources bi) + checkCVSources (extraBundledLibs bi) + checkCVSources (extraLibFlavours bi) + checkSpecVer CabalSpecV3_0 (not . null $ extraDynLibFlavours bi) + (PackageDistInexcusable $ CVExtraDynamic [extraDynLibFlavours bi]) + checkSpecVer CabalSpecV2_2 (not . null $ virtualModules bi) $ + (PackageDistInexcusable CVVirtualModules) + -- check use of thinning and renaming + checkSpecVer CabalSpecV2_0 (not . null $ mixins bi) + (PackageDistInexcusable CVMixins) + -- extensions + 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) + -- modules + pkgId <- asksCM (pnPackageId . ccNames) + let allModsForAuto = ams ++ otherModules bi + an = autoName pkgId + check (sv >= CabalSpecV2_0 && + elem an allModsForAuto && + notElem an (autogenModules bi)) + (PackageDistInexcusable CVAutogenPaths) + -- Paths module + some default extension build failure. + checkSpecVer CabalSpecV2_2 + ((an `elem` otherModules bi || + an `elem` autogenModules bi) && checkExts) + (PackageBuildImpossible RebindableClash) + + -- PVP: we check only for base, but see #8361. + mapM_ (checkPVP "base" + (const $ PackageDistInexcusable BaseNoUpperBounds)) + (targetBuildDepends bi) + + mapM_ checkCustomField (customFieldsBI bi) + + checkDupesModule + where + checkLang :: Language -> CheckM () + checkLang (UnknownLanguage n) = + tellCM (PackageBuildWarning (UnknownLanguages [n])) + checkLang _ = return () + + checkExt :: Extension -> CheckM () + checkExt (UnknownExtension n) + | n `elem` map prettyShow knownLanguages = + tellCM (PackageBuildWarning (LanguagesAsExtension [n])) + | otherwise = + tellCM (PackageBuildWarning (UnknownExtensions [n])) + checkExt n = do + let dss = filter (\(a, _) -> a == n) deprecatedExtensions + check (not . null $ dss) + (PackageDistSuspicious $ DeprecatedExtensions dss) + + checkDep :: Dependency -> CheckM () + 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 -- xxx non è vero, vedi codice sotto + when (packageNameToUnqualComponentName name `elem` allLibNs) + (check (not $ pVer `withinRange` vrange) + (PackageBuildImpossible $ ImpossibleInternalDep [d])) + -- xxx anche questo è un [a] + + checkBTDep :: ExeDependency -> CheckM () + checkBTDep ed@(ExeDependency _ name vrange) = do + exns <- asksCM (pnExecs . ccNames) + pVer <- asksCM (pkgVersion . pnPackageId . ccNames) + when (name `elem` exns) + (check (not $ pVer `withinRange` vrange) + (PackageBuildImpossible $ ImpossibleInternalExe [ed])) + -- xxx test per questo? + + checkOptionPath :: (CompilerFlavor, [FilePath]) -> CheckM () + checkOptionPath (GHC, paths) = mapM_ (\path -> + check (isInsideDist path) + (PackageDistInexcusable $ DistPoint Nothing path)) + paths + checkOptionPath _ = return () + + checkCVSources :: [FilePath] -> CheckM () + checkCVSources cvs = + checkSpecVer CabalSpecV3_0 (not . null $ cvs) + (PackageDistInexcusable CVSources) + + -- 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] + + -- It is an unfortunate reality that autogenPathsModuleName + -- works on PackageDescription while not needing it all. + autoName :: PackageIdentifier -> ModuleName + autoName pid = autogenPathsModuleName + (emptyPackageDescription {package = pid}) + + -- Do we have some peculiar extensions active which would interfer + -- (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 + + checkDupesModule :: CheckM () + checkDupesModule = + let os = otherModules bi + ms = os ++ (ams \\ os) ++ rms + -- We need this tricks or oms are counted twice. + ds = dups ms + in check (not . null $ ds) + (PackageBuildImpossible $ DuplicateModule (ppBITarget t) ds) + -- xxx elminate PotentialDupModule? + -- xxx ppBITarget è un hack assurdo + +-- PVP dependency check. +checkPVP :: String -> (String -> PackageCheck) -> Dependency -> CheckM () +checkPVP name ckf (Dependency pname ver _) = do + check ((not . hasUpperBound) ver && + pname == mkPackageName name) + (ckf name) + +-- xxx buildinfo in altra sezione +-- ------------------------------------------------------------ +-- * Options +-- ------------------------------------------------------------ - where - all_ghc_options = concatMap getOptions (allBuildInfo pkg) - ghc_options_no_rtsopts = rmRtsOpts all_ghc_options - lib_ghc_options = concatMap (getOptions . libBuildInfo) - (allLibraries pkg) - test_ghc_options = concatMap (getOptions . testBuildInfo) - (testSuites pkg) - benchmark_ghc_options = concatMap (getOptions . benchmarkBuildInfo) - (benchmarks pkg) - test_and_benchmark_ghc_options = test_ghc_options ++ - benchmark_ghc_options - non_test_and_benchmark_ghc_options = concatMap getOptions - (allBuildInfo (pkg { testSuites = [] - , benchmarks = [] - })) - - checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck - checkFlags flags = check (any (`elem` flags) all_ghc_options) - - checkTestAndBenchmarkFlags :: [String] -> PackageCheck -> Maybe PackageCheck - checkTestAndBenchmarkFlags flags = check (any (`elem` flags) test_and_benchmark_ghc_options) - - checkNonTestAndBenchmarkFlags :: [String] -> PackageCheck -> Maybe PackageCheck - checkNonTestAndBenchmarkFlags flags = check (any (`elem` flags) non_test_and_benchmark_ghc_options) - - 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 [] = [] - - -checkCCOptions :: PackageDescription -> [PackageCheck] -checkCCOptions = checkCLikeOptions "C" "cc-options" ccOptions - -checkCxxOptions :: PackageDescription -> [PackageCheck] -checkCxxOptions = checkCLikeOptions "C++" "cxx-options" cxxOptions - -checkCLikeOptions :: String -> String -> (BuildInfo -> [String]) -> PackageDescription -> [PackageCheck] -checkCLikeOptions label prefix accessor pkg = - catMaybes [ - - checkAlternatives prefix "include-dirs" - [ (flag, dir) | flag@('-':'I':dir) <- all_cLikeOptions ] - - , checkAlternatives prefix "extra-libraries" - [ (flag, lib) | flag@('-':'l':lib) <- all_cLikeOptions ] - - , checkAlternatives prefix "extra-lib-dirs" - [ (flag, dir) | flag@('-':'L':dir) <- all_cLikeOptions ] - - , checkAlternatives "ld-options" "extra-libraries" - [ (flag, lib) | flag@('-':'l':lib) <- all_ldOptions ] - - , checkAlternatives "ld-options" "extra-lib-dirs" - [ (flag, dir) | flag@('-':'L':dir) <- all_ldOptions ] - - , checkCCFlags [ "-O", "-Os", "-O0", "-O1", "-O2", "-O3" ] $ - PackageDistSuspicious (COptONumber prefix label) - ] - - where all_cLikeOptions = [ opts | bi <- allBuildInfo pkg - , opts <- accessor bi ] - all_ldOptions = [ opts | bi <- allBuildInfo pkg - , opts <- ldOptions bi ] - - checkCCFlags :: [String] -> PackageCheck -> Maybe PackageCheck - checkCCFlags flags = check (any (`elem` flags) all_cLikeOptions) - -checkCPPOptions :: PackageDescription -> [PackageCheck] -checkCPPOptions pkg = catMaybes - [ checkAlternatives "cpp-options" "include-dirs" - [ (flag, dir) | flag@('-':'I':dir) <- all_cppOptions ] - ] - ++ - [ PackageBuildWarning (COptCPP opt) - | opt <- all_cppOptions - -- "-I" is handled above, we allow only -DNEWSTUFF and -UOLDSTUFF - , not $ any (`isPrefixOf` opt) ["-D", "-U", "-I" ] - ] - where - all_cppOptions = [ opts | bi <- allBuildInfo pkg, opts <- cppOptions bi ] +-- | Checks GHC options for commonly misused or non-portable flags. +checkGHCOptions :: String -> BITarget -> [String] -> CheckM () +checkGHCOptions title t opts = do + checkGeneral + case t of + BITLib -> sequence_ [checkLib, checkNonTestBench] + BITTestBench -> checkTestBench + BITOther -> checkNonTestBench + where + checkFlags :: [String] -> PackageCheck -> CheckM () + checkFlags fs ck = check (any (`elem` fs) opts) ck + + checkFlagsP :: (String -> Bool) -> (String -> PackageCheck) -> + CheckM () + checkFlagsP p ckc = + case filter p opts of + [] -> return () + (_:_) -> tellCM (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 ["-main-is"] + (PackageDistSuspicious $ OptMain 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 + check ("-threaded" `elem` opts) + (PackageBuildWarning $ OptThreaded title) + check ("-rtsopts" `elem` opts) $ + (PackageBuildWarning $ OptRts title) + check (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 :: String -> String -> [String] -> [String] -> CheckM () +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] + + check (any (`elem` ["-O", "-Os", "-O0", "-O1", "-O2", "-O3"]) opts) + (PackageDistSuspicious $ COptONumber prefix label) checkAlternatives :: String -> String -> [(String, String)] - -> Maybe PackageCheck -checkAlternatives badField goodField flags = - check (not (null badFlags)) $ - PackageBuildWarning (OptAlternatives badField goodField flags) - where (badFlags, _) = unzip flags + -> CheckM () +checkAlternatives badField goodField flags = do + let (badFlags, _) = unzip flags + check (not $ null badFlags) + (PackageBuildWarning $ OptAlternatives badField goodField flags) + +checkCPPOptions :: [String] -> CheckM () +checkCPPOptions opts = do + checkAlternatives "cpp-options" "include-dirs" + [(flag, dir) | flag@('-':'I':dir) <- opts] + mapM_ (\opt -> check (not $ any(`isPrefixOf` opt) ["-D", "-U", "-I"]) + (PackageBuildWarning (COptCPP opt))) + opts + +-- ------------------------------------------------------------ +-- * Paths and fields +-- ------------------------------------------------------------ +-- xxx muovi di qui? data PathKind = PathKindFile | PathKindDirectory | PathKindGlob deriving (Eq) -checkPaths :: PackageDescription -> [PackageCheck] -checkPaths pkg = - checkPackageFileNamesWithGlob - [ (kind == PathKindGlob, path) - | (path, _, kind) <- relPaths ++ absPaths - ] - ++ - [ PackageBuildWarning (RelativeOutside field path) - | (path, field, _) <- relPaths ++ absPaths - , isOutsideTree path ] - ++ - [ PackageDistInexcusable (AbsolutePath field path) - | (path, field, _) <- relPaths - , isAbsoluteOnAnyPlatform path ] - ++ - [ PackageDistInexcusable (BadRelativePAth field path err) - | (path, field, kind) <- relPaths - -- these are not paths, but globs... - , err <- maybeToList $ case kind of - PathKindFile -> isGoodRelativeFilePath path - PathKindGlob -> isGoodRelativeGlob path - PathKindDirectory -> isGoodRelativeDirectoryPath path - ] - ++ - [ PackageDistInexcusable $ DistPoint (Just field) path - | (path, field, _) <- relPaths ++ absPaths - , isInsideDist path ] - ++ - [ PackageDistInexcusable (DistPoint Nothing path) - | bi <- allBuildInfo pkg - , (GHC, flags) <- perCompilerFlavorToList $ options bi - , path <- flags - , isInsideDist path ] - ++ - [ PackageDistInexcusable $ - GlobSyntaxError "data-files" (explainGlobSyntaxError pat err) - | pat <- dataFiles pkg - , Left err <- [parseFileGlob (specVersion pkg) pat] - ] - ++ - [ PackageDistInexcusable - (GlobSyntaxError "extra-source-files" (explainGlobSyntaxError pat err)) - | pat <- extraSrcFiles pkg - , Left err <- [parseFileGlob (specVersion pkg) pat] - ] - ++ - [ PackageDistInexcusable $ - GlobSyntaxError "extra-doc-files" (explainGlobSyntaxError pat err) - | pat <- extraDocFiles pkg - , Left err <- [parseFileGlob (specVersion pkg) pat] - ] +-- boolean: are absolute paths allowed? +checkPath :: Bool -> String -> PathKind -> FilePath -> CheckM () +checkPath isAbs title kind path = do + check (isOutsideTree path) + (PackageBuildWarning $ RelativeOutside title path) + check (isInsideDist path) + (PackageDistInexcusable $ DistPoint (Just title) path) + checkPackageFileNamesWithGlob kind path + + -- Skip if "can be absolute path". + -- xxx puoi metter euna cosa fuori + check (not isAbs && isAbsoluteOnAnyPlatform path) + (PackageDistInexcusable $ AbsolutePath title path) + case grl path kind of + Just e -> check (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 + +isInsideDist :: FilePath -> Bool +isInsideDist path = + case map lowercase (splitDirectories path) of + "dist" :_ -> True + ".":"dist":_ -> True + _ -> False + -- xxx qui distnewstyle? + +checkPackageFileNamesWithGlob :: PathKind -> FilePath -> CheckM () +checkPackageFileNamesWithGlob kind fp = do + checkWindowsPath (kind == PathKindGlob) fp + -- xxx rimuoverlo da qui? non sta già in path? + checkTarPath fp + +checkWindowsPath :: Bool -> FilePath -> CheckM () +checkWindowsPath isGlob path = + check (not . FilePath.Windows.isValid $ escape isGlob path) + (PackageDistInexcusable $ InvalidOnWin [path]) where - isOutsideTree path = case splitDirectories path of - "..":_ -> True - ".":"..":_ -> True - _ -> False - isInsideDist path = case map lowercase (splitDirectories path) of - "dist" :_ -> True - ".":"dist":_ -> True - _ -> False - - -- paths that must be relative - relPaths :: [(FilePath, String, PathKind)] - relPaths = - [ (path, "extra-source-files", PathKindGlob) | path <- extraSrcFiles pkg ] ++ - [ (path, "extra-tmp-files", PathKindFile) | path <- extraTmpFiles pkg ] ++ - [ (path, "extra-doc-files", PathKindGlob) | path <- extraDocFiles pkg ] ++ - [ (path, "data-files", PathKindGlob) | path <- dataFiles pkg ] ++ - [ (path, "data-dir", PathKindDirectory) | path <- [dataDir pkg]] ++ - [ (path, "license-file", PathKindFile) | path <- map getSymbolicPath $ licenseFiles pkg ] ++ - concat - [ [ (path, "asm-sources", PathKindFile) | path <- asmSources bi ] ++ - [ (path, "cmm-sources", PathKindFile) | path <- cmmSources bi ] ++ - [ (path, "c-sources", PathKindFile) | path <- cSources bi ] ++ - [ (path, "cxx-sources", PathKindFile) | path <- cxxSources bi ] ++ - [ (path, "js-sources", PathKindFile) | path <- jsSources bi ] ++ - [ (path, "install-includes", PathKindFile) | path <- installIncludes bi ] ++ - [ (path, "hs-source-dirs", PathKindDirectory) | path <- map getSymbolicPath $ hsSourceDirs bi ] - | bi <- allBuildInfo pkg - ] - - -- paths that are allowed to be absolute - absPaths :: [(FilePath, String, PathKind)] - absPaths = concat - [ [ (path, "includes", PathKindFile) | path <- includes bi ] ++ - [ (path, "include-dirs", PathKindDirectory) | path <- includeDirs bi ] ++ - [ (path, "extra-lib-dirs", PathKindDirectory) | path <- extraLibDirs bi ] ++ - [ (path, "extra-lib-dirs-static", PathKindDirectory) | path <- extraLibDirsStatic bi ] - | bi <- allBuildInfo pkg - ] - ---TODO: check sets of paths that would be interpreted differently between Unix --- and windows, ie case-sensitive or insensitive. Things that might clash, or --- conversely be distinguished. - ---TODO: use the tar path checks on all the above paths + -- 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 --- | Check that the package declares the version in the @\"cabal-version\"@ --- field correctly. +-- | Check a file name is valid for the portable POSIX tar format. -- -checkCabalVersion :: PackageDescription -> [PackageCheck] -checkCabalVersion pkg = - catMaybes [ - - -- check use of test suite sections - checkVersion CabalSpecV1_8 (not (null $ testSuites pkg)) $ - PackageDistInexcusable CVTestSuite - - -- check use of default-language field - -- note that we do not need to do an equivalent check for the - -- other-language field since that one does not change behaviour - , checkVersion CabalSpecV1_10 (any isJust (buildInfoField defaultLanguage)) $ - PackageBuildWarning CVDefaultLanguage - - , check (specVersion pkg >= CabalSpecV1_10 && specVersion pkg < CabalSpecV3_4 - && any isNothing (buildInfoField defaultLanguage)) $ - PackageBuildWarning CVDefaultLanguageComponent - - , checkVersion CabalSpecV1_18 - (not . null $ extraDocFiles pkg) $ - PackageDistInexcusable CVExtraDocFiles - - , checkVersion CabalSpecV2_0 - (not (null (subLibraries pkg))) $ - PackageDistInexcusable CVMultiLib - - -- check use of reexported-modules sections - , checkVersion CabalSpecV1_22 - (any (not.null.reexportedModules) (allLibraries pkg)) $ - PackageDistInexcusable CVReexported - - -- check use of thinning and renaming - , checkVersion CabalSpecV2_0 usesBackpackIncludes $ - PackageDistInexcusable CVMixins - - -- check use of 'extra-framework-dirs' field - , checkVersion CabalSpecV1_24 (any (not . null) (buildInfoField extraFrameworkDirs)) $ - -- Just a warning, because this won't break on old Cabal versions. - PackageDistSuspiciousWarn CVExtraFrameworkDirs - - -- check use of default-extensions field - -- don't need to do the equivalent check for other-extensions - , checkVersion CabalSpecV1_10 (any (not . null) (buildInfoField defaultExtensions)) $ - PackageBuildWarning CVDefaultExtensions - - -- check use of extensions field - , check (specVersion pkg >= CabalSpecV1_10 - && any (not . null) (buildInfoField oldExtensions)) $ - PackageBuildWarning CVExtensionsDeprecated - - , checkVersion CabalSpecV3_0 (any (not . null) - (concatMap buildInfoField - [ asmSources - , cmmSources - , extraBundledLibs - , extraLibFlavours ])) $ - PackageDistInexcusable CVSources - - , checkVersion CabalSpecV3_0 (any (not . null) $ buildInfoField extraDynLibFlavours) $ - PackageDistInexcusable - (CVExtraDynamic $ buildInfoField extraDynLibFlavours) - - , checkVersion CabalSpecV2_2 (any (not . null) - (buildInfoField virtualModules)) $ - PackageDistInexcusable CVVirtualModules - - -- check use of "source-repository" section - , checkVersion CabalSpecV1_6 (not (null (sourceRepos pkg))) $ - PackageDistInexcusable CVSourceRepository - - -- check for new language extensions - , checkVersion CabalSpecV1_2 (not (null mentionedExtensionsThatNeedCabal12)) $ - PackageDistInexcusable - (CVExtensions CabalSpecV1_2 mentionedExtensionsThatNeedCabal12) - - , checkVersion CabalSpecV1_4 (not (null mentionedExtensionsThatNeedCabal14)) $ - PackageDistInexcusable - (CVExtensions CabalSpecV1_4 mentionedExtensionsThatNeedCabal14) - - , check (specVersion pkg >= CabalSpecV1_24 - && isNothing (setupBuildInfo pkg) - && buildType pkg == Custom) $ - PackageBuildWarning CVCustomSetup - - , check (specVersion pkg < CabalSpecV1_24 - && isNothing (setupBuildInfo pkg) - && buildType pkg == Custom) $ - PackageDistSuspiciousWarn CVExpliticDepsCustomSetup - - , check (specVersion pkg >= CabalSpecV2_0 - && elem (autogenPathsModuleName pkg) allModuleNames - && not (elem (autogenPathsModuleName pkg) allModuleNamesAutogen) ) $ - PackageDistInexcusable CVAutogenPaths - - ] +-- The POSIX tar format has a restriction on the length of file names. It is +-- unfortunately not a simple restriction like a maximum length. The exact +-- 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 :: FilePath -> CheckM () +checkTarPath path + | length path > 255 = tellCM longPath + | otherwise = case pack nameMax (reverse (splitPath path)) of + Left err -> tellCM err + Right [] -> return () + Right (h:rest) -> case pack prefixMax remainder of + Left err -> tellCM err + Right [] -> return () + Right (_:_) -> tellCM noSplit + where + -- drop the '/' between the name and prefix: + remainder = safeInit h : rest + where - -- Perform a check on packages that use a version of the spec less than - -- the version given. This is for cases where a new Cabal version adds - -- a new feature and we want to check that it is not used prior to that - -- version. - checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck - checkVersion ver cond pc - | specVersion pkg >= ver = Nothing - | otherwise = check cond pc - - buildInfoField field = map field (allBuildInfo pkg) - - usesBackpackIncludes = any (not . null . mixins) (allBuildInfo pkg) - - mentionedExtensions = [ ext | bi <- allBuildInfo pkg - , ext <- allExtensions bi ] - mentionedExtensionsThatNeedCabal12 = - nub (filter (`elem` compatExtensionsExtra) mentionedExtensions) - - -- As of Cabal-1.4 we can add new extensions without worrying about - -- breaking old versions of cabal. - mentionedExtensionsThatNeedCabal14 = - nub (filter (`notElem` compatExtensions) mentionedExtensions) - - -- The known extensions in Cabal-1.2.3 - 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 = - map EnableExtension - [ KindSignatures, MagicHash, TypeFamilies, StandaloneDeriving - , UnicodeSyntax, PatternSignatures, UnliftedFFITypes, LiberalTypeSynonyms - , TypeOperators, RecordWildCards, RecordPuns, DisambiguateRecordFields - , OverloadedStrings, GADTs, RelaxedPolyRec - , ExtendedDefaultRules, UnboxedTuples, DeriveDataTypeable - , ConstrainedClassMethods - ] ++ - map DisableExtension - [MonoPatBinds] - - allModuleNames = - (case library pkg of - Nothing -> [] - (Just lib) -> explicitLibModules lib - ) - ++ concatMap otherModules (allBuildInfo pkg) - - allModuleNamesAutogen = concatMap autogenModules (allBuildInfo pkg) + nameMax, prefixMax :: Int + nameMax = 100 + prefixMax = 155 --- ------------------------------------------------------------ --- * Checks on the GenericPackageDescription --- ------------------------------------------------------------ + pack _ [] = Left emptyName + pack maxLen (c:cs) + | n > maxLen = Left longName + | otherwise = Right (pack' maxLen n cs) + where n = length c --- | Check the build-depends fields for any weirdness or bad practice. --- -checkPackageVersions :: GenericPackageDescription -> [PackageCheck] -checkPackageVersions pkg = - catMaybes [ - - -- Check that the version of base is bounded above. - -- For example this bans "build-depends: base >= 3". - -- It should probably be "build-depends: base >= 3 && < 4" - -- which is the same as "build-depends: base == 3.*" - check (not (hasUpperBound baseDependency)) $ - PackageDistInexcusable BaseNoUpperBounds - - ] - where - baseDependency = case typicalPkg pkg of - Right (pkg', _) | not (null baseDeps) -> - foldr intersectVersionRanges anyVersion baseDeps - where - baseDeps = - [ vr | Dependency pname vr _ <- allBuildDepends pkg' - , pname == mkPackageName "base" ] - - -- Just in case finalizePD fails for any reason, - -- or if the package doesn't depend on the base package at all, - -- then we will just skip the check, since hasUpperBound noVersion = True - _ -> noVersion - -checkConditionals :: GenericPackageDescription -> [PackageCheck] -checkConditionals pkg = - catMaybes [ - - check (not $ null unknownOSs) $ - PackageDistInexcusable (UnknownOS unknownOSs) - - , check (not $ null unknownArches) $ - PackageDistInexcusable (UnknownArch unknownArches) - - , check (not $ null unknownImpls) $ - PackageDistInexcusable (UnknownCompiler unknownImpls) - ] - where - unknownOSs = [ os | OS (OtherOS os) <- conditions ] - unknownArches = [ arch | Arch (OtherArch arch) <- conditions ] - unknownImpls = [ impl | Impl (OtherCompiler impl) _ <- conditions ] - conditions = concatMap fvs (maybeToList (condLibrary pkg)) - ++ concatMap (fvs . snd) (condSubLibraries pkg) - ++ concatMap (fvs . snd) (condForeignLibs pkg) - ++ concatMap (fvs . snd) (condExecutables pkg) - ++ concatMap (fvs . snd) (condTestSuites pkg) - ++ concatMap (fvs . snd) (condBenchmarks pkg) - fvs (CondNode _ _ ifs) = concatMap compfv ifs -- free variables - compfv (CondBranch c ct mct) = condfv c ++ fvs ct ++ maybe [] fvs mct - condfv c = case c of - Var v -> [v] - Lit _ -> [] - CNot c1 -> condfv c1 - COr c1 c2 -> condfv c1 ++ condfv c2 - CAnd c1 c2 -> condfv c1 ++ condfv c2 - -checkFlagNames :: GenericPackageDescription -> [PackageCheck] -checkFlagNames gpd - | null invalidFlagNames = [] - | otherwise = - [ PackageDistInexcusable (SuspiciousFlagName invalidFlagNames) ] - where - invalidFlagNames = - [ fn - | flag <- genPackageFlags gpd - , let fn = unFlagName (flagName flag) - , invalidFlagName fn - ] - -- starts with dash - invalidFlagName ('-':_) = True - -- mon ascii letter - invalidFlagName cs = any (not . isAscii) cs - -checkUnusedFlags :: GenericPackageDescription -> [PackageCheck] -checkUnusedFlags gpd - | declared == used = [] - | otherwise = - [ PackageDistSuspicious (DeclaredUsedFlags declared used) ] - where - declared :: Set.Set FlagName - declared = toSetOf (L.genPackageFlags . traverse . L.flagName) gpd - - used :: Set.Set FlagName - used = 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 - ] - -checkUnicodeXFields :: GenericPackageDescription -> [PackageCheck] -checkUnicodeXFields gpd - | null nonAsciiXFields = [] - | otherwise = - [ PackageDistInexcusable (NonASCIICustomField nonAsciiXFields) ] - where - nonAsciiXFields :: [String] - nonAsciiXFields = [ n | (n, _) <- xfields, any (not . isAscii) n ] - - xfields :: [(String,String)] - xfields = DList.runDList $ mconcat - [ toDListOf (L.packageDescription . L.customFieldsPD . traverse) gpd - , toDListOf (L.traverseBuildInfos . L.customFieldsBI . traverse) gpd - ] - --- | cabal-version <2.2 + Paths_module + default-extensions: doesn't build. -checkPathsModuleExtensions :: PackageDescription -> [PackageCheck] -checkPathsModuleExtensions pd - | specVersion pd >= CabalSpecV2_2 = [] - | any checkBI (allBuildInfo pd) || any checkLib (allLibraries pd) - = return (PackageBuildImpossible RebindableClash) - | otherwise = [] - where - mn = autogenPathsModuleName pd - - checkLib :: Library -> Bool - checkLib l = mn `elem` exposedModules l && checkExts (l ^. L.defaultExtensions) - - checkBI :: BuildInfo -> Bool - checkBI bi = - (mn `elem` otherModules bi || mn `elem` autogenModules bi) && - checkExts (bi ^. L.defaultExtensions) - - checkExts exts = rebind `elem` exts && (strings `elem` exts || lists `elem` exts) - where - rebind = EnableExtension RebindableSyntax - strings = EnableExtension OverloadedStrings - lists = EnableExtension OverloadedLists - --- | Checks GHC options from all ghc-*-options fields from the given BuildInfo --- and reports flags that are OK during development process, but are --- unacceptable in a distributed package -checkDevelopmentOnlyFlagsBuildInfo :: BuildInfo -> [PackageCheck] -checkDevelopmentOnlyFlagsBuildInfo bi = - checkDevelopmentOnlyFlagsOptions "ghc-options" (hcOptions GHC bi) - ++ checkDevelopmentOnlyFlagsOptions "ghc-prof-options" (hcProfOptions GHC bi) - ++ checkDevelopmentOnlyFlagsOptions "ghc-shared-options" (hcSharedOptions GHC bi) - --- | Checks the given list of flags belonging to the given field and reports --- flags that are OK during development process, but are unacceptable in a --- distributed package -checkDevelopmentOnlyFlagsOptions :: String -> [String] -> [PackageCheck] -checkDevelopmentOnlyFlagsOptions fieldName ghcOptions = - catMaybes [ - - check has_Werror $ - PackageDistInexcusable (WErrorUnneeded fieldName) - - , check has_J $ - PackageDistInexcusable (JUnneeded fieldName) - - , checkFlags ["-fdefer-type-errors"] $ - PackageDistInexcusable (FDeferTypeErrorsUnneeded fieldName) - - -- -dynamic is not a debug flag - , check (any (\opt -> "-d" `isPrefixOf` opt && opt /= "-dynamic") - ghcOptions) $ - PackageDistInexcusable (DynamicUnneeded fieldName) - - , checkFlags ["-fprof-auto", "-fprof-auto-top", "-fprof-auto-calls", - "-fprof-cafs", "-fno-prof-count-entries", - "-auto-all", "-auto", "-caf-all"] $ - PackageDistSuspicious (ProfilingUnneeded fieldName) - ] - where + pack' maxLen n (c:cs) + | n' <= maxLen = pack' maxLen n' cs + where n' = n + length c + pack' _ _ cs = cs - has_Werror = "-Werror" `elem` ghcOptions - has_J = any - (\o -> case o of - "-j" -> True - ('-' : 'j' : d : _) -> isDigit d - _ -> False - ) - ghcOptions - checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck - checkFlags flags = check (any (`elem` flags) ghcOptions) - -checkDevelopmentOnlyFlags :: GenericPackageDescription -> [PackageCheck] -checkDevelopmentOnlyFlags pkg = - concatMap checkDevelopmentOnlyFlagsBuildInfo - [ bi - | (conditions, bi) <- allConditionalBuildInfo - , not (any guardedByManualFlag conditions) ] - where - guardedByManualFlag = definitelyFalse - - -- We've basically got three-values logic here: True, False or unknown - -- hence this pattern to propagate the unknown cases properly. - definitelyFalse (Var (PackageFlag n)) = maybe False not (Map.lookup n manualFlags) - definitelyFalse (Var _) = False - definitelyFalse (Lit b) = not b - definitelyFalse (CNot c) = definitelyTrue c - definitelyFalse (COr c1 c2) = definitelyFalse c1 && definitelyFalse c2 - definitelyFalse (CAnd c1 c2) = definitelyFalse c1 || definitelyFalse c2 - - definitelyTrue (Var (PackageFlag n)) = fromMaybe False (Map.lookup n manualFlags) - definitelyTrue (Var _) = False - definitelyTrue (Lit b) = b - definitelyTrue (CNot c) = definitelyFalse c - definitelyTrue (COr c1 c2) = definitelyTrue c1 || definitelyTrue c2 - definitelyTrue (CAnd c1 c2) = definitelyTrue c1 && definitelyTrue c2 - - manualFlags = Map.fromList - [ (flagName flag, flagDefault flag) - | flag <- genPackageFlags pkg - , flagManual flag ] - - allConditionalBuildInfo :: [([Condition ConfVar], BuildInfo)] - allConditionalBuildInfo = - concatMap (collectCondTreePaths libBuildInfo) - (maybeToList (condLibrary pkg)) - - ++ concatMap (collectCondTreePaths libBuildInfo . snd) - (condSubLibraries pkg) - - ++ concatMap (collectCondTreePaths buildInfo . snd) - (condExecutables pkg) - - ++ concatMap (collectCondTreePaths testBuildInfo . snd) - (condTestSuites pkg) - - ++ concatMap (collectCondTreePaths benchmarkBuildInfo . snd) - (condBenchmarks pkg) - - -- get all the leaf BuildInfo, paired up with the path (in the tree sense) - -- of if-conditions that guard it - collectCondTreePaths :: (a -> b) - -> CondTree v c a - -> [([Condition v], b)] - collectCondTreePaths mapData = go [] - where - go conditions condNode = - -- the data at this level in the tree: - (reverse conditions, mapData (condTreeData condNode)) - - : concat - [ go (condition:conditions) ifThen - | (CondBranch condition ifThen _) <- condTreeComponents condNode ] - - ++ concat - [ go (condition:conditions) elseThen - | (CondBranch condition _ (Just elseThen)) <- condTreeComponents condNode ] + longPath = PackageDistInexcusable (FilePathTooLong path) + longName = PackageDistInexcusable (FilePathNameTooLong path) + noSplit = PackageDistInexcusable (FilePathSplitTooLong path) + emptyName = PackageDistInexcusable FilePathEmpty +checkGlob :: String -> FilePath -> CheckM () +checkGlob title pat = do + ver <- asksCM (pnSpecVersion . ccNames) + case parseFileGlob ver pat of + Left e -> tellCM (PackageDistInexcusable $ + GlobSyntaxError title (explainGlobSyntaxError pat e)) + Right _ -> return () + +checkCustomField :: (String, String) -> CheckM () +checkCustomField (n, _) = + check (any (not . isAscii) n) + (PackageDistInexcusable $ NonASCIICustomField [n]) + +-- ------------------------------------------------------------ +-- * ALTRO XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +-- ------------------------------------------------------------ -- ------------------------------------------------------------ -- * Checks involving files in the package @@ -2107,7 +2060,7 @@ data CheckPackageContentOps m = CheckPackageContentOps { -- 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, Applicative m) +checkPackageContent :: (Monad m, Applicative m) -- xxx monad è già applicative! => CheckPackageContentOps m -> PackageDescription -> m [PackageCheck] @@ -2137,7 +2090,7 @@ checkCabalFileBOM ops = do -- --cabal-file is specified. So if you can't find the file, -- just don't bother with this check. Left _ -> return Nothing - Right pdfile -> (flip check pc . BS.isPrefixOf bomUtf8) + Right pdfile -> (flip checkXXXPROVA pc . BS.isPrefixOf bomUtf8) `liftM` getFileContents ops pdfile where pc = PackageDistInexcusable (BOMStart pdfile) @@ -2206,7 +2159,7 @@ checkSetupExists ops pkg = do let simpleBuild = buildType pkg == Simple hsexists <- doesFileExist ops "Setup.hs" lhsexists <- doesFileExist ops "Setup.lhs" - return $ check (not simpleBuild && not hsexists && not lhsexists) $ + return $ checkXXXPROVA (not simpleBuild && not hsexists && not lhsexists) $ PackageDistInexcusable MissingSetupFile checkConfigureExists :: Monad m => CheckPackageContentOps m @@ -2215,7 +2168,7 @@ checkConfigureExists :: Monad m => CheckPackageContentOps m checkConfigureExists ops pd | buildType pd == Configure = do exists <- doesFileExist ops "configure" - return $ check (not exists) $ + return $ checkXXXPROVA (not exists) $ PackageBuildWarning MissingConfigureScript | otherwise = return Nothing @@ -2271,73 +2224,7 @@ repoTypeDirname Pijul = [".pijul"] -- should be done for example when creating or validating a package tarball. -- checkPackageFileNames :: [FilePath] -> [PackageCheck] -checkPackageFileNames = checkPackageFileNamesWithGlob . zip (repeat True) - -checkPackageFileNamesWithGlob :: [(Bool, FilePath)] -> [PackageCheck] -checkPackageFileNamesWithGlob files = - catMaybes $ - checkWindowsPaths files - : - [ checkTarPath file - | (_, file) <- files - ] - -checkWindowsPaths :: [(Bool, FilePath)] -> Maybe PackageCheck -checkWindowsPaths paths = - case filter (not . FilePath.Windows.isValid . escape) paths of - [] -> Nothing - ps -> Just $ - PackageDistInexcusable (InvalidOnWin $ map snd ps) - 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 (isGlob, path) = (".\\" ++) - -- glob paths will be expanded before being dereferenced, so asterisks - -- shouldn't count against them. - $ map (\c -> if c == '*' && isGlob then 'x' else c) path - --- | Check a file name is valid for the portable POSIX tar format. --- --- The POSIX tar format has a restriction on the length of file names. It is --- unfortunately not a simple restriction like a maximum length. The exact --- 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 :: FilePath -> Maybe PackageCheck -checkTarPath path - | length path > 255 = Just longPath - | otherwise = case pack nameMax (reverse (splitPath path)) of - Left err -> Just err - Right [] -> Nothing - Right (h:rest) -> case pack prefixMax remainder of - Left err -> Just err - Right [] -> Nothing - Right (_:_) -> Just noSplit - where - -- drop the '/' between the name and prefix: - remainder = safeInit h : rest - - where - nameMax, prefixMax :: Int - 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' maxLen n (c:cs) - | n' <= maxLen = pack' maxLen n' cs - where n' = n + length c - pack' _ _ cs = cs - - longPath = PackageDistInexcusable (FilePathTooLong path) - longName = PackageDistInexcusable (FilePathNameTooLong path) - noSplit = PackageDistInexcusable (FilePathSplitTooLong path) - emptyName = PackageDistInexcusable FilePathEmpty +checkPackageFileNames = checkPackageFileNamesWithGlobXXX . zip (repeat True) -- -------------------------------------------------------------- -- * Checks for missing content and other pre-distribution checks @@ -2404,60 +2291,6 @@ checkGlobFiles verbosity pkg root = getWarning field glob (GlobMissingDirectory dir) = [ PackageDistSuspiciousWarn (GlobNoDir field glob dir) ] --- | Check that setup dependencies, have proper bounds. --- In particular, @base@ and @Cabal@ upper bounds are mandatory. -checkSetupVersions :: GenericPackageDescription -> [PackageCheck] -checkSetupVersions pkg = - [ emitError nameStr - | (name, vr) <- Map.toList deps - , not (hasUpperBound vr) - , let nameStr = unPackageName name - , nameStr `elem` criticalPkgs - ] - where - criticalPkgs = ["Cabal", "base"] - deps = case typicalPkg pkg of - Right (pkgs', _) -> - Map.fromListWith intersectVersionRanges - [ (pname, vr) - | sbi <- maybeToList $ setupBuildInfo pkgs' - , Dependency pname vr _ <- setupDepends sbi - ] - _ -> Map.empty - emitError nm = - PackageDistInexcusable (UpperBoundSetup nm) - -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) - 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 - 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 [] - -- ------------------------------------------------------------ -- * Utils -- ------------------------------------------------------------ @@ -2692,26 +2525,24 @@ isGoodRelativeDirectoryPath = state0 -- | otherwise -> 4 -- @ --- --- TODO: What we really want to do is test if there exists any --- configuration in which the base version is unbounded above. --- However that's a bit tricky because there are many possible --- configurations. As a cheap easy and safe approximation we will --- pick a single "typical" configuration and check if that has an --- open upper bound. To get a typical configuration we finalise --- using no package index and the current platform. -typicalPkg :: GenericPackageDescription - -> Either [Dependency] (PackageDescription, FlagAssignment) -typicalPkg = finalizePD - mempty defaultComponentRequestedSpec (const True) - buildPlatform - (unknownCompilerInfo - (CompilerId buildCompilerFlavor nullVersion) - NoAbiTag) - [] - 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." + +----------------------- +-- REMOVE ME +----------------------- + +checkConfiguredPackage :: p -> [a] +checkConfiguredPackage _ = [] + +checkXXXPROVA :: Bool -> PackageCheck -> Maybe PackageCheck +checkXXXPROVA False _ = Nothing +checkXXXPROVA True pc = Just pc + +checkPackageFileNamesWithGlobXXX :: p -> [a] +checkPackageFileNamesWithGlobXXX _ = [] + +-- xxx vedi se setupbuildinfo viene preso nelle «all build info» diff --git a/Cabal/src/Distribution/Simple/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs index 26022b9aa0b..2a5cb5b675f 100644 --- a/Cabal/src/Distribution/Simple/Configure.hs +++ b/Cabal/src/Distribution/Simple/Configure.hs @@ -1961,7 +1961,7 @@ checkPackageProblems :: Verbosity -> IO () checkPackageProblems verbosity dir gpkg pkg = do ioChecks <- checkPackageFiles verbosity pkg dir - let pureChecks = checkPackage gpkg (Just pkg) + let pureChecks = checkPackage gpkg -- xxx WARN CHECK THIS TEST THIS XXX (errors, warnings) = partitionEithers (M.mapMaybe classEW $ pureChecks ++ ioChecks) if null errors diff --git a/cabal-install/src/Distribution/Client/Check.hs b/cabal-install/src/Distribution/Client/Check.hs index b08fa164e5d..4425d1c849c 100644 --- a/cabal-install/src/Distribution/Client/Check.hs +++ b/cabal-install/src/Distribution/Client/Check.hs @@ -56,22 +56,9 @@ check verbosity = do (ws, ppd) <- readGenericPackageDescriptionCheck verbosity pdfile -- convert parse warnings into PackageChecks let ws' = map (wrapParseWarning pdfile) ws - -- flatten the generic package description into a regular package - -- description - -- TODO: this may give more warnings than it should give; - -- consider two branches of a condition, one saying - -- ghc-options: -Wall - -- and the other - -- ghc-options: -Werror - -- joined into - -- ghc-options: -Wall -Werror - -- checkPackages will yield a warning on the last line, but it - -- would not on each individual branch. - -- However, this is the same way hackage does it, so we will yield - -- the exact same errors as it will. let pkg_desc = flattenPackageDescription ppd ioChecks <- checkPackageFiles verbosity pkg_desc "." - let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc) ++ ws' + let packageChecks = ioChecks ++ checkPackage ppd ++ ws' buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ] buildWarning = [ x | x@PackageBuildWarning {} <- packageChecks ] distSuspicious = [ x | x@PackageDistSuspicious {} <- packageChecks ] diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs index 157f5c3cc2f..3bc293871a5 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -477,7 +477,7 @@ exAvSrcPkg ex = -- We ignore these warnings because some unit tests test that the -- solver allows unknown extensions/languages when the compiler -- supports them. - let checks = C.checkPackage (srcpkgDescription package) Nothing + let checks = C.checkPackage (srcpkgDescription package) in filter (not . isUnknownLangExt) checks in if null pkgCheckErrors then package diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/NoDupNames/cabal.out b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/NoDupNames/cabal.out index d1b03551437..afd7026b73f 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/NoDupNames/cabal.out +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/NoDupNames/cabal.out @@ -1,3 +1,4 @@ # cabal check Warning: The package will not build sanely due to these errors: Warning: Duplicate sections: dup. The name of every library, executable, test suite, and benchmark section in the package must be unique. +Warning: Hackage would reject this package.