-- |
-- Module      :  Distribution.Client.Check
-- Copyright   :  (c) Lennart Kolmodin 2008
-- License     :  BSD-like
--
-- Maintainer  :  kolmodin@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Check a package for common mistakes
module Distribution.Client.Check
  ( check
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import Distribution.Client.Errors
import Distribution.Client.Utils.Parsec (renderParseError)
import Distribution.PackageDescription (GenericPackageDescription)
import Distribution.PackageDescription.Check
import Distribution.PackageDescription.Parsec
  ( parseGenericPackageDescription
  , runParseResult
  )
import Distribution.Parsec (PWarning (..), showPError)
import Distribution.Simple.Utils (defaultPackageDescCwd, dieWithException, notice, warn, warnError)
import Distribution.Utils.Path (getSymbolicPath)

import System.IO (hPutStr, stderr)

import qualified Control.Monad as CM
import qualified Data.ByteString as BS
import qualified Data.Function as F
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import qualified System.Directory as Dir

readGenericPackageDescriptionCheck :: Verbosity -> FilePath -> IO ([PWarning], GenericPackageDescription)
readGenericPackageDescriptionCheck :: Verbosity -> FilePath -> IO ([PWarning], GenericPackageDescription)
readGenericPackageDescriptionCheck Verbosity
verbosity FilePath
fpath = do
  exists <- FilePath -> IO Bool
Dir.doesFileExist FilePath
fpath
  unless exists $
    dieWithException verbosity $
      FileDoesntExist fpath
  bs <- BS.readFile fpath
  let (warnings, result) = runParseResult (parseGenericPackageDescription bs)
  case result of
    Left (Maybe Version
_, NonEmpty PError
errors) -> do
      (PError -> IO ()) -> NonEmpty PError -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> (PError -> FilePath) -> PError -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> PError -> FilePath
showPError FilePath
fpath) NonEmpty PError
errors
      Handle -> FilePath -> IO ()
hPutStr Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> NonEmpty PError -> [PWarning] -> FilePath
renderParseError FilePath
fpath ByteString
bs NonEmpty PError
errors [PWarning]
warnings
      Verbosity
-> CabalInstallException
-> IO ([PWarning], GenericPackageDescription)
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalInstallException
ParseError
    Right GenericPackageDescription
x -> ([PWarning], GenericPackageDescription)
-> IO ([PWarning], GenericPackageDescription)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([PWarning]
warnings, GenericPackageDescription
x)

-- | Checks a package for common errors. Returns @True@ if the package
-- is fit to upload to Hackage, @False@ otherwise.
-- Note: must be called with the CWD set to the directory containing
-- the '.cabal' file.
check
  :: Verbosity
  -> [CheckExplanationIDString]
  -- ^ List of check-ids in String form
  -- (e.g. @invalid-path-win@) to ignore.
  -> IO Bool
check :: Verbosity -> [FilePath] -> IO Bool
check Verbosity
verbosity [FilePath]
ignores = do
  pdfile <- SymbolicPathX 'OnlyRelative Pkg 'File -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath (SymbolicPathX 'OnlyRelative Pkg 'File -> FilePath)
-> IO (SymbolicPathX 'OnlyRelative Pkg 'File) -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity -> IO (SymbolicPathX 'OnlyRelative Pkg 'File)
defaultPackageDescCwd Verbosity
verbosity
  (ws, ppd) <- readGenericPackageDescriptionCheck verbosity pdfile
  -- convert parse warnings into PackageChecks
  let ws' = (PWarning -> PackageCheck) -> [PWarning] -> [PackageCheck]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> PWarning -> PackageCheck
wrapParseWarning FilePath
pdfile) [PWarning]
ws
  ioChecks <- checkPackageFilesGPD verbosity ppd "."
  let packageChecksPrim = [PackageCheck]
ioChecks [PackageCheck] -> [PackageCheck] -> [PackageCheck]
forall a. [a] -> [a] -> [a]
++ GenericPackageDescription -> [PackageCheck]
checkPackage GenericPackageDescription
ppd [PackageCheck] -> [PackageCheck] -> [PackageCheck]
forall a. [a] -> [a] -> [a]
++ [PackageCheck]
ws'
      (packageChecks, unrecs) = filterPackageChecksByIdString packageChecksPrim ignores

  CM.mapM_ (\FilePath
s -> Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath
"Unrecognised ignore \"" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
s FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\"")) unrecs

  CM.mapM_ (outputGroupCheck verbosity) (groupChecks packageChecks)

  let errors = (PackageCheck -> Bool) -> [PackageCheck] -> [PackageCheck]
forall a. (a -> Bool) -> [a] -> [a]
filter PackageCheck -> Bool
isHackageDistError [PackageCheck]
packageChecks

  unless (null errors) $
    warnError verbosity "Hackage would reject this package."

  when (null packageChecks) $
    notice verbosity "No errors or warnings could be found in the package."

  return (null errors)

-------------------------------------------------------------------------------
-- Grouping/displaying checks

-- Poor man’s “group checks by constructor”.
groupChecks :: [PackageCheck] -> [NE.NonEmpty PackageCheck]
groupChecks :: [PackageCheck] -> [NonEmpty PackageCheck]
groupChecks [PackageCheck]
ds =
  (PackageCheck -> PackageCheck -> Bool)
-> [PackageCheck] -> [NonEmpty PackageCheck]
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Bool) -> f a -> [NonEmpty a]
NE.groupBy
    ((Int -> Int -> Bool)
-> (PackageCheck -> Int) -> PackageCheck -> PackageCheck -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
F.on Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) PackageCheck -> Int
constInt)
    ((PackageCheck -> PackageCheck -> Ordering)
-> [PackageCheck] -> [PackageCheck]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy ((Int -> Int -> Ordering)
-> (PackageCheck -> Int)
-> PackageCheck
-> PackageCheck
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
F.on Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare PackageCheck -> Int
constInt) [PackageCheck]
ds)
  where
    constInt :: PackageCheck -> Int
    constInt :: PackageCheck -> Int
constInt (PackageBuildImpossible{}) = Int
0
    constInt (PackageBuildWarning{}) = Int
1
    constInt (PackageDistSuspicious{}) = Int
2
    constInt (PackageDistSuspiciousWarn{}) = Int
3
    constInt (PackageDistInexcusable{}) = Int
4

groupExplanation :: PackageCheck -> String
groupExplanation :: PackageCheck -> FilePath
groupExplanation (PackageBuildImpossible{}) = FilePath
"The package will not build sanely due to these errors:"
groupExplanation (PackageBuildWarning{}) = FilePath
"The following errors are likely to affect your build negatively:"
groupExplanation (PackageDistSuspicious{}) = FilePath
"These warnings will likely cause trouble when distributing the package:"
groupExplanation (PackageDistSuspiciousWarn{}) = FilePath
"These warnings may cause trouble when distributing the package:"
groupExplanation (PackageDistInexcusable{}) = FilePath
"The following errors will cause portability problems on other environments:"

groupOutputFunction :: PackageCheck -> Verbosity -> String -> IO ()
groupOutputFunction :: PackageCheck -> Verbosity -> FilePath -> IO ()
groupOutputFunction (PackageBuildImpossible{}) Verbosity
ver = Verbosity -> FilePath -> IO ()
warnError Verbosity
ver
groupOutputFunction (PackageBuildWarning{}) Verbosity
ver = Verbosity -> FilePath -> IO ()
warnError Verbosity
ver
groupOutputFunction (PackageDistSuspicious{}) Verbosity
ver = Verbosity -> FilePath -> IO ()
warn Verbosity
ver
groupOutputFunction (PackageDistSuspiciousWarn{}) Verbosity
ver = Verbosity -> FilePath -> IO ()
warn Verbosity
ver
groupOutputFunction (PackageDistInexcusable{}) Verbosity
ver = Verbosity -> FilePath -> IO ()
warnError Verbosity
ver

outputGroupCheck :: Verbosity -> NE.NonEmpty PackageCheck -> IO ()
outputGroupCheck :: Verbosity -> NonEmpty PackageCheck -> IO ()
outputGroupCheck Verbosity
ver NonEmpty PackageCheck
pcs = do
  let hp :: PackageCheck
hp = NonEmpty PackageCheck -> PackageCheck
forall a. NonEmpty a -> a
NE.head NonEmpty PackageCheck
pcs
      outf :: FilePath -> IO ()
outf = PackageCheck -> Verbosity -> FilePath -> IO ()
groupOutputFunction PackageCheck
hp Verbosity
ver
  Verbosity -> FilePath -> IO ()
notice Verbosity
ver (PackageCheck -> FilePath
groupExplanation PackageCheck
hp)
  (PackageCheck -> IO ()) -> NonEmpty PackageCheck -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
CM.mapM_ (FilePath -> IO ()
outf (FilePath -> IO ())
-> (PackageCheck -> FilePath) -> PackageCheck -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageCheck -> FilePath
ppPackageCheck) NonEmpty PackageCheck
pcs