module Distribution.PackageDescription.Check (
PackageCheck(..),
checkPackage,
checkConfiguredPackage,
checkPackageFiles,
checkPackageContent,
CheckPackageContentOps(..),
checkPackageFileNames,
) where
import Distribution.PackageDescription
import Distribution.PackageDescription.Configuration
import Distribution.Compiler
import Distribution.System
import Distribution.License
import Distribution.Simple.CCompiler
import Distribution.Simple.Utils hiding (findPackageDesc, notice)
import Distribution.Version
import Distribution.Package
import Distribution.Text
import Language.Haskell.Extension
import Data.Maybe
( isNothing, isJust, catMaybes, mapMaybe, maybeToList, fromMaybe )
import Data.List (sort, group, isPrefixOf, nub, find)
import Control.Monad
( filterM, liftM )
import qualified System.Directory as System
( doesFileExist, doesDirectoryExist )
import qualified Data.Map as Map
import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint ((<>), (<+>))
import qualified System.Directory (getDirectoryContents)
import System.IO (openBinaryFile, IOMode(ReadMode), hGetContents)
import System.FilePath
( (</>), takeExtension, isRelative, isAbsolute
, splitDirectories, splitPath, splitExtension )
import System.FilePath.Windows as FilePath.Windows
( isValid )
data PackageCheck =
PackageBuildImpossible { explanation :: String }
| PackageBuildWarning { explanation :: String }
| PackageDistSuspicious { explanation :: String }
| PackageDistSuspiciousWarn { explanation :: String }
| PackageDistInexcusable { explanation :: String }
deriving (Eq)
instance Show PackageCheck where
show notice = explanation notice
check :: Bool -> PackageCheck -> Maybe PackageCheck
check False _ = Nothing
check True pc = Just pc
checkSpecVersion :: PackageDescription -> [Int] -> Bool -> PackageCheck
-> Maybe PackageCheck
checkSpecVersion pkg specver cond pc
| specVersion pkg >= Version specver [] = Nothing
| otherwise = check cond pc
checkPackage :: GenericPackageDescription
-> Maybe PackageDescription
-> [PackageCheck]
checkPackage gpkg mpkg =
checkConfiguredPackage pkg
++ checkConditionals gpkg
++ checkPackageVersions gpkg
++ checkDevelopmentOnlyFlags gpkg
where
pkg = fromMaybe (flattenPackageDescription gpkg) mpkg
checkConfiguredPackage :: PackageDescription -> [PackageCheck]
checkConfiguredPackage pkg =
checkSanity pkg
++ checkFields pkg
++ checkLicense pkg
++ checkSourceRepos pkg
++ checkGhcOptions pkg
++ checkCCOptions pkg
++ checkCPPOptions pkg
++ checkPaths pkg
++ checkCabalVersion pkg
checkSanity :: PackageDescription -> [PackageCheck]
checkSanity pkg =
catMaybes [
check (null . (\(PackageName n) -> n) . packageName $ pkg) $
PackageBuildImpossible "No 'name' field."
, check (null . versionBranch . packageVersion $ pkg) $
PackageBuildImpossible "No 'version' field."
, check (all ($ pkg) [ null . executables
, null . testSuites
, null . benchmarks
, isNothing . library ]) $
PackageBuildImpossible
"No executables, libraries, tests, or benchmarks found. Nothing to do."
, check (not (null duplicateNames)) $
PackageBuildImpossible $ "Duplicate sections: " ++ commaSep duplicateNames
++ ". The name of every executable, test suite, and benchmark section in"
++ " the package must be unique."
]
++ maybe [] (checkLibrary pkg) (library pkg)
++ concatMap (checkExecutable pkg) (executables pkg)
++ concatMap (checkTestSuite pkg) (testSuites pkg)
++ concatMap (checkBenchmark pkg) (benchmarks pkg)
++ catMaybes [
check (specVersion pkg > cabalVersion) $
PackageBuildImpossible $
"This package description follows version "
++ display (specVersion pkg) ++ " of the Cabal specification. This "
++ "tool only supports up to version " ++ display cabalVersion ++ "."
]
where
exeNames = map exeName $ executables pkg
testNames = map testName $ testSuites pkg
bmNames = map benchmarkName $ benchmarks pkg
duplicateNames = dups $ exeNames ++ testNames ++ bmNames
checkLibrary :: PackageDescription -> Library -> [PackageCheck]
checkLibrary pkg lib =
catMaybes [
check (not (null moduleDuplicates)) $
PackageBuildImpossible $
"Duplicate modules in library: "
++ commaSep (map display moduleDuplicates)
, checkVersion [1,21] (not (null (requiredSignatures lib))) $
PackageDistInexcusable $
"To use the 'required-signatures' field the package needs to specify "
++ "at least 'cabal-version: >= 1.21'."
, checkVersion [1,21] (not (null (exposedSignatures lib))) $
PackageDistInexcusable $
"To use the 'exposed-signatures' field the package needs to specify "
++ "at least 'cabal-version: >= 1.21'."
]
where
checkVersion :: [Int] -> Bool -> PackageCheck -> Maybe PackageCheck
checkVersion ver cond pc
| specVersion pkg >= Version ver [] = Nothing
| otherwise = check cond pc
moduleDuplicates = dups (libModules lib ++
map moduleReexportName (reexportedModules lib))
checkExecutable :: PackageDescription -> Executable -> [PackageCheck]
checkExecutable pkg exe =
catMaybes [
check (null (modulePath exe)) $
PackageBuildImpossible $
"No 'main-is' field found for executable " ++ exeName exe
, check (not (null (modulePath exe))
&& (not $ fileExtensionSupportedLanguage $ modulePath exe)) $
PackageBuildImpossible $
"The 'main-is' field must specify a '.hs' or '.lhs' file "
++ "(even if it is generated by a preprocessor), "
++ "or it may specify a C/C++/obj-C source file."
, checkSpecVersion pkg [1,17]
(fileExtensionSupportedLanguage (modulePath exe)
&& takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $
PackageDistInexcusable $
"The package uses a C/C++/obj-C source file for the 'main-is' field. "
++ "To use this feature you must specify 'cabal-version: >= 1.18'."
, check (not (null moduleDuplicates)) $
PackageBuildImpossible $
"Duplicate modules in executable '" ++ exeName exe ++ "': "
++ commaSep (map display moduleDuplicates)
]
where
moduleDuplicates = dups (exeModules exe)
checkTestSuite :: PackageDescription -> TestSuite -> [PackageCheck]
checkTestSuite pkg test =
catMaybes [
case testInterface test of
TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> Just $
PackageBuildWarning $
quote (display tt) ++ " is not a known type of test suite. "
++ "The known test suite types are: "
++ commaSep (map display knownTestTypes)
TestSuiteUnsupported tt -> Just $
PackageBuildWarning $
quote (display tt) ++ " is not a supported test suite version. "
++ "The known test suite types are: "
++ commaSep (map display knownTestTypes)
_ -> Nothing
, check (not $ null moduleDuplicates) $
PackageBuildImpossible $
"Duplicate modules in test suite '" ++ testName test ++ "': "
++ commaSep (map display moduleDuplicates)
, check mainIsWrongExt $
PackageBuildImpossible $
"The 'main-is' field must specify a '.hs' or '.lhs' file "
++ "(even if it is generated by a preprocessor), "
++ "or it may specify a C/C++/obj-C source file."
, checkSpecVersion pkg [1,17] (mainIsNotHsExt && not mainIsWrongExt) $
PackageDistInexcusable $
"The package uses a C/C++/obj-C source file for the 'main-is' field. "
++ "To use this feature you must specify 'cabal-version: >= 1.18'."
]
where
moduleDuplicates = dups $ testModules test
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 $
quote (display tt) ++ " is not a known type of benchmark. "
++ "The known benchmark types are: "
++ commaSep (map display knownBenchmarkTypes)
BenchmarkUnsupported tt -> Just $
PackageBuildWarning $
quote (display tt) ++ " is not a supported benchmark version. "
++ "The known benchmark types are: "
++ commaSep (map display knownBenchmarkTypes)
_ -> Nothing
, check (not $ null moduleDuplicates) $
PackageBuildImpossible $
"Duplicate modules in benchmark '" ++ benchmarkName bm ++ "': "
++ commaSep (map display moduleDuplicates)
, check mainIsWrongExt $
PackageBuildImpossible $
"The 'main-is' field must specify a '.hs' or '.lhs' file "
++ "(even if it is generated by a preprocessor)."
]
where
moduleDuplicates = dups $ benchmarkModules bm
mainIsWrongExt = case benchmarkInterface bm of
BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]
_ -> False
checkFields :: PackageDescription -> [PackageCheck]
checkFields pkg =
catMaybes [
check (not . FilePath.Windows.isValid . display . packageName $ pkg) $
PackageDistInexcusable $
"Unfortunately, the package name '" ++ display (packageName pkg)
++ "' is one of the reserved system file names on Windows. Many tools "
++ "need to convert package names to file names so using this name "
++ "would cause problems."
, check (isNothing (buildType pkg)) $
PackageBuildWarning $
"No 'build-type' specified. If you do not need a custom Setup.hs or "
++ "./configure script then use 'build-type: Simple'."
, case buildType pkg of
Just (UnknownBuildType unknown) -> Just $
PackageBuildWarning $
quote unknown ++ " is not a known 'build-type'. "
++ "The known build types are: "
++ commaSep (map display knownBuildTypes)
_ -> Nothing
, check (isJust (setupBuildInfo pkg) && buildType pkg /= Just Custom) $
PackageBuildWarning $
"Ignoring the 'custom-setup' section because the 'build-type' is "
++ "not 'Custom'. Use 'build-type: Custom' if you need to use a "
++ "custom Setup.hs script."
, check (not (null unknownCompilers)) $
PackageBuildWarning $
"Unknown compiler " ++ commaSep (map quote unknownCompilers)
++ " in 'tested-with' field."
, check (not (null unknownLanguages)) $
PackageBuildWarning $
"Unknown languages: " ++ commaSep unknownLanguages
, check (not (null unknownExtensions)) $
PackageBuildWarning $
"Unknown extensions: " ++ commaSep unknownExtensions
, check (not (null languagesUsedAsExtensions)) $
PackageBuildWarning $
"Languages listed as extensions: "
++ commaSep languagesUsedAsExtensions
++ ". Languages must be specified in either the 'default-language' "
++ " or the 'other-languages' field."
, check (not (null ourDeprecatedExtensions)) $
PackageDistSuspicious $
"Deprecated extensions: "
++ commaSep (map (quote . display . fst) ourDeprecatedExtensions)
++ ". " ++ unwords
[ "Instead of '" ++ display ext
++ "' use '" ++ display replacement ++ "'."
| (ext, Just replacement) <- ourDeprecatedExtensions ]
, check (null (category pkg)) $
PackageDistSuspicious "No 'category' field."
, check (null (maintainer pkg)) $
PackageDistSuspicious "No 'maintainer' field."
, check (null (synopsis pkg) && null (description pkg)) $
PackageDistInexcusable "No 'synopsis' or 'description' field."
, check (null (description pkg) && not (null (synopsis pkg))) $
PackageDistSuspicious "No 'description' field."
, check (null (synopsis pkg) && not (null (description pkg))) $
PackageDistSuspicious "No 'synopsis' field."
, check (length (synopsis pkg) >= 80) $
PackageDistSuspicious
"The 'synopsis' field is rather long (max 80 chars is recommended)."
, check (not (null testedWithImpossibleRanges)) $
PackageDistInexcusable $
"Invalid 'tested-with' version range: "
++ commaSep (map display testedWithImpossibleRanges)
++ ". To indicate that you have tested a package with multiple "
++ "different versions of the same compiler use multiple entries, "
++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not "
++ "'tested-with: GHC==6.10.4 && ==6.12.3'."
]
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 display 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 display knownLanguages ]
testedWithImpossibleRanges =
[ Dependency (PackageName (display compiler)) vr
| (compiler, vr) <- testedWith pkg
, isNoVersion vr ]
checkLicense :: PackageDescription -> [PackageCheck]
checkLicense pkg =
catMaybes [
check (license pkg == UnspecifiedLicense) $
PackageDistInexcusable
"The 'license' field is missing."
, check (license pkg == AllRightsReserved) $
PackageDistSuspicious
"The 'license' is AllRightsReserved. Is that really what you want?"
, case license pkg of
UnknownLicense l -> Just $
PackageBuildWarning $
quote ("license: " ++ l) ++ " is not a recognised license. The "
++ "known licenses are: "
++ commaSep (map display knownLicenses)
_ -> Nothing
, check (license pkg == BSD4) $
PackageDistSuspicious $
"Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' "
++ "refers to the old 4-clause BSD license with the advertising "
++ "clause. 'BSD3' refers the new 3-clause BSD license."
, case unknownLicenseVersion (license pkg) of
Just knownVersions -> Just $
PackageDistSuspicious $
"'license: " ++ display (license pkg) ++ "' is not a known "
++ "version of that license. The known versions are "
++ commaSep (map display knownVersions)
++ ". If this is not a mistake and you think it should be a known "
++ "version then please file a ticket."
_ -> Nothing
, check (license pkg `notElem` [ AllRightsReserved
, UnspecifiedLicense, PublicDomain]
&& null (licenseFiles pkg)) $
PackageDistSuspicious "A 'license-file' is not specified."
]
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
checkSourceRepos :: PackageDescription -> [PackageCheck]
checkSourceRepos pkg =
catMaybes $ concat [[
case repoKind repo of
RepoKindUnknown kind -> Just $ PackageDistInexcusable $
quote kind ++ " is not a recognised kind of source-repository. "
++ "The repo kind is usually 'head' or 'this'"
_ -> Nothing
, check (isNothing (repoType repo)) $
PackageDistInexcusable
"The source-repository 'type' is a required field."
, check (isNothing (repoLocation repo)) $
PackageDistInexcusable
"The source-repository 'location' is a required field."
, check (repoType repo == Just CVS && isNothing (repoModule repo)) $
PackageDistInexcusable
"For a CVS source-repository, the 'module' is a required field."
, check (repoKind repo == RepoThis && isNothing (repoTag repo)) $
PackageDistInexcusable $
"For the 'this' kind of source-repository, the 'tag' is a required "
++ "field. It should specify the tag corresponding to this version "
++ "or release of the package."
, check (maybe False System.FilePath.isAbsolute (repoSubdir repo)) $
PackageDistInexcusable
"The 'subdir' field of a source-repository must be a relative path."
]
| repo <- sourceRepos pkg ]
checkGhcOptions :: PackageDescription -> [PackageCheck]
checkGhcOptions pkg =
catMaybes [
checkFlags ["-fasm"] $
PackageDistInexcusable $
"'ghc-options: -fasm' is unnecessary and will not work on CPU "
++ "architectures other than x86, x86-64, ppc or sparc."
, checkFlags ["-fvia-C"] $
PackageDistSuspicious $
"'ghc-options: -fvia-C' is usually unnecessary. If your package "
++ "needs -via-C for correctness rather than performance then it "
++ "is using the FFI incorrectly and will probably not work with GHC "
++ "6.10 or later."
, checkFlags ["-fhpc"] $
PackageDistInexcusable $
"'ghc-options: -fhpc' is not not necessary. Use the configure flag "
++ " --enable-coverage instead."
, checkFlags ["-prof"] $
PackageBuildWarning $
"'ghc-options: -prof' is not necessary and will lead to problems "
++ "when used on a library. Use the configure flag "
++ "--enable-library-profiling and/or --enable-profiling."
, checkFlags ["-o"] $
PackageBuildWarning $
"'ghc-options: -o' is not needed. "
++ "The output files are named automatically."
, checkFlags ["-hide-package"] $
PackageBuildWarning $
"'ghc-options: -hide-package' is never needed. "
++ "Cabal hides all packages."
, checkFlags ["--make"] $
PackageBuildWarning $
"'ghc-options: --make' is never needed. Cabal uses this automatically."
, checkFlags ["-main-is"] $
PackageDistSuspicious $
"'ghc-options: -main-is' is not portable."
, checkFlags ["-O0", "-Onot"] $
PackageDistSuspicious $
"'ghc-options: -O0' is not needed. "
++ "Use the --disable-optimization configure flag."
, checkFlags [ "-O", "-O1"] $
PackageDistInexcusable $
"'ghc-options: -O' is not needed. "
++ "Cabal automatically adds the '-O' flag. "
++ "Setting it yourself interferes with the --disable-optimization flag."
, checkFlags ["-O2"] $
PackageDistSuspiciousWarn $
"'ghc-options: -O2' is rarely needed. "
++ "Check that it is giving a real benefit "
++ "and not just imposing longer compile times on your users."
, checkFlags ["-split-objs"] $
PackageBuildWarning $
"'ghc-options: -split-objs' is not needed. "
++ "Use the --enable-split-objs configure flag."
, checkFlags ["-optl-Wl,-s", "-optl-s"] $
PackageDistInexcusable $
"'ghc-options: -optl-Wl,-s' is not needed and is not portable to all"
++ " operating systems. Cabal 1.4 and later automatically strip"
++ " executables. Cabal also has a flag --disable-executable-stripping"
++ " which is necessary when building packages for some Linux"
++ " distributions and using '-optl-Wl,-s' prevents that from working."
, checkFlags ["-fglasgow-exts"] $
PackageDistSuspicious $
"Instead of 'ghc-options: -fglasgow-exts' it is preferable to use "
++ "the 'extensions' field."
, check ("-threaded" `elem` lib_ghc_options) $
PackageBuildWarning $
"'ghc-options: -threaded' has no effect for libraries. It should "
++ "only be used for executables."
, check ("-rtsopts" `elem` lib_ghc_options) $
PackageBuildWarning $
"'ghc-options: -rtsopts' has no effect for libraries. It should "
++ "only be used for executables."
, check (any (\opt -> "-with-rtsopts" `isPrefixOf` opt) lib_ghc_options) $
PackageBuildWarning $
"'ghc-options: -with-rtsopts' has no effect for libraries. It "
++ "should only be used for executables."
, checkAlternatives "ghc-options" "extensions"
[ (flag, display extension) | flag <- all_ghc_options
, Just extension <- [ghcExtension flag] ]
, checkAlternatives "ghc-options" "extensions"
[ (flag, extension) | flag@('-':'X':extension) <- all_ghc_options ]
, checkAlternatives "ghc-options" "cpp-options" $
[ (flag, flag) | flag@('-':'D':_) <- all_ghc_options ]
++ [ (flag, flag) | flag@('-':'U':_) <- all_ghc_options ]
, checkAlternatives "ghc-options" "include-dirs"
[ (flag, dir) | flag@('-':'I':dir) <- all_ghc_options ]
, checkAlternatives "ghc-options" "extra-libraries"
[ (flag, lib) | flag@('-':'l':lib) <- all_ghc_options ]
, checkAlternatives "ghc-options" "extra-lib-dirs"
[ (flag, dir) | flag@('-':'L':dir) <- all_ghc_options ]
, checkAlternatives "ghc-options" "frameworks"
[ (flag, fmwk) | (flag@"-framework", fmwk) <-
zip all_ghc_options (safeTail all_ghc_options) ]
, checkAlternatives "ghc-options" "extra-framework-dirs"
[ (flag, dir) | (flag@"-framework-path", dir) <-
zip all_ghc_options (safeTail all_ghc_options) ]
]
where
all_ghc_options = concatMap get_ghc_options (allBuildInfo pkg)
lib_ghc_options = maybe [] (get_ghc_options . libBuildInfo) (library pkg)
get_ghc_options bi = hcOptions GHC bi ++ hcProfOptions GHC bi
++ hcSharedOptions GHC bi
checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck
checkFlags flags = check (any (`elem` flags) all_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)
checkCCOptions :: PackageDescription -> [PackageCheck]
checkCCOptions pkg =
catMaybes [
checkAlternatives "cc-options" "include-dirs"
[ (flag, dir) | flag@('-':'I':dir) <- all_ccOptions ]
, checkAlternatives "cc-options" "extra-libraries"
[ (flag, lib) | flag@('-':'l':lib) <- all_ccOptions ]
, checkAlternatives "cc-options" "extra-lib-dirs"
[ (flag, dir) | flag@('-':'L':dir) <- all_ccOptions ]
, 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 $
"'cc-options: -O[n]' is generally not needed. When building with "
++ " optimisations Cabal automatically adds '-O2' for C code. "
++ "Setting it yourself interferes with the --disable-optimization "
++ "flag."
]
where all_ccOptions = [ opts | bi <- allBuildInfo pkg
, opts <- ccOptions bi ]
all_ldOptions = [ opts | bi <- allBuildInfo pkg
, opts <- ldOptions bi ]
checkCCFlags :: [String] -> PackageCheck -> Maybe PackageCheck
checkCCFlags flags = check (any (`elem` flags) all_ccOptions)
checkCPPOptions :: PackageDescription -> [PackageCheck]
checkCPPOptions pkg =
catMaybes [
checkAlternatives "cpp-options" "include-dirs"
[ (flag, dir) | flag@('-':'I':dir) <- all_cppOptions]
]
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 $
"Instead of " ++ quote (badField ++ ": " ++ unwords badFlags)
++ " use " ++ quote (goodField ++ ": " ++ unwords goodFlags)
where (badFlags, goodFlags) = unzip flags
checkPaths :: PackageDescription -> [PackageCheck]
checkPaths pkg =
[ PackageBuildWarning $
quote (kind ++ ": " ++ path)
++ " is a relative path outside of the source tree. "
++ "This will not work when generating a tarball with 'sdist'."
| (path, kind) <- relPaths ++ absPaths
, isOutsideTree path ]
++
[ PackageDistInexcusable $
quote (kind ++ ": " ++ path) ++ " is an absolute path."
| (path, kind) <- relPaths
, isAbsolute path ]
++
[ PackageDistInexcusable $
quote (kind ++ ": " ++ path) ++ " points inside the 'dist' "
++ "directory. This is not reliable because the location of this "
++ "directory is configurable by the user (or package manager). In "
++ "addition the layout of the 'dist' directory is subject to change "
++ "in future versions of Cabal."
| (path, kind) <- relPaths ++ absPaths
, isInsideDist path ]
++
[ PackageDistInexcusable $
"The 'ghc-options' contains the path '" ++ path ++ "' which points "
++ "inside the 'dist' directory. This is not reliable because the "
++ "location of this directory is configurable by the user (or package "
++ "manager). In addition the layout of the 'dist' directory is subject "
++ "to change in future versions of Cabal."
| bi <- allBuildInfo pkg
, (GHC, flags) <- options bi
, path <- flags
, isInsideDist path ]
where
isOutsideTree path = case splitDirectories path of
"..":_ -> True
".":"..":_ -> True
_ -> False
isInsideDist path = case map lowercase (splitDirectories path) of
"dist" :_ -> True
".":"dist":_ -> True
_ -> False
relPaths =
[ (path, "extra-src-files") | path <- extraSrcFiles pkg ]
++ [ (path, "extra-tmp-files") | path <- extraTmpFiles pkg ]
++ [ (path, "extra-doc-files") | path <- extraDocFiles pkg ]
++ [ (path, "data-files") | path <- dataFiles pkg ]
++ [ (path, "data-dir") | path <- [dataDir pkg]]
++ [ (path, "license-file") | path <- licenseFiles pkg ]
++ concat
[ [ (path, "c-sources") | path <- cSources bi ]
++ [ (path, "js-sources") | path <- jsSources bi ]
++ [ (path, "install-includes") | path <- installIncludes bi ]
++ [ (path, "hs-source-dirs") | path <- hsSourceDirs bi ]
| bi <- allBuildInfo pkg ]
absPaths = concat
[ [ (path, "includes") | path <- includes bi ]
++ [ (path, "include-dirs") | path <- includeDirs bi ]
++ [ (path, "extra-lib-dirs") | path <- extraLibDirs bi ]
| bi <- allBuildInfo pkg ]
checkCabalVersion :: PackageDescription -> [PackageCheck]
checkCabalVersion pkg =
catMaybes [
check (specVersion pkg >= Version [1,10] []
&& not simpleSpecVersionRangeSyntax) $
PackageBuildWarning $
"Packages relying on Cabal 1.10 or later must only specify a "
++ "version range of the form 'cabal-version: >= x.y'. Use "
++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'."
, check (specVersion pkg < Version [1,9] []
&& not simpleSpecVersionRangeSyntax) $
PackageDistSuspicious $
"It is recommended that the 'cabal-version' field only specify a "
++ "version range of the form '>= x.y'. Use "
++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'. "
++ "Tools based on Cabal 1.10 and later will ignore upper bounds."
, checkVersion [1,12] simpleSpecVersionSyntax $
PackageBuildWarning $
"With Cabal 1.10 or earlier, the 'cabal-version' field must use "
++ "range syntax rather than a simple version number. Use "
++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'."
, checkVersion [1,8] (not (null $ testSuites pkg)) $
PackageDistInexcusable $
"The 'test-suite' section is new in Cabal 1.10. "
++ "Unfortunately it messes up the parser in older Cabal versions "
++ "so you must specify at least 'cabal-version: >= 1.8', but note "
++ "that only Cabal 1.10 and later can actually run such test suites."
, checkVersion [1,10] (any isJust (buildInfoField defaultLanguage)) $
PackageBuildWarning $
"To use the 'default-language' field the package needs to specify "
++ "at least 'cabal-version: >= 1.10'."
, check (specVersion pkg >= Version [1,10] []
&& (any isNothing (buildInfoField defaultLanguage))) $
PackageBuildWarning $
"Packages using 'cabal-version: >= 1.10' must specify the "
++ "'default-language' field for each component (e.g. Haskell98 or "
++ "Haskell2010). If a component uses different languages in "
++ "different modules then list the other ones in the "
++ "'other-languages' field."
, checkVersion [1,21]
(maybe False (not.null.reexportedModules) (library pkg)) $
PackageDistInexcusable $
"To use the 'reexported-module' field the package needs to specify "
++ "at least 'cabal-version: >= 1.21'."
, checkVersion [1,21] (not (null depsUsingThinningRenamingSyntax)) $
PackageDistInexcusable $
"The package uses "
++ "thinning and renaming in the 'build-depends' field: "
++ commaSep (map display depsUsingThinningRenamingSyntax)
++ ". To use this new syntax, the package needs to specify at least"
++ "'cabal-version: >= 1.21'."
, checkVersion [1,23] (any (not . null) (buildInfoField extraFrameworkDirs)) $
PackageDistSuspiciousWarn $
"To use the 'extra-framework-dirs' field the package needs to specify"
++ " at least 'cabal-version: >= 1.23'."
, checkVersion [1,10] (any (not . null) (buildInfoField defaultExtensions)) $
PackageBuildWarning $
"To use the 'default-extensions' field the package needs to specify "
++ "at least 'cabal-version: >= 1.10'."
, check (specVersion pkg >= Version [1,10] []
&& (any (not . null) (buildInfoField oldExtensions))) $
PackageBuildWarning $
"For packages using 'cabal-version: >= 1.10' the 'extensions' "
++ "field is deprecated. The new 'default-extensions' field lists "
++ "extensions that are used in all modules in the component, while "
++ "the 'other-extensions' field lists extensions that are used in "
++ "some modules, e.g. via the {-# LANGUAGE #-} pragma."
, checkVersion [1,8] (not (null versionRangeExpressions)) $
PackageDistInexcusable $
"The package uses full version-range expressions "
++ "in a 'build-depends' field: "
++ commaSep (map displayRawDependency versionRangeExpressions)
++ ". To use this new syntax the package needs to specify at least "
++ "'cabal-version: >= 1.8'. Alternatively, if broader compatibility "
++ "is important, then convert to conjunctive normal form, and use "
++ "multiple 'build-depends:' lines, one conjunct per line."
, checkVersion [1,6] (not (null depsUsingWildcardSyntax)) $
PackageDistInexcusable $
"The package uses wildcard syntax in the 'build-depends' field: "
++ commaSep (map display depsUsingWildcardSyntax)
++ ". To use this new syntax the package need to specify at least "
++ "'cabal-version: >= 1.6'. Alternatively, if broader compatibility "
++ "is important then use: " ++ commaSep
[ display (Dependency name (eliminateWildcardSyntax versionRange))
| Dependency name versionRange <- depsUsingWildcardSyntax ]
, checkVersion [1,8] (not (null testedWithVersionRangeExpressions)) $
PackageDistInexcusable $
"The package uses full version-range expressions "
++ "in a 'tested-with' field: "
++ commaSep (map displayRawDependency testedWithVersionRangeExpressions)
++ ". To use this new syntax the package needs to specify at least "
++ "'cabal-version: >= 1.8'."
, checkVersion [1,6] (not (null testedWithUsingWildcardSyntax)) $
PackageDistInexcusable $
"The package uses wildcard syntax in the 'tested-with' field: "
++ commaSep (map display testedWithUsingWildcardSyntax)
++ ". To use this new syntax the package need to specify at least "
++ "'cabal-version: >= 1.6'. Alternatively, if broader compatibility "
++ "is important then use: " ++ commaSep
[ display (Dependency name (eliminateWildcardSyntax versionRange))
| Dependency name versionRange <- testedWithUsingWildcardSyntax ]
, checkVersion [1,6] (not (null dataFilesUsingGlobSyntax)) $
PackageDistInexcusable $
"Using wildcards like "
++ commaSep (map quote $ take 3 dataFilesUsingGlobSyntax)
++ " in the 'data-files' field requires 'cabal-version: >= 1.6'. "
++ "Alternatively if you require compatibility with earlier Cabal "
++ "versions then list all the files explicitly."
, checkVersion [1,6] (not (null extraSrcFilesUsingGlobSyntax)) $
PackageDistInexcusable $
"Using wildcards like "
++ commaSep (map quote $ take 3 extraSrcFilesUsingGlobSyntax)
++ " in the 'extra-source-files' field requires "
++ "'cabal-version: >= 1.6'. Alternatively if you require "
++ "compatibility with earlier Cabal versions then list all the files "
++ "explicitly."
, checkVersion [1,6] (not (null (sourceRepos pkg))) $
PackageDistInexcusable $
"The 'source-repository' section is new in Cabal 1.6. "
++ "Unfortunately it messes up the parser in earlier Cabal versions "
++ "so you need to specify 'cabal-version: >= 1.6'."
, checkVersion [1,4] (license pkg `notElem` compatLicenses) $
PackageDistInexcusable $
"Unfortunately the license " ++ quote (display (license pkg))
++ " 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'."
, checkVersion [1,2,3] (not (null mentionedExtensionsThatNeedCabal12)) $
PackageDistInexcusable $
"Unfortunately the language extensions "
++ commaSep (map (quote . display) mentionedExtensionsThatNeedCabal12)
++ " break the parser in earlier Cabal versions so you need to "
++ "specify 'cabal-version: >= 1.2.3'. Alternatively if you require "
++ "compatibility with earlier Cabal versions then you may be able to "
++ "use an equivalent compiler-specific flag."
, checkVersion [1,4] (not (null mentionedExtensionsThatNeedCabal14)) $
PackageDistInexcusable $
"Unfortunately the language extensions "
++ commaSep (map (quote . display) mentionedExtensionsThatNeedCabal14)
++ " break 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 you may be able to "
++ "use an equivalent compiler-specific flag."
, check (specVersion pkg >= Version [1,23] []
&& isNothing (setupBuildInfo pkg)
&& buildType pkg == Just Custom) $
PackageBuildWarning $
"Packages using 'cabal-version: >= 1.23' with 'build-type: Custom' "
++ "must use a 'custom-setup' section with a 'setup-depends' field "
++ "that specifies the dependencies of the Setup.hs script itself. "
++ "The 'setup-depends' field uses the same syntax as 'build-depends', "
++ "so a simple example would be 'setup-depends: base, Cabal'."
, check (specVersion pkg < Version [1,23] []
&& isNothing (setupBuildInfo pkg)
&& buildType pkg == Just Custom) $
PackageDistSuspiciousWarn $
"From version 1.23 cabal supports specifiying explicit dependencies "
++ "for Custom setup scripts. Consider using cabal-version >= 1.23 and "
++ "adding a 'custom-setup' section with a 'setup-depends' field "
++ "that specifies the dependencies of the Setup.hs script itself. "
++ "The 'setup-depends' field uses the same syntax as 'build-depends', "
++ "so a simple example would be 'setup-depends: base, Cabal'."
]
where
checkVersion :: [Int] -> Bool -> PackageCheck -> Maybe PackageCheck
checkVersion ver cond pc
| specVersion pkg >= Version ver [] = Nothing
| otherwise = check cond pc
buildInfoField field = map field (allBuildInfo pkg)
dataFilesUsingGlobSyntax = filter usesGlobSyntax (dataFiles pkg)
extraSrcFilesUsingGlobSyntax = filter usesGlobSyntax (extraSrcFiles pkg)
usesGlobSyntax str = case parseFileGlob str of
Just (FileGlob _ _) -> True
_ -> False
versionRangeExpressions =
[ dep | dep@(Dependency _ vr) <- buildDepends pkg
, usesNewVersionRangeSyntax vr ]
testedWithVersionRangeExpressions =
[ Dependency (PackageName (display compiler)) vr
| (compiler, vr) <- testedWith pkg
, usesNewVersionRangeSyntax vr ]
simpleSpecVersionRangeSyntax =
either (const True)
(foldVersionRange'
True
(\_ -> False)
(\_ -> False) (\_ -> False)
(\_ -> True)
(\_ -> False)
(\_ _ -> False)
(\_ _ -> False) (\_ _ -> False)
id)
(specVersionRaw pkg)
simpleSpecVersionSyntax =
either (const True) (const False) (specVersionRaw pkg)
usesNewVersionRangeSyntax :: VersionRange -> Bool
usesNewVersionRangeSyntax =
(> 2)
. foldVersionRange'
(1 :: Int)
(const 1)
(const 1) (const 1)
(const 1) (const 1)
(const (const 1))
(+) (+)
(const 3)
depsUsingWildcardSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg
, usesWildcardSyntax vr ]
depsUsingThinningRenamingSyntax =
[ name
| bi <- allBuildInfo pkg
, (name, _) <- Map.toList (targetBuildRenaming bi) ]
testedWithUsingWildcardSyntax =
[ Dependency (PackageName (display compiler)) vr
| (compiler, vr) <- testedWith pkg
, usesWildcardSyntax vr ]
usesWildcardSyntax :: VersionRange -> Bool
usesWildcardSyntax =
foldVersionRange'
False (const False)
(const False) (const False)
(const False) (const False)
(\_ _ -> True)
(||) (||) id
eliminateWildcardSyntax =
foldVersionRange'
anyVersion thisVersion
laterVersion earlierVersion
orLaterVersion orEarlierVersion
(\v v' -> intersectVersionRanges (orLaterVersion v) (earlierVersion v'))
intersectVersionRanges unionVersionRanges id
compatLicenses = [ GPL Nothing, LGPL Nothing, AGPL Nothing, BSD3, BSD4
, PublicDomain, AllRightsReserved
, UnspecifiedLicense, OtherLicense ]
mentionedExtensions = [ ext | bi <- allBuildInfo pkg
, ext <- allExtensions bi ]
mentionedExtensionsThatNeedCabal12 =
nub (filter (`elem` compatExtensionsExtra) mentionedExtensions)
mentionedExtensionsThatNeedCabal14 =
nub (filter (`notElem` compatExtensions) mentionedExtensions)
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
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]
displayRawVersionRange :: VersionRange -> String
displayRawVersionRange =
Disp.render
. fst
. foldVersionRange'
( Disp.text "-any" , 0 :: Int)
(\v -> (Disp.text "==" <> disp v , 0))
(\v -> (Disp.char '>' <> disp v , 0))
(\v -> (Disp.char '<' <> disp v , 0))
(\v -> (Disp.text ">=" <> disp v , 0))
(\v -> (Disp.text "<=" <> disp v , 0))
(\v _ -> (Disp.text "==" <> dispWild v , 0))
(\(r1, p1) (r2, p2) ->
(punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2))
(\(r1, p1) (r2, p2) ->
(punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1))
(\(r, _ ) -> (Disp.parens r, 0))
where
dispWild (Version b _) =
Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b))
<> Disp.text ".*"
punct p p' | p < p' = Disp.parens
| otherwise = id
displayRawDependency :: Dependency -> String
displayRawDependency (Dependency pkg vr) =
display pkg ++ " " ++ displayRawVersionRange vr
checkPackageVersions :: GenericPackageDescription -> [PackageCheck]
checkPackageVersions pkg =
catMaybes [
check (not (boundedAbove baseDependency)) $
PackageDistInexcusable $
"The dependency 'build-depends: base' does not specify an upper "
++ "bound on the version number. Each major release of the 'base' "
++ "package changes the API in various ways and most packages will "
++ "need some changes to compile with it. The recommended practise "
++ "is to specify an upper bound on the version of the 'base' "
++ "package. This ensures your package will continue to build when a "
++ "new major version of the 'base' package is released. If you are "
++ "not sure what upper bound to use then use the next major "
++ "version. For example if you have tested your package with 'base' "
++ "version 4.5 and 4.6 then use 'build-depends: base >= 4.5 && < 4.7'."
]
where
finalised = finalizePackageDescription
[] (const True) buildPlatform
(unknownCompilerInfo
(CompilerId buildCompilerFlavor (Version [] [])) NoAbiTag)
[] pkg
baseDependency = case finalised of
Right (pkg', _) | not (null baseDeps) ->
foldr intersectVersionRanges anyVersion baseDeps
where
baseDeps =
[ vr | Dependency (PackageName "base") vr <- buildDepends pkg' ]
_ -> noVersion
boundedAbove :: VersionRange -> Bool
boundedAbove vr = case asVersionIntervals vr of
[] -> True
intervals -> case last intervals of
(_, UpperBound _ _) -> True
(_, NoUpperBound ) -> False
checkConditionals :: GenericPackageDescription -> [PackageCheck]
checkConditionals pkg =
catMaybes [
check (not $ null unknownOSs) $
PackageDistInexcusable $
"Unknown operating system name "
++ commaSep (map quote unknownOSs)
, check (not $ null unknownArches) $
PackageDistInexcusable $
"Unknown architecture name "
++ commaSep (map quote unknownArches)
, check (not $ null unknownImpls) $
PackageDistInexcusable $
"Unknown compiler name "
++ commaSep (map quote unknownImpls)
]
where
unknownOSs = [ os | OS (OtherOS os) <- conditions ]
unknownArches = [ arch | Arch (OtherArch arch) <- conditions ]
unknownImpls = [ impl | Impl (OtherCompiler impl) _ <- conditions ]
conditions = maybe [] fvs (condLibrary pkg)
++ concatMap (fvs . snd) (condExecutables pkg)
fvs (CondNode _ _ ifs) = concatMap compfv ifs
compfv (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
checkDevelopmentOnlyFlagsBuildInfo :: BuildInfo -> [PackageCheck]
checkDevelopmentOnlyFlagsBuildInfo bi =
catMaybes [
check has_WerrorWall $
PackageDistInexcusable $
"'ghc-options: -Wall -Werror' makes the package very easy to "
++ "break with future GHC versions because new GHC versions often "
++ "add new warnings. Use just 'ghc-options: -Wall' instead."
++ extraExplanation
, check (not has_WerrorWall && has_Werror) $
PackageDistInexcusable $
"'ghc-options: -Werror' makes the package easy to "
++ "break with future GHC versions because new GHC versions often "
++ "add new warnings. "
++ extraExplanation
, checkFlags ["-fdefer-type-errors"] $
PackageDistInexcusable $
"'ghc-options: -fdefer-type-errors' is fine during development but "
++ "is not appropriate for a distributed package. "
++ extraExplanation
, check (any (\opt -> "-d" `isPrefixOf` opt && opt /= "-dynamic")
ghc_options) $
PackageDistInexcusable $
"'ghc-options: -d*' debug flags are not appropriate "
++ "for a distributed package. "
++ extraExplanation
, checkFlags ["-fprof-auto", "-fprof-auto-top", "-fprof-auto-calls",
"-fprof-cafs", "-fno-prof-count-entries",
"-auto-all", "-auto", "-caf-all"] $
PackageDistSuspicious $
"'ghc-options: -fprof*' profiling flags are typically not "
++ "appropriate for a distributed library package. These flags are "
++ "useful to profile this package, but when profiling other packages "
++ "that use this one these flags clutter the profile output with "
++ "excessive detail. If you think other packages really want to see "
++ "cost centres from this package then use '-fprof-auto-exported' "
++ "which puts cost centres only on exported functions. "
++ extraExplanation
]
where
extraExplanation =
" 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."
has_WerrorWall = has_Werror && ( has_Wall || has_W )
has_Werror = "-Werror" `elem` ghc_options
has_Wall = "-Wall" `elem` ghc_options
has_W = "-W" `elem` ghc_options
ghc_options = hcOptions GHC bi ++ hcProfOptions GHC bi
++ hcSharedOptions GHC bi
checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck
checkFlags flags = check (any (`elem` flags) ghc_options)
checkDevelopmentOnlyFlags :: GenericPackageDescription -> [PackageCheck]
checkDevelopmentOnlyFlags pkg =
concatMap checkDevelopmentOnlyFlagsBuildInfo
[ bi
| (conditions, bi) <- allConditionalBuildInfo
, not (any guardedByManualFlag conditions) ]
where
guardedByManualFlag = definitelyFalse
definitelyFalse (Var (Flag 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 (Flag 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 buildInfo . snd)
(condExecutables pkg)
++ concatMap (collectCondTreePaths testBuildInfo . snd)
(condTestSuites pkg)
++ concatMap (collectCondTreePaths benchmarkBuildInfo . snd)
(condBenchmarks pkg)
collectCondTreePaths :: (a -> b)
-> CondTree v c a
-> [([Condition v], b)]
collectCondTreePaths mapData = go []
where
go conditions condNode =
(reverse conditions, mapData (condTreeData condNode))
: concat
[ go (condition:conditions) ifThen
| (condition, ifThen, _) <- condTreeComponents condNode ]
++ concat
[ go (condition:conditions) elseThen
| (condition, _, Just elseThen) <- condTreeComponents condNode ]
checkPackageFiles :: PackageDescription -> FilePath -> IO [PackageCheck]
checkPackageFiles pkg root = checkPackageContent checkFilesIO pkg
where
checkFilesIO = CheckPackageContentOps {
doesFileExist = System.doesFileExist . relative,
doesDirectoryExist = System.doesDirectoryExist . relative,
getDirectoryContents = System.Directory.getDirectoryContents . relative,
getFileContents = \f -> openBinaryFile (relative f) ReadMode >>= hGetContents
}
relative path = root </> path
data CheckPackageContentOps m = CheckPackageContentOps {
doesFileExist :: FilePath -> m Bool,
doesDirectoryExist :: FilePath -> m Bool,
getDirectoryContents :: FilePath -> m [FilePath],
getFileContents :: FilePath -> m String
}
checkPackageContent :: Monad m => CheckPackageContentOps m
-> PackageDescription
-> m [PackageCheck]
checkPackageContent ops pkg = do
cabalBomError <- checkCabalFileBOM ops
licenseErrors <- checkLicensesExist ops pkg
setupError <- checkSetupExists ops pkg
configureError <- checkConfigureExists ops pkg
localPathErrors <- checkLocalPathsExist ops pkg
vcsLocation <- checkMissingVcsInfo ops pkg
return $ licenseErrors
++ catMaybes [cabalBomError, setupError, configureError]
++ localPathErrors
++ vcsLocation
checkCabalFileBOM :: Monad m => CheckPackageContentOps m
-> m (Maybe PackageCheck)
checkCabalFileBOM ops = do
epdfile <- findPackageDesc ops
case epdfile of
Left pc -> return $ Just pc
Right pdfile -> (flip check pc . startsWithBOM . fromUTF8) `liftM` (getFileContents ops pdfile)
where pc = PackageDistInexcusable $
pdfile ++ " starts with an Unicode byte order mark (BOM). This may cause problems with older cabal versions."
findPackageDesc :: Monad m => CheckPackageContentOps m
-> m (Either PackageCheck FilePath)
findPackageDesc ops
= do let dir = "."
files <- getDirectoryContents ops dir
cabalFiles <- filterM (doesFileExist ops)
[ dir </> file
| file <- files
, let (name, ext) = splitExtension file
, not (null name) && ext == ".cabal" ]
case cabalFiles of
[] -> return (Left $ PackageBuildImpossible noDesc)
[cabalFile] -> return (Right cabalFile)
multiple -> return (Left $ PackageBuildImpossible $ multiDesc multiple)
where
noDesc :: String
noDesc = "No cabal file found.\n"
++ "Please create a package description file <pkgname>.cabal"
multiDesc :: [String] -> String
multiDesc l = "Multiple cabal files found.\n"
++ "Please use only one of: "
++ intercalate ", " l
checkLicensesExist :: Monad m => CheckPackageContentOps m
-> PackageDescription
-> m [PackageCheck]
checkLicensesExist ops pkg = do
exists <- mapM (doesFileExist ops) (licenseFiles pkg)
return
[ PackageBuildWarning $
"The '" ++ fieldname ++ "' field refers to the file "
++ quote file ++ " which does not exist."
| (file, False) <- zip (licenseFiles pkg) exists ]
where
fieldname | length (licenseFiles pkg) == 1 = "license-file"
| otherwise = "license-files"
checkSetupExists :: Monad m => CheckPackageContentOps m
-> PackageDescription
-> m (Maybe PackageCheck)
checkSetupExists ops pkg = do
let simpleBuild = buildType pkg == Just Simple
hsexists <- doesFileExist ops "Setup.hs"
lhsexists <- doesFileExist ops "Setup.lhs"
return $ check (not simpleBuild && not hsexists && not lhsexists) $
PackageDistInexcusable $
"The package is missing a Setup.hs or Setup.lhs script."
checkConfigureExists :: Monad m => CheckPackageContentOps m
-> PackageDescription
-> m (Maybe PackageCheck)
checkConfigureExists ops PackageDescription { buildType = Just Configure } = do
exists <- doesFileExist ops "configure"
return $ check (not exists) $
PackageBuildWarning $
"The 'build-type' is 'Configure' but there is no 'configure' script. "
++ "You probably need to run 'autoreconf -i' to generate it."
checkConfigureExists _ _ = return Nothing
checkLocalPathsExist :: Monad m => CheckPackageContentOps m
-> PackageDescription
-> m [PackageCheck]
checkLocalPathsExist ops pkg = do
let dirs = [ (dir, kind)
| bi <- allBuildInfo pkg
, (dir, kind) <-
[ (dir, "extra-lib-dirs") | dir <- extraLibDirs bi ]
++ [ (dir, "extra-framework-dirs")
| dir <- extraFrameworkDirs bi ]
++ [ (dir, "include-dirs") | dir <- includeDirs bi ]
++ [ (dir, "hs-source-dirs") | dir <- hsSourceDirs bi ]
, isRelative dir ]
missing <- filterM (liftM not . doesDirectoryExist ops . fst) dirs
return [ PackageBuildWarning {
explanation = quote (kind ++ ": " ++ dir)
++ " directory does not exist."
}
| (dir, kind) <- missing ]
checkMissingVcsInfo :: Monad m => CheckPackageContentOps m
-> PackageDescription
-> m [PackageCheck]
checkMissingVcsInfo ops pkg | null (sourceRepos pkg) = do
vcsInUse <- liftM or $ mapM (doesDirectoryExist ops) repoDirnames
if vcsInUse
then return [ PackageDistSuspicious message ]
else return []
where
repoDirnames = [ dirname | repo <- knownRepoTypes
, dirname <- repoTypeDirname repo ]
message = "When distributing packages it is encouraged to specify source "
++ "control information in the .cabal file using one or more "
++ "'source-repository' sections. See the Cabal user guide for "
++ "details."
checkMissingVcsInfo _ _ = return []
repoTypeDirname :: RepoType -> [FilePath]
repoTypeDirname Darcs = ["_darcs"]
repoTypeDirname Git = [".git"]
repoTypeDirname SVN = [".svn"]
repoTypeDirname CVS = ["CVS"]
repoTypeDirname Mercurial = [".hg"]
repoTypeDirname GnuArch = [".arch-params"]
repoTypeDirname Bazaar = [".bzr"]
repoTypeDirname Monotone = ["_MTN"]
repoTypeDirname _ = []
checkPackageFileNames :: [FilePath] -> [PackageCheck]
checkPackageFileNames files =
(take 1 . mapMaybe checkWindowsPath $ files)
++ (take 1 . mapMaybe checkTarPath $ files)
checkWindowsPath :: FilePath -> Maybe PackageCheck
checkWindowsPath path =
check (not $ FilePath.Windows.isValid path') $
PackageDistInexcusable $
"Unfortunately, the file " ++ quote path ++ " is not a valid file "
++ "name on Windows which would cause portability problems for this "
++ "package. Windows file names cannot contain any of the characters "
++ "\":*?<>|\" and there are a few reserved names including \"aux\", "
++ "\"nul\", \"con\", \"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"."
where
path' = ".\\" ++ path
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 (first:rest) -> case pack prefixMax remainder of
Left err -> Just err
Right [] -> Nothing
Right (_:_) -> Just noSplit
where
remainder = init first : 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 $
"The following file name is too long to store in a portable POSIX "
++ "format tar archive. The maximum length is 255 ASCII characters.\n"
++ "The file in question is:\n " ++ path
longName = PackageDistInexcusable $
"The following file name is too long to store in a portable POSIX "
++ "format tar archive. The maximum length for the name part (including "
++ "extension) is 100 ASCII characters. The maximum length for any "
++ "individual directory component is 155.\n"
++ "The file in question is:\n " ++ path
noSplit = PackageDistInexcusable $
"The following file name is too long to store in a portable POSIX "
++ "format tar archive. While the total length is less than 255 ASCII "
++ "characters, there are unfortunately further restrictions. It has to "
++ "be possible to split the file path on a directory separator into "
++ "two parts such that the first part fits in 155 characters or less "
++ "and the second part fits in 100 characters or less. Basically you "
++ "have to make the file name or directory names shorter, or you could "
++ "split a long directory name into nested subdirectories with shorter "
++ "names.\nThe file in question is:\n " ++ path
emptyName = PackageDistInexcusable $
"Encountered a file with an empty name, something is very wrong! "
++ "Files with an empty name cannot be stored in a tar archive or in "
++ "standard file systems."
quote :: String -> String
quote s = "'" ++ s ++ "'"
commaSep :: [String] -> String
commaSep = intercalate ", "
dups :: Ord a => [a] -> [a]
dups xs = [ x | (x:_:_) <- group (sort xs) ]
fileExtensionSupportedLanguage :: FilePath -> Bool
fileExtensionSupportedLanguage path =
isHaskell || isC
where
extension = takeExtension path
isHaskell = extension `elem` [".hs", ".lhs"]
isC = isJust (filenameCDialect extension)