Naive implementation of 'cabal check'

A naive implementation of 'cabal check'.
It will list the errors and warnings as implemented by Cabal, yielding them
in groups of severity. Currently ignores verbosity levels, no additional
arguments are understood. This addresses ticket #211.

Hackage/Check.hs

@@ -0,0 +1,76 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Hackage.Check
+-- Copyright   :  (c) Lennart Kolmodin 2008
+-- License     :  BSD-like
+--
+-- Maintainer  :  kolmodin@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- Check a package for common mistakes
+--
+-----------------------------------------------------------------------------
+module Hackage.Check (
+    check
+  ) where
+
+import Control.Monad ( unless )
+
+import Distribution.PackageDescription.Parse ( readPackageDescription )
+import Distribution.PackageDescription.Check
+import Distribution.PackageDescription.Configuration ( flattenPackageDescription )
+import Distribution.Verbosity ( Verbosity )
+import Distribution.Simple.Utils ( defaultPackageDesc )
+
+check :: Verbosity -> IO ()
+check verbosity = do
+    pdfile <- defaultPackageDesc verbosity
+    ppd <- readPackageDescription verbosity pdfile
+    -- flatten the generic package description into a regular package
+    -- description
+    -- TODO: this may give more warnings than it should give;
+    --       consider two branches of a condition, one saying
+    --          ghc-options: -Wall
+    --       and the other
+    --          ghc-options: -Werror
+    --      joined into
+    --          ghc-options: -Wall -Werror
+    --      checkPackages will yield a warning on the last line, but it
+    --      would not on each individual branch.
+    --      Hovever, this is the same way hackage does it, so we will yield
+    --      the exact same errors as it will.
+    let pkg_desc = flattenPackageDescription ppd
+    ioChecks <- checkPackageFiles pkg_desc "."
+    let packageChecks = ioChecks ++ checkPackage pkg_desc
+        buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ]
+        buildWarning    = [ x | x@PackageBuildWarning {}    <- packageChecks ]
+        distSuspicious  = [ x | x@PackageDistSuspicious {}  <- packageChecks ]
+        distInexusable  = [ x | x@PackageDistInexcusable {} <- packageChecks ]
+
+    unless (null buildImpossible) $ do
+        putStrLn "The package will not build sanely due to these errors:"
+        mapM_ (putStrLn . explanation) buildImpossible
+        putStrLn ""
+
+    unless (null buildWarning) $ do
+        putStrLn "The following warnings are likely affect your build negatively:"
+        mapM_ (putStrLn . explanation) buildWarning
+        putStrLn ""
+
+    unless (null distSuspicious) $ do
+        putStrLn "These warnings may cause trouble when distribution the package:"
+        mapM_ (putStrLn . explanation) distSuspicious
+        putStrLn ""
+
+    unless (null distInexusable) $ do
+        putStrLn "The following errors will cause portability problems on other environments:"
+        mapM_ (putStrLn . explanation) distInexusable
+        putStrLn ""
+
+    let isDistError (PackageDistSuspicious {}) = False
+        isDistError _                          = True
+        errors = filter isDistError packageChecks
+
+    unless (null errors) $ do
+        putStrLn "Hackage would reject this package."

Hackage/Setup.hs

@@ -19,6 +19,7 @@ module Hackage.Setup
     , upgradeCommand
     , infoCommand
     , fetchCommand
+    , checkCommand
     , uploadCommand, UploadFlags(..)
 
     , parsePackageArgs
@@ -134,6 +135,16 @@ infoCommand = CommandUI {
     commandOptions      = \_ -> [optionVerbose id const]
   }
 
+checkCommand  :: CommandUI (Flag Verbosity)
+checkCommand = CommandUI {
+    commandName         = "check",
+    commandSynopsis     = "Check the package for common mistakes",
+    commandDescription  = Nothing,
+    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
+    commandDefaultFlags = mempty,
+    commandOptions      = mempty
+  }
+
 -- ------------------------------------------------------------
 -- * Upload flags
 -- ------------------------------------------------------------

Main.hs

@@ -31,8 +31,9 @@ import Hackage.Info             (info)
 import Hackage.Update           (update)
 import Hackage.Upgrade          (upgrade)
 import Hackage.Fetch            (fetch)
+import Hackage.Check as Check   (check)
 --import Hackage.Clean            (clean)
-import Hackage.Upload           (upload, check)
+import Hackage.Upload as Upload (upload, check)
 
 import Distribution.Verbosity   (Verbosity, normal)
 import Distribution.Version     (showVersion)
@@ -42,6 +43,7 @@ import System.Environment       (getArgs, getProgName)
 import System.Exit              (exitWith, ExitCode(..))
 import Data.List                (intersperse)
 import Data.Monoid              (Monoid(..))
+import Control.Monad            (unless)
 
 -- | Entry point
 --
@@ -85,6 +87,7 @@ mainWorker args =
       ,upgradeCommand         `commandAddAction` upgradeAction
       ,fetchCommand           `commandAddAction` fetchAction
       ,uploadCommand          `commandAddAction` uploadAction
+      ,checkCommand           `commandAddAction` checkAction
 
       ,wrapperAction (Cabal.buildCommand     defaultProgramConfiguration)
       ,wrapperAction Cabal.copyCommand
@@ -187,10 +190,16 @@ uploadAction flags extraArgs = do
   -- FIXME: check that the .tar.gz files exist and report friendly error message if not
   let tarfiles = extraArgs
   if fromFlag (uploadCheck flags)
-    then check  verbosity tarfiles
+    then Upload.check  verbosity tarfiles
     else upload verbosity 
                 (flagToMaybe $ configUploadUsername config
                      `mappend` uploadUsername flags)
                 (flagToMaybe $ configUploadPassword config
                      `mappend` uploadPassword flags)
                 tarfiles
+
+checkAction :: Flag Verbosity -> [String] -> IO ()
+checkAction verbosityFlag extraArgs = do
+  unless (null extraArgs) $ do
+    die $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs
+  Check.check (fromFlag verbosityFlag)