Add TARGET option to cabal check

cabal-install/cabal-install.cabal

@@ -87,6 +87,7 @@ library
         Distribution.Client.Check
         Distribution.Client.CmdBench
         Distribution.Client.CmdBuild
+        Distribution.Client.CmdCheck
         Distribution.Client.CmdClean
         Distribution.Client.CmdConfigure
         Distribution.Client.CmdErrorMessages

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

@@ -16,65 +16,74 @@
 -- Check a package for common mistakes
 module Distribution.Client.Check
   ( check
+  , multiCheck
   ) where
 
 import Distribution.Client.Compat.Prelude
 import Prelude ()
 
 import Distribution.Client.Utils.Parsec (renderParseError)
-import Distribution.PackageDescription (GenericPackageDescription)
+import Distribution.PackageDescription (GenericPackageDescription, PackageName)
 import Distribution.PackageDescription.Check
 import Distribution.PackageDescription.Parsec
   ( parseGenericPackageDescription
   , runParseResult
   )
 import Distribution.Parsec (PWarning (..), showPError)
-import Distribution.Simple.Utils (defaultPackageDesc, dieWithException, notice, warn, warnError)
+import Distribution.Simple.Utils (dieWithException, findPackageDesc, notice, warn, warnError)
 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 Distribution.Client.Errors
+import qualified Distribution.Client.Errors as E
+import qualified Distribution.Types.PackageName as PN
 import qualified System.Directory as Dir
 
 readGenericPackageDescriptionCheck :: Verbosity -> FilePath -> IO ([PWarning], GenericPackageDescription)
 readGenericPackageDescriptionCheck verbosity fpath = do
   exists <- Dir.doesFileExist fpath
   unless exists $
     dieWithException verbosity $
-      FileDoesntExist fpath
+      E.FileDoesntExist fpath
   bs <- BS.readFile fpath
   let (warnings, result) = runParseResult (parseGenericPackageDescription bs)
   case result of
     Left (_, errors) -> do
       traverse_ (warn verbosity . showPError fpath) errors
       hPutStr stderr $ renderParseError fpath bs errors warnings
-      dieWithException verbosity ParseError
+      dieWithException verbosity E.ParseError
     Right x -> return (warnings, 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
+  -> Maybe PackageName
   -> [CheckExplanationIDString]
   -- ^ List of check-ids in String form
   -- (e.g. @invalid-path-win@) to ignore.
+  -> FilePath
+  -- ^ Folder to check (where `.cabal` file is).
   -> IO Bool
-check verbosity ignores = do
-  pdfile <- defaultPackageDesc verbosity
+check verbosity mPkgName ignores checkDir = do
+  epdf <- findPackageDesc checkDir
+  pdfile <- case epdf of
+    Right cf -> return cf
+    Left e -> dieWithException verbosity e
   (ws, ppd) <- readGenericPackageDescriptionCheck verbosity pdfile
   -- convert parse warnings into PackageChecks
   let ws' = map (wrapParseWarning pdfile) ws
-  ioChecks <- checkPackageFilesGPD verbosity ppd "."
+  ioChecks <- checkPackageFilesGPD verbosity ppd checkDir
   let packageChecksPrim = ioChecks ++ checkPackage ppd ++ ws'
       (packageChecks, unrecs) = filterPackageChecksByIdString packageChecksPrim ignores
 
   CM.mapM_ (\s -> warn verbosity ("Unrecognised ignore \"" ++ s ++ "\"")) unrecs
+  case mPkgName of
+    (Just pn) -> notice verbosity $ "***  " ++ PN.unPackageName pn
+    Nothing -> return ()
 
   CM.mapM_ (outputGroupCheck verbosity) (groupChecks packageChecks)
 
@@ -88,6 +97,29 @@ check verbosity ignores = do
 
   return (null errors)
 
+-- | Same as 'check', but with output adjusted for multiple targets.
+multiCheck
+  :: Verbosity
+  -> [CheckExplanationIDString]
+  -- ^ List of check-ids in String form
+  -- (e.g. @invalid-path-win@) to ignore.
+  -> [(PackageName, FilePath)]
+  -- ^ Folder to check (where `.cabal` file is).
+  -> IO Bool
+multiCheck verbosity _ [] = do
+  notice verbosity "check: no targets, nothing to do."
+  return True
+multiCheck verbosity ignores [(_, checkDir)] = do
+  -- Only one target, do not print header with package name.
+  check verbosity Nothing ignores checkDir
+multiCheck verbosity ignores namesDirs = do
+  bs <- CM.mapM (uncurry checkFun) namesDirs
+  return (and bs)
+  where
+    checkFun :: PackageName -> FilePath -> IO Bool
+    checkFun mpn wdir = do
+      check verbosity (Just mpn) ignores wdir
+
 -------------------------------------------------------------------------------
 -- Grouping/displaying checks
 

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

@@ -0,0 +1,149 @@
+module Distribution.Client.CmdCheck
+  ( checkCommand
+  , checkAction
+  ) where
+
+import Distribution.Client.Compat.Prelude
+import Prelude ()
+
+import Distribution.Client.Check (multiCheck)
+
+{-
+import Distribution.Client.CmdErrorMessages
+        -- xxx vedi questo!
+  ( plural
+  , renderListCommaAnd
+  , renderTargetProblem
+  , renderTargetProblemNoTargets
+  , renderTargetSelector
+  , showTargetSelector
+  , targetSelectorFilter
+  , targetSelectorPluralPkgs
+  )
+-}
+import Distribution.Client.ProjectOrchestration
+import Distribution.Client.Setup (GlobalFlags (..))
+import Distribution.Client.Types.PackageLocation
+  ( PackageLocation (..)
+  , UnresolvedSourcePackage
+  )
+import Distribution.Client.Types.PackageSpecifier (PackageSpecifier (..))
+import Distribution.PackageDescription.Check (CheckExplanationIDString)
+import Distribution.Simple.Command (CommandUI (..), OptionField (..), ShowOrParseArgs, option, reqArg')
+import Distribution.Simple.Setup (Flag (..), fromFlag, optionVerbosity)
+import Distribution.Simple.Utils (wrapText)
+import Distribution.Solver.Types.SourcePackage (srcpkgPackageId, srcpkgSource)
+import Distribution.Types.PackageId
+import Distribution.Verbosity (normal)
+
+data CheckFlags = CheckFlags
+  { checkVerbosity :: Flag Verbosity
+  , checkIgnore :: [CheckExplanationIDString]
+  }
+  deriving (Show, Typeable)
+
+defaultCheckFlags :: CheckFlags
+defaultCheckFlags =
+  CheckFlags
+    { checkVerbosity = Flag normal
+    , checkIgnore = []
+    }
+
+checkOptions' :: ShowOrParseArgs -> [OptionField CheckFlags]
+checkOptions' _showOrParseArgs =
+  [ optionVerbosity
+      checkVerbosity
+      (\v flags -> flags{checkVerbosity = v})
+  , option
+      ['i']
+      ["ignore"]
+      "ignore a specific warning (e.g. --ignore=missing-upper-bounds)"
+      checkIgnore
+      (\v c -> c{checkIgnore = v ++ checkIgnore c})
+      (reqArg' "WARNING" (: []) (const []))
+  ]
+
+-------------------------------------------------------------------------------
+-- Command
+-------------------------------------------------------------------------------
+
+checkCommand :: CommandUI CheckFlags
+checkCommand =
+  CommandUI
+    { commandName = "check"
+    , commandSynopsis = "Check the package for common mistakes."
+    , commandDescription = Just $ \_ ->
+        wrapText $
+          "If no targets are passed, expects a .cabal package file in the "
+            ++ "current directory.\n"
+            ++ "\n"
+            ++ "Some checks correspond to the requirements to packages on Hackage. "
+            ++ "If no `Error` is reported, Hackage should accept the "
+            ++ "package. If errors are present, `check` exits with 1 and Hackage "
+            ++ "will refuse the package.\n"
+    , commandNotes = Nothing
+    , commandUsage = usageFlags "check"
+    , commandDefaultFlags = defaultCheckFlags
+    , commandOptions = checkOptions'
+    }
+
+usageFlags :: String -> String -> String
+usageFlags name pname =
+  "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"
+
+-------------------------------------------------------------------------------
+-- Action
+-------------------------------------------------------------------------------
+
+checkAction :: CheckFlags -> [String] -> GlobalFlags -> IO ()
+checkAction checkFlags extraArgs _globalFlags = do
+  -- xxx questo solo se non è vuoto
+  -- Compute base context.
+  let verbosityFlag = checkVerbosity checkFlags
+      verbosity = fromFlag verbosityFlag
+  baseCtx <- establishProjectBaseContext verbosity mempty OtherCommand
+  let localPkgs = localPackages baseCtx
+  let localIdSrc = mapMaybe specifierPkgIdSrc localPkgs
+
+  -- xxx qui astra con cmdinstall
+  -- Get/process selectors. The only sensible selectors for `check`
+  -- are only those which refer to a package as a whole.
+  targetSelectors <-
+    either (reportTargetSelectorProblems verbosity) return
+      =<< readTargetSelectors localPkgs Nothing extraArgs
+  let processedSels = concat $ mapMaybe (processSelector (map fst localIdSrc)) targetSelectors
+
+      -- And finally go from selectors to a directory we can feed to `check`.
+      selectedIdSrc = filter (flip elem processedSels . fst) localIdSrc
+      namesSrcs = map (\(li, ls) -> (pkgName li, ls)) selectedIdSrc
+
+  allOk <- multiCheck (fromFlag verbosityFlag) (checkIgnore checkFlags) namesSrcs
+  unless allOk exitFailure
+  where
+    -- Good selectors for `check` are only those who refer to a
+    -- package as a whole.
+    processSelector :: [PackageId] -> TargetSelector -> Maybe [PackageId]
+    processSelector _ (TargetPackage _ pIds _) = Just pIds
+    processSelector _ (TargetPackageNamed{}) = Nothing
+    processSelector allIds (TargetAllPackages{}) = Just allIds
+    processSelector _ (TargetComponent{}) = Nothing
+    processSelector _ (TargetComponentUnknown{}) = Nothing
+    -- xxx errori qui
+    -- xxx qua non solo Nothing, ma anche errori
+
+    -- Only 'PackageSpecifier's with an actual directory.
+    specifierPkgIdSrc
+      :: PackageSpecifier UnresolvedSourcePackage
+      -> Maybe (PackageId, FilePath)
+    specifierPkgIdSrc (NamedPackage{}) = Nothing
+    specifierPkgIdSrc (SpecificSourcePackage pkg) =
+      let pId = srcpkgPackageId pkg
+       in -- No interested in remote/compressed sources.
+          case srcpkgSource pkg of
+            (LocalUnpackedPackage fp) -> Just (pId, fp)
+            (LocalTarballPackage{}) -> Nothing
+            (RemoteTarballPackage{}) -> Nothing
+            (RepoTarballPackage{}) -> Nothing
+            (RemoteSourceRepoPackage{}) -> Nothing
+
+-- xxx orribile cambia

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

@@ -81,7 +81,6 @@ data CabalInstallException
   | UploadActionDocumentation
   | UploadActionOnlyArchives [FilePath]
   | FileNotFound FilePath
-  | CheckAction [String]
   | ReportAction [String]
   | InitAction
   | UserConfigAction FilePath
@@ -231,7 +230,6 @@ exceptionCodeCabalInstall e = case e of
   UploadActionDocumentation{} -> 7052
   UploadActionOnlyArchives{} -> 7053
   FileNotFound{} -> 7054
-  CheckAction{} -> 7055
   ReportAction{} -> 7056
   InitAction{} -> 7057
   UserConfigAction{} -> 7058
@@ -405,7 +403,6 @@ exceptionMessageCabalInstall e = case e of
     "the 'upload' command expects only .tar.gz archives: "
       ++ intercalate ", " otherFiles
   FileNotFound tarfile -> "file not found: " ++ tarfile
-  CheckAction extraArgs -> "'check' doesn't take any extra arguments: " ++ unwords extraArgs
   ReportAction extraArgs -> "'report' doesn't take any extra arguments: " ++ unwords extraArgs
   InitAction ->
     "'init' only takes a single, optional, extra "

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

@@ -23,7 +23,6 @@ module Distribution.Client.Main (main) where
 import Distribution.Client.Setup
   ( ActAsSetupFlags (..)
   , BuildFlags (..)
-  , CheckFlags (..)
   , ConfigExFlags (..)
   , ConfigFlags (..)
   , FetchFlags (..)
@@ -42,7 +41,6 @@ import Distribution.Client.Setup
   , actAsSetupCommand
   , benchmarkCommand
   , buildCommand
-  , checkCommand
   , cleanCommand
   , configCompilerAux'
   , configPackageDB'
@@ -127,6 +125,7 @@ import Distribution.Client.Targets
 
 import qualified Distribution.Client.CmdBench as CmdBench
 import qualified Distribution.Client.CmdBuild as CmdBuild
+import qualified Distribution.Client.CmdCheck as CmdCheck
 import qualified Distribution.Client.CmdClean as CmdClean
 import qualified Distribution.Client.CmdConfigure as CmdConfigure
 import qualified Distribution.Client.CmdExec as CmdExec
@@ -143,7 +142,6 @@ import qualified Distribution.Client.CmdSdist as CmdSdist
 import qualified Distribution.Client.CmdTest as CmdTest
 import qualified Distribution.Client.CmdUpdate as CmdUpdate
 
-import Distribution.Client.Check as Check (check)
 import Distribution.Client.Configure (configure, writeConfigFlags)
 import Distribution.Client.Fetch (fetch)
 import Distribution.Client.Freeze (freeze)
@@ -429,7 +427,7 @@ mainWorker args = do
       , regularCmd fetchCommand fetchAction
       , regularCmd getCommand getAction
       , regularCmd unpackCommand unpackAction
-      , regularCmd checkCommand checkAction
+      , regularCmd CmdCheck.checkCommand CmdCheck.checkAction
       , regularCmd uploadCommand uploadAction
       , regularCmd reportCommand reportAction
       , regularCmd initCommand initAction
@@ -1230,16 +1228,6 @@ uploadAction uploadFlags extraArgs globalFlags = do
       pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref)
       return $ distPref </> display (packageId pkg) ++ "-docs" <.> "tar.gz"
 
-checkAction :: CheckFlags -> [String] -> Action
-checkAction checkFlags extraArgs _globalFlags = do
-  let verbosityFlag = checkVerbosity checkFlags
-      verbosity = fromFlag verbosityFlag
-  unless (null extraArgs) $
-    dieWithException verbosity $
-      CheckAction extraArgs
-  allOk <- Check.check (fromFlag verbosityFlag) (checkIgnore checkFlags)
-  unless allOk exitFailure
-
 formatAction :: Flag Verbosity -> [String] -> Action
 formatAction verbosityFlag extraArgs _globalFlags = do
   let verbosity = fromFlag verbosityFlag