cabal-install/src/Distribution/Client/Check.hs

   1 {-# LANGUAGE CPP #-}
   2
   3 -----------------------------------------------------------------------------
   4
   5 -----------------------------------------------------------------------------
   6
   7 -- |
   8 -- Module      :  Distribution.Client.Check
   9 -- Copyright   :  (c) Lennart Kolmodin 2008
  10 -- License     :  BSD-like
  11 --
  12 -- Maintainer  :  kolmodin@haskell.org
  13 -- Stability   :  provisional
  14 -- Portability :  portable
  15 --
  16 -- Check a package for common mistakes
  17 module Distribution.Client.Check
  18   ( check
  19   ) where
  20
  21 import Distribution.Client.Compat.Prelude
  22 import Prelude ()
  23
  24 import Distribution.Client.Utils.Parsec (renderParseError)
  25 import Distribution.PackageDescription (GenericPackageDescription)
  26 import Distribution.PackageDescription.Check
  27 import Distribution.PackageDescription.Parsec
  28   ( parseGenericPackageDescription
  29   , runParseResult
  30   )
  31 import Distribution.Parsec (PWarning (..), showPError)
  32 import Distribution.Simple.Utils (defaultPackageDesc, dieWithException, notice, warn, warnError)
  33 import System.IO (hPutStr, stderr)
  34
  35 import qualified Control.Monad as CM
  36 import qualified Data.ByteString as BS
  37 import qualified Data.Function as F
  38 import qualified Data.List as L
  39 import qualified Data.List.NonEmpty as NE
  40 import Distribution.Client.Errors
  41 import qualified System.Directory as Dir
  42
  43 readGenericPackageDescriptionCheck :: Verbosity -> FilePath -> IO ([PWarning], GenericPackageDescription)
  44 readGenericPackageDescriptionCheck verbosity fpath = do
  45   exists <- Dir.doesFileExist fpath
  46   unless exists $
  47     dieWithException verbosity $
  48       FileDoesntExist fpath
  49   bs <- BS.readFile fpath
  50   let (warnings, result) = runParseResult (parseGenericPackageDescription bs)
  51   case result of
  52     Left (_, errors) -> do
  53       traverse_ (warn verbosity . showPError fpath) errors
  54       hPutStr stderr $ renderParseError fpath bs errors warnings
  55       dieWithException verbosity ParseError
  56     Right x -> return (warnings, x)
  57
  58 -- | Checks a packge for common errors. Returns @True@ if the package
  59 -- is fit to upload to Hackage, @False@ otherwise.
  60 -- Note: must be called with the CWD set to the directory containing
  61 -- the '.cabal' file.
  62 check
  63   :: Verbosity
  64   -> [CheckExplanationIDString]
  65   -- ^ List of check-ids in String form
  66   -- (e.g. @invalid-path-win@) to ignore.
  67   -> IO Bool
  68 check verbosity ignores = do
  69   pdfile <- defaultPackageDesc verbosity
  70   (ws, ppd) <- readGenericPackageDescriptionCheck verbosity pdfile
  71   -- convert parse warnings into PackageChecks
  72   let ws' = map (wrapParseWarning pdfile) ws
  73   ioChecks <- checkPackageFilesGPD verbosity ppd "."
  74   let packageChecksPrim = ioChecks ++ checkPackage ppd ++ ws'
  75       (packageChecks, unrecs) = filterPackageChecksByIdString packageChecksPrim ignores
  76
  77   CM.mapM_ (\s -> warn verbosity ("Unrecognised ignore \"" ++ s ++ "\"")) unrecs
  78
  79   CM.mapM_ (outputGroupCheck verbosity) (groupChecks packageChecks)
  80
  81   let errors = filter isHackageDistError packageChecks
  82
  83   unless (null errors) $
  84     warnError verbosity "Hackage would reject this package."
  85
  86   when (null packageChecks) $
  87     notice verbosity "No errors or warnings could be found in the package."
  88
  89   return (null errors)
  90
  91 -------------------------------------------------------------------------------
  92 -- Grouping/displaying checks
  93
  94 -- Poor man’s “group checks by constructor”.
  95 groupChecks :: [PackageCheck] -> [NE.NonEmpty PackageCheck]
  96 groupChecks ds =
  97   NE.groupBy
  98     (F.on (==) constInt)
  99     (L.sortBy (F.on compare constInt) ds)
 100   where
 101     constInt :: PackageCheck -> Int
 102     constInt (PackageBuildImpossible{}) = 0
 103     constInt (PackageBuildWarning{}) = 1
 104     constInt (PackageDistSuspicious{}) = 2
 105     constInt (PackageDistSuspiciousWarn{}) = 3
 106     constInt (PackageDistInexcusable{}) = 4
 107
 108 groupExplanation :: PackageCheck -> String
 109 groupExplanation (PackageBuildImpossible{}) = "The package will not build sanely due to these errors:"
 110 groupExplanation (PackageBuildWarning{}) = "The following errors are likely to affect your build negatively:"
 111 groupExplanation (PackageDistSuspicious{}) = "These warnings will likely cause trouble when distributing the package:"
 112 groupExplanation (PackageDistSuspiciousWarn{}) = "These warnings may cause trouble when distributing the package:"
 113 groupExplanation (PackageDistInexcusable{}) = "The following errors will cause portability problems on other environments:"
 114
 115 groupOutputFunction :: PackageCheck -> Verbosity -> String -> IO ()
 116 groupOutputFunction (PackageBuildImpossible{}) ver = warnError ver
 117 groupOutputFunction (PackageBuildWarning{}) ver = warnError ver
 118 groupOutputFunction (PackageDistSuspicious{}) ver = warn ver
 119 groupOutputFunction (PackageDistSuspiciousWarn{}) ver = warn ver
 120 groupOutputFunction (PackageDistInexcusable{}) ver = warnError ver
 121
 122 outputGroupCheck :: Verbosity -> NE.NonEmpty PackageCheck -> IO ()
 123 outputGroupCheck ver pcs = do
 124   let hp = NE.head pcs
 125       outf = groupOutputFunction hp ver
 126   notice ver (groupExplanation hp)
 127   CM.mapM_ (outf . ppPackageCheck) pcs