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