Add lots of new package checks

Check that Setup.(l)hs exists.
Check for ./configure file if build-type: Configure
Check for duplicate modules in library and executables.
Check ghc-options and cc-options for -I -l -L flags that should be elsewhere
Check for lots of insane ghc-options that people have used in real packages.
Check for old ghc -f flags that correspond to extensions

Author: dcoutts

Distribution/PackageDescription/Check.hs

@@ -47,6 +47,7 @@ module Distribution.PackageDescription.Check (
   ) where
 
 import Data.Maybe (isNothing, catMaybes)
+import Data.List  (intersperse, sort, group, isPrefixOf)
 import System.Directory (doesFileExist)
 
 import Distribution.PackageDescription
@@ -56,6 +57,7 @@ import Distribution.Simple.Utils (cabalVersion)
 
 import Distribution.Version (Version(..), withinRange, showVersionRange)
 import Distribution.Package (PackageIdentifier(..))
+import Language.Haskell.Extension (Extension(..))
 import System.FilePath (takeExtension, (</>))
 
 -- | Results of some kind of failed package check.
@@ -100,8 +102,6 @@ check True  pc = Just pc
 -- * Standard checks
 -- ------------------------------------------------------------
 
--- TODO: give hints about old extentions. see Simple.GHC, reverse mapping
--- TODO: and allmost ghc -X flags should be extensions
 -- TODO: Once we implement striping (ticket #88) we should also reject
 --       ghc-options: -optl-Wl,-s.
 
@@ -117,6 +117,7 @@ checkPackage pkg =
  ++ checkFields pkg
  ++ checkLicense pkg
  ++ checkGhcOptions pkg
+ ++ checkCCOptions pkg
 
 
 -- ------------------------------------------------------------
@@ -160,8 +161,17 @@ checkLibrary lib =
     check (buildable (libBuildInfo lib) && null (exposedModules lib)) $
        PackageBuildImpossible
          "A library was specified, but no 'exposed-modules' list has been given."
+
+  , check (not (null moduleDuplicates)) $
+       PackageBuildWarning $
+         "Dulicate modules in library: " ++ commaSep moduleDuplicates
   ]
 
+  where moduleDuplicates = [ module_
+                           | let modules = exposedModules lib
+                                        ++ otherModules (libBuildInfo lib)
+                           , (module_:_:_) <- group (sort modules) ]
+
 checkExecutable :: Executable -> [PackageCheck]
 checkExecutable exe =
   catMaybes [
@@ -175,8 +185,16 @@ checkExecutable exe =
       PackageBuildImpossible $
            "The 'Main-Is' field must specify a '.hs' or '.lhs' file\n"
         ++ "    (even if it is generated by a preprocessor)."
+
+  , check (not (null moduleDuplicates)) $
+       PackageBuildWarning $
+            "Dulicate modules in executable '" ++ exeName exe ++ "': "
+         ++ commaSep moduleDuplicates
   ]
 
+  where moduleDuplicates = [ module_
+                           | let modules = otherModules (buildInfo exe)
+                           , (module_:_:_) <- group (sort modules) ]
 
 -- ------------------------------------------------------------
 -- * Additional pure checks
@@ -233,24 +251,80 @@ checkGhcOptions pkg =
            "'ghc-options: -Werror' makes the package easy to "
         ++ "break with future GHC versions."
 
-  , checkFlag "-fasm" $
+  , checkFlags ["-fasm"] $
       PackageDistInexcusable $
            "'ghc-options: -fasm' is unnecessary and breaks on all "
         ++ "arches except for x86, x86-64 and ppc."
 
-  , checkFlag "-O" $
+  , checkFlags ["-fvia-C"] $
+      PackageDistSuspicious $
+        "'ghc-options: -fvia-C' is usually unnecessary."
+
+  , checkFlags ["-fhpc"] $
+      PackageDistInexcusable $
+        "'ghc-options: -fhpc' is not appropriate for a distributed package."
+
+  , check (any ("-d" `isPrefixOf`) all_ghc_options) $
+      PackageDistInexcusable $
+        "'ghc-options: -d*' debug flags are not appropriate for a distributed package."
+
+  , checkFlags ["-prof"] $
+      PackageDistInexcusable $
+        "'ghc-options: -prof' is not needed. Use the --enable-library-profiling configure flag."
+
+  , checkFlags ["-o"] $
+      PackageDistInexcusable $
+        "'ghc-options: -o' is not allowed. The output files are named automatically."
+
+  , checkFlags ["-hide-package"] $
+      PackageDistInexcusable $
+           "'ghc-options: -hide-package' is never needed. Cabal hides all packages\n"
+
+  , checkFlags ["-main-is"] $
+      PackageDistSuspicious $
+           "'ghc-options: -main-is' is not portable."
+
+  , checkFlags ["-O0", "-Onot"] $
+      PackageDistInexcusable $
+        "'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.\n"
         ++ "    Setting it yourself interferes with the --disable-optimization flag."
 
-  , checkFlag "-O2" $
+  , checkFlags ["-O2"] $
       PackageDistSuspicious $
            "'ghc-options: -O2' is rarely needed. Check that it is giving a real benefit\n"
         ++ "    and not just imposing longer compile times on your users."
 
-  , check (any (`elem` all_ghc_options) ["-ffi", "-fffi"]) $
+  , checkFlags ["-split-objs"] $
       PackageDistInexcusable $
-        "Instead of using -ffi or -fffi, use 'extensions: ForeignFunctionInterface'"
+        "'ghc-options: -split-objs' is not needed. Use the --enable-split-objs configure flag."
+
+  , checkFlags ["-fglasgow-exts"] $
+      PackageDistSuspicious $
+        "Instead of 'ghc-options: -fglasgow-exts' it is preferable to use the 'extensions' field."
+
+  , checkAlternatives "ghc-options" "extensions"
+      [ (flag, show 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
@@ -263,8 +337,63 @@ checkGhcOptions pkg =
                          , (GHC, strs) <- options bi ]
     all_ghc_options = concat ghc_options
 
-    checkFlag :: String -> PackageCheck -> Maybe PackageCheck
-    checkFlag flag = check (flag `elem` all_ghc_options)
+    checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck
+    checkFlags flags = check (any (`elem` flags) all_ghc_options)
+
+    ghcExtension ('-':'f':name) = case name of
+      "allow-overlapping-instances" -> Just OverlappingInstances
+      "th"                          -> Just TemplateHaskell
+      "ffi"                         -> Just ForeignFunctionInterface
+      "fi"                          -> Just ForeignFunctionInterface
+      "no-monomorphism-restriction" -> Just NoMonomorphismRestriction
+      "no-mono-pat-binds"           -> Just NoMonoPatBinds
+      "allow-undecidable-instances" -> Just UndecidableInstances
+      "allow-incoherent-instances"  -> Just IncoherentInstances
+      "arrows"                      -> Just Arrows
+      "generics"                    -> Just Generics
+      "no-implicit-prelude"         -> Just NoImplicitPrelude
+      "implicit-params"             -> Just ImplicitParams
+      "bang-patterns"               -> Just BangPatterns
+      "scoped-type-variables"       -> Just ScopedTypeVariables
+      "extended-default-rules"      -> Just ExtendedDefaultRules
+      _                             -> Nothing
+    ghcExtension ('-':'c':"pp")     = Just CPP
+    ghcExtension _                  = Nothing
+
+
+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 ]
+  ]
+
+  where all_ccOptions = [ opts | bi <- allBuildInfo pkg
+                              , opts <- ccOptions bi ]
+        all_ldOptions = [ opts | bi <- allBuildInfo pkg
+                               , opts <- ldOptions 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
 
 -- ------------------------------------------------------------
 -- * Checks in IO
@@ -275,9 +404,11 @@ checkGhcOptions pkg =
 --
 checkPackageFiles :: PackageDescription -> FilePath -> IO [PackageCheck]
 checkPackageFiles pkg root = do
-    licenseError <- checkLicenseExists pkg root
+    licenseError   <- checkLicenseExists pkg root
+    setupError     <- checkSetupExists pkg root
+    configureError <- checkConfigureExists pkg root
 
-    return (catMaybes [licenseError])
+    return (catMaybes [licenseError, setupError, configureError])
 
 checkLicenseExists :: PackageDescription -> FilePath -> IO (Maybe PackageCheck)
 checkLicenseExists pkg root
@@ -291,4 +422,29 @@ checkLicenseExists pkg root
 
   where
     file = licenseFile pkg
-    quote s = ['"'] ++ s ++ ['"']
+
+checkSetupExists :: PackageDescription -> FilePath -> IO (Maybe PackageCheck)
+checkSetupExists _ root = do
+  hsexists  <- doesFileExist (root </> "Setup.hs")
+  lhsexists <- doesFileExist (root </> "Setup.lhs")
+  return $ check (not hsexists && not lhsexists) $
+    PackageDistInexcusable $
+      "The package is missing a Setup.hs or Setup.lhs script."
+
+checkConfigureExists :: PackageDescription -> FilePath -> IO (Maybe PackageCheck)
+checkConfigureExists PackageDescription { buildType = Just Configure } root = do
+  exists <- doesFileExist (root </> "configure")
+  return $ check (not exists) $
+    PackageBuildWarning $
+      "The 'build-type' is 'Configure' but there is no 'configure' script."
+checkConfigureExists _ _ = return Nothing
+
+-- ------------------------------------------------------------
+-- * Utils
+-- ------------------------------------------------------------
+
+quote :: String -> String
+quote s = "'" ++ s ++ "'"
+
+commaSep :: [String] -> String
+commaSep = concat . intersperse ","