-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.PackageDescription.Check
-- Copyright   :  Lennart Kolmodin 2008
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This has code for checking for various problems in packages. There is one
-- set of checks that just looks at a 'PackageDescription' in isolation and
-- another set of checks that also looks at files in the package. Some of the
-- checks are basic sanity checks, others are portability standards that we'd
-- like to encourage. There is a 'PackageCheck' type that distinguishes the
-- different kinds of check so we can see which ones are appropriate to report
-- in different situations. This code gets uses when configuring a package when
-- we consider only basic problems. The higher standard is uses when when
-- preparing a source tarball and by Hackage when uploading new packages. The
-- reason for this is that we want to hold packages that are expected to be
-- distributed to a higher standard than packages that are only ever expected
-- to be used on the author's own environment.

module Distribution.PackageDescription.Check (
        -- * Package Checking
        PackageCheck(..),
        checkPackage,
        checkConfiguredPackage,

        -- ** Checking package contents
        checkPackageFiles,
        checkPackageContent,
        CheckPackageContentOps(..),
        checkPackageFileNames,
  ) where

import Data.Maybe
         ( isNothing, isJust, catMaybes, 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 Distribution.PackageDescription
import Distribution.PackageDescription.Configuration
         ( flattenPackageDescription, finalizePackageDescription )
import Distribution.Compiler
         ( CompilerFlavor(..), buildCompilerFlavor, CompilerId(..)
         , unknownCompilerInfo, AbiTag(..) )
import Distribution.System
         ( OS(..), Arch(..), buildPlatform )
import Distribution.License
         ( License(..), knownLicenses )
import Distribution.Simple.CCompiler
         ( filenameCDialect )
import Distribution.Simple.Utils
         ( cabalVersion, intercalate, parseFileGlob, FileGlob(..), lowercase )

import Distribution.Version
         ( Version(..)
         , VersionRange(..), foldVersionRange'
         , anyVersion, noVersion, thisVersion, laterVersion, earlierVersion
         , orLaterVersion, orEarlierVersion
         , unionVersionRanges, intersectVersionRanges
         , asVersionIntervals, UpperBound(..), isNoVersion )
import Distribution.Package
         ( PackageName(PackageName), packageName, packageVersion
         , Dependency(..), pkgName )

import Distribution.Text
         ( display, disp )
import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint ((<>), (<+>))

import qualified Language.Haskell.Extension as Extension (deprecatedExtensions)
import Language.Haskell.Extension
         ( Language(UnknownLanguage), knownLanguages
         , Extension(..), KnownExtension(..) )
import System.FilePath
         ( (</>), takeExtension, isRelative, isAbsolute
         , splitDirectories,  splitPath )
import System.FilePath.Windows as FilePath.Windows
         ( isValid )

-- | Results of some kind of failed package check.
--
-- There are a range of severities, from merely dubious to totally insane.
-- All of them come with a human readable explanation. In future we may augment
-- them with more machine readable explanations, for example to help an IDE
-- suggest automatic corrections.
--
data PackageCheck =

       -- | This package description is no good. There's no way it's going to
       -- build sensibly. This should give an error at configure time.
       PackageBuildImpossible { explanation :: String }

       -- | A problem that is likely to affect building the package, or an
       -- issue that we'd like every package author to be aware of, even if
       -- the package is never distributed.
     | PackageBuildWarning { explanation :: String }

       -- | An issue that might not be a problem for the package author but
       -- might be annoying or detrimental when the package is distributed to
       -- users. We should encourage distributed packages to be free from these
       -- issues, but occasionally there are justifiable reasons so we cannot
       -- ban them entirely.
     | PackageDistSuspicious { explanation :: String }

       -- | An issue that is OK in the author's environment but is almost
       -- certain to be a portability problem for other environments. We can
       -- quite legitimately refuse to publicly distribute packages with these
       -- problems.
     | PackageDistInexcusable { explanation :: 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


-- ------------------------------------------------------------
-- * Standard checks
-- ------------------------------------------------------------

-- | Check for common mistakes and problems in package descriptions.
--
-- This is the standard collection of checks covering all aspects except
-- for checks that require looking at files within the package. For those
-- see 'checkPackageFiles'.
--
-- It requires the 'GenericPackageDescription' and optionally a particular
-- configuration of that package. If you pass 'Nothing' then we just check
-- a version of the generic description using 'flattenPackageDescription'.
--
checkPackage :: GenericPackageDescription
             -> Maybe PackageDescription
             -> [PackageCheck]
checkPackage gpkg mpkg =
     checkConfiguredPackage pkg
  ++ checkConditionals gpkg
  ++ checkPackageVersions gpkg
  where
    pkg = fromMaybe (flattenPackageDescription gpkg) mpkg

--TODO: make this variant go away
--      we should always know the GenericPackageDescription
checkConfiguredPackage :: PackageDescription -> [PackageCheck]
checkConfiguredPackage pkg =
    checkSanity pkg
 ++ checkFields pkg
 ++ checkLicense pkg
 ++ checkSourceRepos pkg
 ++ checkGhcOptions pkg
 ++ checkCCOptions pkg
 ++ checkCPPOptions pkg
 ++ checkPaths pkg
 ++ checkCabalVersion pkg


-- ------------------------------------------------------------
-- * Basic sanity checks
-- ------------------------------------------------------------

-- | Check that this package description is sane.
--
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 (null (executables pkg) && isNothing (library pkg)) $
      PackageBuildImpossible
        "No executables and no library 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."
  ]
  --TODO: check for name clashes case insensitively: windows file systems cannot
  --cope.

  ++ 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)

    -- check use of required-signatures/exposed-signatures sections
  , 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'."

    -- Test suites might be built as (internal) libraries named after
    -- the test suite and thus their names must not clash with the
    -- name of the package.
  , check libNameClash $
      PackageBuildImpossible $
           "The test suite " ++ testName test
        ++ " has the same name as the package."
  ]
  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

    libNameClash = testName test `elem` [ libName
                                        | _lib <- maybeToList (library pkg)
                                        , let PackageName libName =
                                                pkgName (package pkg) ]

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)."

    -- See comment for similar check on test suites.
  , check libNameClash $
      PackageBuildImpossible $
           "The benchmark " ++ benchmarkName bm
        ++ " has the same name as the package."
  ]
  where
    moduleDuplicates = dups $ benchmarkModules bm

    mainIsWrongExt = case benchmarkInterface bm of
      BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]
      _                   -> False

    libNameClash = benchmarkName bm `elem` [ libName
                                           | _lib <- maybeToList (library pkg)
                                           , let PackageName libName =
                                                   pkgName (package pkg) ]

-- ------------------------------------------------------------
-- * Additional pure checks
-- ------------------------------------------------------------

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 (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 deprecatedExtensions)) $
      PackageDistSuspicious $
           "Deprecated extensions: "
        ++ commaSep (map (quote . display . fst) deprecatedExtensions)
        ++ ". " ++ unwords
             [ "Instead of '" ++ display ext
            ++ "' use '" ++ display replacement ++ "'."
             | (ext, Just replacement) <- deprecatedExtensions ]

  , 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."

    --TODO: recommend the bug reports URL, author and homepage fields
    --TODO: recommend not using the stability field
    --TODO: recommend specifying a source repo

  , check (length (synopsis pkg) >= 80) $
      PackageDistSuspicious
        "The 'synopsis' field is rather long (max 80 chars is recommended)."

    -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12"
  , 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 ]
    deprecatedExtensions = nub $ catMaybes
      [ find ((==ext) . fst) Extension.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]
           -- AllRightsReserved and PublicDomain are not strictly
           -- licenses so don't need license files.
        && 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 ]

--TODO: check location looks like a URL for some repo types.

checkGhcOptions :: PackageDescription -> [PackageCheck]
checkGhcOptions pkg =
  catMaybes [

    check has_WerrorWall $
      PackageDistSuspicious $
           "'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."

  , check (not has_WerrorWall && has_Werror) $
      PackageDistSuspicious $
           "'ghc-options: -Werror' makes the package easy to "
        ++ "break with future GHC versions because new GHC versions often "
        ++ "add new warnings."

  , 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 ["-fdefer-type-errors"] $
      PackageDistInexcusable $
          "'ghc-options: -fdefer-type-errors' is fine during development but "
       ++ "is not appropriate for a distributed package."

  , checkFlags ["-fhpc"] $
      PackageDistInexcusable $
        "'ghc-options: -fhpc' is not appropriate for a distributed package."

    -- -dynamic is not a debug flag
  , check (any (\opt -> "-d" `isPrefixOf` opt && opt /= "-dynamic")
           all_ghc_options) $
      PackageDistInexcusable $
        "'ghc-options: -d*' debug flags are not appropriate "
        ++ "for a distributed package."

  , 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-executable-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"] $
      PackageDistSuspicious $
      "'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."

  , checkProfFlags ["-auto-all"] $
      PackageDistSuspicious $
        "'ghc-prof-options: -auto-all' is fine during development, but "
        ++ "not recommended in a distributed package. "

  , checkProfFlags ["-fprof-auto"] $
      PackageDistSuspicious $
        "'ghc-prof-options: -fprof-auto' is fine during development, but "
        ++ "not recommended in a distributed package. "

  , check ("-threaded" `elem` lib_ghc_options) $
      PackageDistSuspicious $
           "'ghc-options: -threaded' 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 ]
  ]

  where
    has_WerrorWall = flip any ghc_options $ \opts ->
                               "-Werror" `elem` opts
                           && ("-Wall"   `elem` opts || "-W" `elem` opts)
    has_Werror     = any (\opts -> "-Werror" `elem` opts) ghc_options

    (ghc_options, ghc_prof_options) =
      unzip . map (\bi -> (hcOptions GHC bi, hcProfOptions GHC bi))
      $ (allBuildInfo pkg)
    all_ghc_options      = concat ghc_options
    all_ghc_prof_options = concat ghc_prof_options
    lib_ghc_options = maybe [] (hcOptions GHC . libBuildInfo) (library pkg)

    checkFlags,checkProfFlags :: [String] -> PackageCheck -> Maybe PackageCheck
    checkFlags     flags = doCheckFlags flags all_ghc_options
    checkProfFlags flags = doCheckFlags flags all_ghc_prof_options

    doCheckFlags   flags opts = check (any (`elem` flags) opts)

    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 directory."
  | (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
    -- paths that must be relative
    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]]
      ++ 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 ]
    -- paths that are allowed to be absolute
    absPaths = concat
      [    [ (path, "includes")         | path <- includes        bi ]
        ++ [ (path, "include-dirs")     | path <- includeDirs     bi ]
        ++ [ (path, "extra-lib-dirs")   | path <- extraLibDirs    bi ]
      | bi <- allBuildInfo pkg ]

--TODO: check sets of paths that would be interpreted differently between Unix
-- and windows, ie case-sensitive or insensitive. Things that might clash, or
-- conversely be distinguished.

--TODO: use the tar path checks on all the above paths

-- | Check that the package declares the version in the @\"cabal-version\"@
-- field correctly.
--
checkCabalVersion :: PackageDescription -> [PackageCheck]
checkCabalVersion pkg =
  catMaybes [

    -- check syntax of cabal-version field
    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 syntax of cabal-version field
  , 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."

    -- check syntax of cabal-version field
  , 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) ++ "'."

    -- check use of test suite sections
  , 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."

    -- check use of default-language field
    -- note that we do not need to do an equivalent check for the
    -- other-language field since that one does not change behaviour
  , checkVersion [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."

    -- check use of reexported-modules sections
  , 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'."

    -- check use of thinning and renaming
  , 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'."

    -- check use of default-extensions field
    -- don't need to do the equivalent check for other-extensions
  , 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 use of extensions field
  , 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."

    -- check use of "foo (>= 1.0 && < 1.4) || >=1.8 " version-range syntax
  , 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."

    -- check use of "build-depends: foo == 1.*" syntax
  , 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 ]

    -- check use of "tested-with: GHC (>= 1.0 && < 1.4) || >=1.8 " syntax
  , 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'."

    -- check use of "tested-with: GHC == 6.12.*" syntax
  , 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 ]

    -- check use of "data-files: data/*.txt" syntax
  , 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."

    -- check use of "extra-source-files: mk/*.in" syntax
  , 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."

    -- check use of "source-repository" section
  , 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'."

    -- check for new licenses
  , 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'."

    -- check for new language extensions
  , 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."
  ]
  where
    -- Perform a check on packages that use a version of the spec less than
    -- the version given. This is for cases where a new Cabal version adds
    -- a new feature and we want to check that it is not used prior to that
    -- version.
    checkVersion :: [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)

    -- is the cabal-version field a simple version number, rather than a range
    simpleSpecVersionSyntax =
      either (const True) (const False) (specVersionRaw pkg)

    usesNewVersionRangeSyntax :: VersionRange -> Bool
    usesNewVersionRangeSyntax =
        (> 2) -- uses the new syntax if depth is more than 2
      . foldVersionRange'
          (1 :: Int)
          (const 1)
          (const 1) (const 1)
          (const 1) (const 1)
          (const (const 1))
          (+) (+)
          (const 3) -- uses new ()'s syntax

    depsUsingWildcardSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg
                                    , usesWildcardSyntax vr ]

    -- XXX: If the user writes build-depends: foo with (), this is
    -- indistinguishable from build-depends: foo, so there won't be an
    -- error even though there should be
    depsUsingThinningRenamingSyntax =
      [ name
      | bi <- allBuildInfo pkg
      , (name, rns) <- Map.toList (targetBuildRenaming bi)
      , rns /= ModuleRenaming True [] ]

    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) -- the wildcard case
        (||) (||) 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)

    -- As of Cabal-1.4 we can add new extensions without worrying about
    -- breaking old versions of cabal.
    mentionedExtensionsThatNeedCabal14 =
      nub (filter (`notElem` compatExtensions) mentionedExtensions)

    -- The known extensions in Cabal-1.2.3
    compatExtensions =
      map EnableExtension
      [ OverlappingInstances, UndecidableInstances, IncoherentInstances
      , RecursiveDo, ParallelListComp, MultiParamTypeClasses
      , FunctionalDependencies, Rank2Types
      , RankNTypes, PolymorphicComponents, ExistentialQuantification
      , ScopedTypeVariables, ImplicitParams, FlexibleContexts
      , FlexibleInstances, EmptyDataDecls, CPP, BangPatterns
      , TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface
      , Arrows, Generics, NamedFieldPuns, PatternGuards
      , GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms
      , HereDocuments] ++
      map DisableExtension
      [MonomorphismRestriction, ImplicitPrelude] ++
      compatExtensionsExtra

    -- The extra known extensions in Cabal-1.2.3 vs Cabal-1.1.6
    -- (Cabal-1.1.6 came with ghc-6.6. Cabal-1.2 came with ghc-6.8)
    compatExtensionsExtra =
      map EnableExtension
      [ KindSignatures, MagicHash, TypeFamilies, StandaloneDeriving
      , UnicodeSyntax, PatternSignatures, UnliftedFFITypes, LiberalTypeSynonyms
      , TypeOperators, RecordWildCards, RecordPuns, DisambiguateRecordFields
      , OverloadedStrings, GADTs, RelaxedPolyRec
      , ExtendedDefaultRules, UnboxedTuples, DeriveDataTypeable
      , ConstrainedClassMethods
      ] ++
      map DisableExtension
      [MonoPatBinds]

-- | A variation on the normal 'Text' instance, shows any ()'s in the original
-- textual syntax. We need to show these otherwise it's confusing to users when
-- we complain of their presence but do not pretty print them!
--
displayRawVersionRange :: VersionRange -> String
displayRawVersionRange =
   Disp.render
 . fst
 . foldVersionRange'                         -- precedence:
     -- All the same as the usual pretty printer, except for the parens
     (         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)) -- parens

  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


-- ------------------------------------------------------------
-- * Checks on the GenericPackageDescription
-- ------------------------------------------------------------

-- | Check the build-depends fields for any weirdness or bad practise.
--
checkPackageVersions :: GenericPackageDescription -> [PackageCheck]
checkPackageVersions pkg =
  catMaybes [

    -- Check that the version of base is bounded above.
    -- For example this bans "build-depends: base >= 3".
    -- It should probably be "build-depends: base >= 3 && < 4"
    -- which is the same as  "build-depends: base == 3.*"
    check (not (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 2 and 3 then use 'build-depends: base >= 2 && < 4'."

  ]
  where
    -- TODO: What we really want to do is test if there exists any
    -- configuration in which the base version is unbounded above.
    -- However that's a bit tricky because there are many possible
    -- configurations. As a cheap easy and safe approximation we will
    -- pick a single "typical" configuration and check if that has an
    -- open upper bound. To get a typical configuration we finalise
    -- using no package index and the current platform.
    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' ]

      -- Just in case finalizePackageDescription fails for any reason,
      -- or if the package doesn't depend on the base package at all,
      -- then we will just skip the check, since boundedAbove noVersion = True
      _          -> noVersion

    boundedAbove :: VersionRange -> Bool
    boundedAbove vr = case asVersionIntervals vr of
      []        -> True -- this is the inconsistent version range.
      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 [] freeVars (condLibrary pkg)
              ++ concatMap (freeVars . snd) (condExecutables pkg)
    freeVars (CondNode _ _ ifs) = concatMap compfv ifs
    compfv (c, ct, mct) = condfv c ++ freeVars ct ++ maybe [] freeVars 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

-- ------------------------------------------------------------
-- * Checks involving files in the package
-- ------------------------------------------------------------

-- | Sanity check things that requires IO. It looks at the files in the
-- package and expects to find the package unpacked in at the given file path.
--
checkPackageFiles :: PackageDescription -> FilePath -> IO [PackageCheck]
checkPackageFiles pkg root = checkPackageContent checkFilesIO pkg
  where
    checkFilesIO = CheckPackageContentOps {
      doesFileExist      = System.doesFileExist      . relative,
      doesDirectoryExist = System.doesDirectoryExist . relative
    }
    relative path = root </> path

-- | A record of operations needed to check the contents of packages.
-- Used by 'checkPackageContent'.
--
data CheckPackageContentOps m = CheckPackageContentOps {
    doesFileExist      :: FilePath -> m Bool,
    doesDirectoryExist :: FilePath -> m Bool
  }

-- | Sanity check things that requires looking at files in the package.
-- This is a generalised version of 'checkPackageFiles' that can work in any
-- monad for which you can provide 'CheckPackageContentOps' operations.
--
-- The point of this extra generality is to allow doing checks in some virtual
-- file system, for example a tarball in memory.
--
checkPackageContent :: Monad m => CheckPackageContentOps m
                    -> PackageDescription
                    -> m [PackageCheck]
checkPackageContent ops pkg = do
  licenseErrors   <- checkLicensesExist   ops pkg
  setupError      <- checkSetupExists     ops pkg
  configureError  <- checkConfigureExists ops pkg
  localPathErrors <- checkLocalPathsExist ops pkg
  vcsLocation     <- checkMissingVcsInfo  ops pkg

  return $ licenseErrors
        ++ catMaybes [setupError, configureError]
        ++ localPathErrors
        ++ vcsLocation

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 _ = do
  hsexists  <- doesFileExist ops "Setup.hs"
  lhsexists <- doesFileExist ops "Setup.lhs"
  return $ check (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, "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 _          = []

-- ------------------------------------------------------------
-- * Checks involving files in the package
-- ------------------------------------------------------------

-- | Check the names of all files in a package for portability problems. This
-- should be done for example when creating or validating a package tarball.
--
checkPackageFileNames :: [FilePath] -> [PackageCheck]
checkPackageFileNames files =
     (take 1 . catMaybes . map checkWindowsPath $ files)
  ++ (take 1 . catMaybes . map checkTarPath     $ files)
      -- If we get any of these checks triggering then we're likely to get
      -- many, and that's probably not helpful, so return at most one.

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
    -- force a relative name to catch invalid file names like "f:oo" which
    -- otherwise parse as file "oo" in the current directory on the 'f' drive.

-- | Check a file name is valid for the portable POSIX tar format.
--
-- The POSIX tar format has a restriction on the length of file names. It is
-- unfortunately not a simple restriction like a maximum length. The exact
-- restriction is that either the whole path be 100 characters or less, or it
-- be possible to split the path on a directory separator such that the first
-- part is 155 characters or less and the second part 100 characters or less.
--
checkTarPath :: FilePath -> Maybe PackageCheck
checkTarPath path
  | length path > 255   = Just longPath
  | otherwise = case pack nameMax (reverse (splitPath path)) of
    Left err           -> Just err
    Right []           -> Nothing
    Right (first:rest) -> case pack prefixMax remainder of
      Left err         -> Just err
      Right []         -> Nothing
      Right (_:_)      -> Just noSplit
     where
        -- drop the '/' between the name and prefix:
        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."

-- ------------------------------------------------------------
-- * Utils
-- ------------------------------------------------------------

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)