[commit: Cabal] master: Naive implementation of 'cabal check' (f6ab0f6)

[Paolo Capriotti]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/f6ab0f6206ce23cc1bbbea53bcc5d4f927ea54f0

>---------------------------------------------------------------

commit f6ab0f6206ce23cc1bbbea53bcc5d4f927ea54f0
Author: Lennart Kolmodin <kolmodin at gentoo.org>
Date:   Thu Feb 21 20:48:20 2008 +0000

    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.

>---------------------------------------------------------------

 cabal-install/Hackage/Check.hs |   76 ++++++++++++++++++++++++++++++++++++++++
 cabal-install/Hackage/Setup.hs |   11 ++++++
 cabal-install/Main.hs          |   13 ++++++-
 3 files changed, 98 insertions(+), 2 deletions(-)

diff --git a/cabal-install/Hackage/Check.hs b/cabal-install/Hackage/Check.hs
new file mode 100644
index 0000000..9589de9
--- /dev/null
+++ b/cabal-install/Hackage/Check.hs
@@ -0,0 +1,76 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Hackage.Check
+-- Copyright   :  (c) Lennart Kolmodin 2008
+-- License     :  BSD-like
+--
+-- Maintainer  :  kolmodin at 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 at PackageBuildImpossible {} <- packageChecks ]
+        buildWarning    = [ x | x at PackageBuildWarning {}    <- packageChecks ]
+        distSuspicious  = [ x | x at PackageDistSuspicious {}  <- packageChecks ]
+        distInexusable  = [ x | x at 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."
diff --git a/cabal-install/Hackage/Setup.hs b/cabal-install/Hackage/Setup.hs
index 5350f51..1115ae6 100644
--- a/cabal-install/Hackage/Setup.hs
+++ b/cabal-install/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
 -- ------------------------------------------------------------
diff --git a/cabal-install/Main.hs b/cabal-install/Main.hs
index b6c0c98..6d222a2 100644
--- a/cabal-install/Main.hs
+++ b/cabal-install/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)