-- |
-- 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
  Bool
exists <- FilePath -> IO Bool
Dir.doesFileExist FilePath
fpath
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$
      FilePath -> CabalInstallException
FileDoesntExist FilePath
fpath
  ByteString
bs <- FilePath -> IO ByteString
BS.readFile FilePath
fpath
  let ([PWarning]
warnings, Either (Maybe Version, NonEmpty PError) GenericPackageDescription
result) = ParseResult GenericPackageDescription
-> ([PWarning],
    Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
runParseResult (ByteString -> ParseResult GenericPackageDescription
parseGenericPackageDescription ByteString
bs)
  case Either (Maybe Version, NonEmpty PError) GenericPackageDescription
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 packge 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
  FilePath
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
  ([PWarning]
ws, GenericPackageDescription
ppd) <- Verbosity -> FilePath -> IO ([PWarning], GenericPackageDescription)
readGenericPackageDescriptionCheck Verbosity
verbosity FilePath
pdfile
  -- convert parse warnings into PackageChecks
  let ws' :: [PackageCheck]
ws' = (PWarning -> PackageCheck) -> [PWarning] -> [PackageCheck]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> PWarning -> PackageCheck
wrapParseWarning FilePath
pdfile) [PWarning]
ws
  [PackageCheck]
ioChecks <- Verbosity
-> GenericPackageDescription -> FilePath -> IO [PackageCheck]
checkPackageFilesGPD Verbosity
verbosity GenericPackageDescription
ppd FilePath
"."
  let packageChecksPrim :: [PackageCheck]
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'
      ([PackageCheck]
packageChecks, [FilePath]
unrecs) = [PackageCheck] -> [FilePath] -> ([PackageCheck], [FilePath])
filterPackageChecksByIdString [PackageCheck]
packageChecksPrim [FilePath]
ignores

  (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
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
"\"")) [FilePath]
unrecs

  (NonEmpty PackageCheck -> IO ())
-> [NonEmpty PackageCheck] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
CM.mapM_ (Verbosity -> NonEmpty PackageCheck -> IO ()
outputGroupCheck Verbosity
verbosity) ([PackageCheck] -> [NonEmpty PackageCheck]
groupChecks [PackageCheck]
packageChecks)

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

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PackageCheck] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageCheck]
errors) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity -> FilePath -> IO ()
warnError Verbosity
verbosity FilePath
"Hackage would reject this package."

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([PackageCheck] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageCheck]
packageChecks) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity FilePath
"No errors or warnings could be found in the package."

  Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([PackageCheck] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageCheck]
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