diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs index 198ee83658a..731f8d85bee 100644 --- a/Cabal/src/Distribution/PackageDescription/Check.hs +++ b/Cabal/src/Distribution/PackageDescription/Check.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + ----------------------------------------------------------------------------- -- | -- Module : Distribution.PackageDescription.Check @@ -81,9 +83,12 @@ 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 -- ------------------------------------------------------------ @@ -130,7 +135,7 @@ data CheckExplanation = | SignaturesCabal2 | AutogenNotExposed | AutogenIncludesNotIncluded - | NoMainIs Executable + | NoMainIs UnqualComponentName | NoHsLhsMain | MainCCabal1_18 | AutogenNoOther CEType UnqualComponentName @@ -293,8 +298,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 exeName) = + "No 'main-is' field found for executable " ++ prettyShow exeName ppExplanation NoHsLhsMain = "The 'main-is' field must specify a '.hs' or '.lhs' file " ++ "(even if it is generated by a preprocessor), " @@ -804,16 +809,555 @@ data PackageCheck = instance Show PackageCheck where show notice = ppExplanation (explanation notice) -check :: Bool -> PackageCheck -> Maybe PackageCheck -check False _ = Nothing -check True pc = Just pc +-- ------------------------------------------------------------ +-- * Check monad +-- ------------------------------------------------------------ + +{- TODO: + PR NOTES: + - deriving (Functor, Applicative, Monad)… can be written in full + (not using GeneralizedNewtypeDeriving) + 15/08 112 tests, 0 skipped, 0 unexpected passes, 100 unexpected fails. + 16/08 112 tests, 0 skipped, 0 unexpected passes, 96 unexpected fails. + 17/08 112 tests, 0 skipped, 0 unexpected passes, 95 unexpected fails. + 17/08 22 tests, 0 skipped, 0 unexpected passes, 17 unexpected fails. + 22/08 22 tests, 0 skipped, 0 unexpected passes, 13 unexpected fails. +-} + +-- xxx usare set invece di list? + +-- | 'CTCtx' collects information useful for the checks, mainly a buildup +-- of the various slices of the target (`a`, a Library, Executable, etc., +-- monoidal), dependencies, whether we are under a user flag. +-- +data CTCtx a = CTCtx { ctxTarget :: a, + ctxDependencies :: [Dependency], + ctxPackageFlag :: Bool } + deriving (Show, Eq, Ord) + +-- | The 'UnqualComponentName' function is to appropriately name in some +-- targets which need to be spoonfed (otherwise name appears as ""). +initCTCtx :: Monoid a => (UnqualComponentName -> a -> a) -> + UnqualComponentName -> CTCtx a +initCTCtx nf n = CTCtx (nf n mempty) [] False + +-- | Note how we “build up” target from various slices, for dependencies +-- the job is already done for us. +-- +updateCTCtx :: Monoid a => a -> [Dependency] -> CTCtx a -> CTCtx a +updateCTCtx t ds ctx = ctx { ctxTarget = ctxTarget ctx <> t, + ctxDependencies = ds } + +-- | 'annotateTree' takes advantage of the 'CondTree' structure for context +-- aware checking. +-- +annotateTree :: Monoid a => CTCtx a -> + CondTree ConfVar [Dependency] a -> + CondTree ConfVar (CTCtx a) () +annotateTree ctx (CondNode t ds brs) = + let ctx' = updateCTCtx t ds ctx + in CondNode () ctx' (map (annotateBranch ctx') brs) + where + annotateBranch wctx (CondBranch cond t mf) = + let uf = isPkgFlagCond cond + wctx' = wctx { ctxPackageFlag = ctxPackageFlag wctx || uf } + in CondBranch cond (annotateTree wctx' t) + (fmap (annotateTree wctx') mf) + + isPackageFlag :: ConfVar -> Bool + isPackageFlag (PackageFlag _) = True + isPackageFlag otherwise = False + + -- xxx and for turned off by default flags? + isPkgFlagCond :: Condition ConfVar -> Bool + isPkgFlagCond (Var v) = isPackageFlag v + isPkgFlagCond (CAnd ca cb) = isPkgFlagCond ca || isPkgFlagCond cb + isPkgFlagCond _ = False + -- xxx scrivi che potrebbe essere fatto con traverse + +-- | Context to our checks. E.g: are we under a user-defined flag? +-- Or in a conditional part of the .cabal file? +-- +data CheckCtx = CheckCtx { ccTargetNames :: [UnqualComponentName] } + -- CheckCtx is relatively small, so there is no cogent reason + -- to break it up in parts for different checks. + -- *If* it becomes unwieldy, a good way to separate concerns + -- without breaking it up would be to use HasNames m => … + -- typeclasses. + +-- | Empty 'CheckCtx'. +pristineCheckCtx :: CheckCtx +pristineCheckCtx = CheckCtx [] + +-- | Check monad, carrying a context, collecting 'PackageCheck's. +-- +newtype CheckM a = CheckM ( RWS.RWS () [PackageCheck] CheckCtx a ) + deriving (Functor, Applicative, Monad, + MonadState CheckCtx, MonadWriter [PackageCheck]) + -- xxx RWS or simply read+write? + -- xxx limit interface here? + -- sì, non autoderivare reader/writer + +check :: Bool -> PackageCheck -> CheckM () +check b ct = when b (tell [ct]) + +-- vp: version of the package, vc: version to match +checkSpecVer :: CabalSpecVersion -> CabalSpecVersion -> Bool -> + PackageCheck -> CheckM () +checkSpecVer vp vc cond c + | vp >= vc = return () + | otherwise = check cond c + +-- xxx add desc +-- xxx elimina Maybe packagedescription? +checkPackage :: GenericPackageDescription -> Maybe PackageDescription -> + [PackageCheck] +checkPackage gpd mpd = + let (CheckM cm) = checkPackageM gpd + (_, cs) = RWS.evalRWS cm () pristineCheckCtx + in cs + +-- xxx move these functions from here +-- 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. +-- +-- We don’t of course use RecordWildCards or similar because compilation +-- breakage gently encourages the possible need to write more checks. +checkPackageM :: GenericPackageDescription -> CheckM () +checkPackageM + pkg@(GenericPackageDescription + -- xxx elmina pkg + packageDescription_ gpdScannedVersion_ genPackageFlags_ + condLibrary_ condSubLibraries_ condForeignLibs_ condExecutables_ + condTestSuites_ condBenchmarks_) + = do + -- xxx Il Just lo uso qui + -- Cabal/src/Distribution/Simple/Configure.hs + -- e qui + -- cabal-install/src/Distribution/Client/Check.hs + + checkPackageDesc 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. + let names = concat [map fst condSubLibraries_, + map fst condExecutables_, + map fst condTestSuites_, + map fst condBenchmarks_] + dupes = dups names + check (not . null $ dups names) + (PackageBuildImpossible $ DuplicateSections dupes) + + -- xxx questo muovilo via + -- It is OK for executables to have the same name! + let subLibNames = map fst condSubLibraries_ + check (any (== prettyShow (packageName packageDescription_)) + (prettyShow <$> subLibNames)) + (PackageBuildImpossible $ IllegalLibraryName packageDescription_) + + case condLibrary_ of + Just cl -> (checkCondTarget (checkLibrary False) (const id)) (undefined, cl) + Nothing -> return () -- xxx elimia questo + -- mapM_ checkLibrary condSubLibraries _ + let ver = specVersion packageDescription_ + mapM_ (checkCondTarget + (checkLibrary False) + (\u l -> l {libName = maybeToLibraryName (Just u)})) + condSubLibraries_ + mapM_ (checkCondTarget + (checkExecutable (package packageDescription_) ver) + (const id)) + condExecutables_ + mapM_ (checkCondTarget + (checkTestSuite ver) + (\u l -> l {testName = u})) + condTestSuites_ + mapM_ (checkCondTarget + checkBenchmark + (\u l -> l {benchmarkName = u})) + condBenchmarks_ + +checkPackageDesc :: PackageDescription -> CheckM () +checkPackageDesc + (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 + + -- Remember that this PackageDescription is *not* a configured + -- package! Hence we will perform here check about missing fields, + -- etc. but traverse GenericPackageDescription for tests related + -- to libraries etc. + -- xxx qui no lo sai per davvero + + -- xxx come fare che non possano essere utilizzati? + -- xxx segna bug «rimuovi missing field/desc or field/desc, useless» + + -- xxx `name` is caught at parse level, remove this test + check (null . unPackageName . packageName $ package_) + (PackageBuildImpossible NoNameField) + -- xxx `version` is caught at parse level, remove this test + check (nullVersion == packageVersion package_) + (PackageBuildImpossible NoVersionField) + +-- xxx rimetti in batta dopo! +-- -- missing fields +-- 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_]) +-- (PackageDistSuspicious $ MissingField CEFSynOrDesc) + +-- -- xxx questo check non funziona? +-- check (ShortText.length synopsis_ > 80) +-- (PackageDistSuspicious undefined) + + where + checkNull :: ShortText.ShortText -> PackageCheck -> CheckM () + checkNull st c = check (ShortText.null st) c + +-- xxx remove Show +checkCondTarget :: (Show a, Monoid a) => + (a -> CheckM ()) -> + (UnqualComponentName -> a -> a) -> + (UnqualComponentName, CondTree ConfVar [Dependency] a) -> + CheckM () +checkCondTarget cf nf (unqualName, ct) = + let ct' = annotateTree (initCTCtx nf unqualName) ct + in vNode ct' + -- xxx non va bene cambia! + where + -- xxx posso farlo con altro? + -- xxx aggiungi vnode coso + vNode (CondNode _ wctx []) = cf (ctxTarget wctx) + vBranc (CondBranch _ t mt) = undefined + -- xxx qui undefined cambia + + +-- ------------------------------------------------------------ +-- * Targets +-- ------------------------------------------------------------ + +-- xxx bool put it outside and in context +checkLibrary :: Bool -> Library -> CheckM () + -- xxx isSub not good! +checkLibrary isSub lib@(Library + libName_ exposedModules_ reexportedModules_ + signatures_ libExposed_ libVisibility_ + libBuildInfo_) = do + +-- xxx reinserisci +-- -- The public 'library' gets special dispensation, because it +-- -- is common practice to export a library and name the executable +-- -- the same as the package. +-- maybe (return ()) checkDupName (libraryNameString libName_) + + check (libName_ == LMainLibName && isSub) + (PackageBuildImpossible UnnamedInternal) + + -- TODO: This check is bogus if a required-signature was passed through + -- xxx qui lib non ci va + check (null (explicitLibModules lib) && null reexportedModules_) + (PackageDistSuspiciousWarn (NoModulesExposed lib)) + +-- -- check use of signatures sections +-- , checkVersion CabalSpecV2_0 (not (null (signatures lib))) $ +-- PackageDistInexcusable SignaturesCabal2 + -- xxx questo viene preso a parse! + + 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) + -- xxx anche qua lib non va bene + + checkBuildInfo BITLib libBuildInfo_ + + where + allExplicitIncludes :: L.HasBuildInfo a => a -> [FilePath] + allExplicitIncludes x = view L.includes x ++ + view L.installIncludes x + +checkExecutable :: PackageId -> CabalSpecVersion -> Executable -> CheckM () +checkExecutable pid v 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 v 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) + -- xxx vedi se riesci a rimuovere exe da questi due + + checkBuildInfo BITOther buildInfo_ + +checkTestSuite :: CabalSpecVersion -> TestSuite -> CheckM () +checkTestSuite v ts@(TestSuite + testName_ testInterface_ testBuildInfo_ + testCodeGenerators_) = do + + -- xxx caught by the parser, can remove safely + case testInterface_ of + TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> + tell [PackageBuildWarning $ TestsuiteTypeNotKnown tt] + TestSuiteUnsupported tt -> + tell [PackageBuildWarning $ TestsuiteNotSupported tt] + _ -> return () + + check mainIsWrongExt + (PackageBuildImpossible NoHsLhsMain) + + checkSpecVer v CabalSpecV1_18 + (mainIsNotHsExt && not mainIsWrongExt) + (PackageDistInexcusable MainCCabal1_18) + + -- xxx autogen abstract or document + 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 + 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 + + -- xxx possibly caught by the parser + case benchmarkInterface_ of + BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> + tell [PackageBuildWarning $ BenchmarkTypeNotKnown tt] + BenchmarkUnsupported tt -> + tell [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 + +checkBuildInfo :: BITarget -> BuildInfo -> CheckM () +checkBuildInfo t bi@(BuildInfo _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ + _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ + _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ + _) = do + -- xxx elimina _ qui + + checkGHCOptions "ghc-options" t (hcOptions GHC bi) + checkGHCOptions "ghc-prof-options" t (hcProfOptions GHC bi) + checkGHCOptions "ghc-shared-options" t (hcSharedOptions GHC 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 + -- xxx e per l’exe??? + -- xxx meglio lib e nonlib + -- xxx other rinomina + -- xxx controlla prenda anche foreign libs + -- xxx ricontrolla cosa è all ghc options + where + checkFlags :: [String] -> PackageCheck -> CheckM () + checkFlags fs ck = check (any (`elem` fs) opts) ck + + 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)] + + 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 [] = [] + +checkAlternatives :: String -> String -> [(String, String)] + -> CheckM () +checkAlternatives badField goodField flags = do + let (badFlags, _) = unzip flags + check (not $ null badFlags) + (PackageBuildWarning $ OptAlternatives badField goodField flags) -checkSpecVersion :: PackageDescription -> CabalSpecVersion -> Bool -> PackageCheck - -> Maybe PackageCheck -checkSpecVersion pkg specver cond pc - | specVersion pkg >= specver = Nothing - | otherwise = check cond pc +{- -- ------------------------------------------------------------ -- * Standard checks -- ------------------------------------------------------------ @@ -849,7 +1393,6 @@ checkPackage gpkg mpkg = -- we should always know the GenericPackageDescription checkConfiguredPackage :: PackageDescription -> [PackageCheck] checkConfiguredPackage pkg = - checkSanity pkg ++ checkFields pkg ++ checkLicense pkg ++ checkSourceRepos pkg @@ -860,188 +1403,6 @@ checkConfiguredPackage pkg = ++ checkPaths pkg ++ checkCabalVersion pkg - --- ------------------------------------------------------------ --- * Basic sanity checks --- ------------------------------------------------------------ - --- | Check that this package description is sane. --- -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 - -- ------------------------------------------------------------ -- * Additional pure checks -- ------------------------------------------------------------ @@ -1077,25 +1438,10 @@ checkFields pkg = , 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 - + -- xxx questo vedi se metterlo in un ticket , check (ShortText.length (synopsis pkg) > 80) $ PackageDistSuspicious SynopsisTooLong @@ -1307,182 +1653,6 @@ checkSourceRepos 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) ] - ] - - 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 @@ -1534,13 +1704,6 @@ checkCPPOptions pkg = catMaybes where all_cppOptions = [ opts | bi <- allBuildInfo pkg, opts <- cppOptions bi ] -checkAlternatives :: String -> String -> [(String, String)] - -> Maybe PackageCheck -checkAlternatives badField goodField flags = - check (not (null badFlags)) $ - PackageBuildWarning (OptAlternatives badField goodField flags) - where (badFlags, _) = unzip flags - data PathKind = PathKindFile | PathKindDirectory @@ -2452,6 +2615,7 @@ checkDuplicateModules pkg = (PotentialDupModule s dupLibsStrict)] else [] +-} -- ------------------------------------------------------------ -- * Utils -- ------------------------------------------------------------ @@ -2709,3 +2873,13 @@ 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." + +----------------------- +-- XXX REMMOVE ME +----------------------- + +checkConfiguredPackage _ = [] +checkPackageFiles _ _ _ = return [] +checkPackageContent _ _ = return [] +data CheckPackageContentOps +checkPackageFileNames _ = [] 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.