|
| 1 | +module Distribution.Client.CmdCheck |
| 2 | + ( checkCommand |
| 3 | + , checkAction |
| 4 | + ) where |
| 5 | + |
| 6 | +import Distribution.Client.Compat.Prelude |
| 7 | +import Prelude () |
| 8 | + |
| 9 | +import Distribution.Client.Check (multiCheck) |
| 10 | + |
| 11 | +{- |
| 12 | +import Distribution.Client.CmdErrorMessages |
| 13 | + -- xxx vedi questo! |
| 14 | + ( plural |
| 15 | + , renderListCommaAnd |
| 16 | + , renderTargetProblem |
| 17 | + , renderTargetProblemNoTargets |
| 18 | + , renderTargetSelector |
| 19 | + , showTargetSelector |
| 20 | + , targetSelectorFilter |
| 21 | + , targetSelectorPluralPkgs |
| 22 | + ) |
| 23 | +-} |
| 24 | +import Distribution.Client.ProjectOrchestration |
| 25 | +import Distribution.Client.Setup (GlobalFlags (..)) |
| 26 | +import Distribution.Client.Types.PackageLocation |
| 27 | + ( PackageLocation (..) |
| 28 | + , UnresolvedSourcePackage |
| 29 | + ) |
| 30 | +import Distribution.Client.Types.PackageSpecifier (PackageSpecifier (..)) |
| 31 | +import Distribution.PackageDescription.Check (CheckExplanationIDString) |
| 32 | +import Distribution.Simple.Command (CommandUI (..), OptionField (..), ShowOrParseArgs, option, reqArg') |
| 33 | +import Distribution.Simple.Setup (Flag (..), fromFlag, optionVerbosity) |
| 34 | +import Distribution.Simple.Utils (wrapText) |
| 35 | +import Distribution.Solver.Types.SourcePackage (srcpkgPackageId, srcpkgSource) |
| 36 | +import Distribution.Types.PackageId |
| 37 | +import Distribution.Verbosity (normal) |
| 38 | + |
| 39 | +data CheckFlags = CheckFlags |
| 40 | + { checkVerbosity :: Flag Verbosity |
| 41 | + , checkIgnore :: [CheckExplanationIDString] |
| 42 | + } |
| 43 | + deriving (Show, Typeable) |
| 44 | + |
| 45 | +defaultCheckFlags :: CheckFlags |
| 46 | +defaultCheckFlags = |
| 47 | + CheckFlags |
| 48 | + { checkVerbosity = Flag normal |
| 49 | + , checkIgnore = [] |
| 50 | + } |
| 51 | + |
| 52 | +checkOptions' :: ShowOrParseArgs -> [OptionField CheckFlags] |
| 53 | +checkOptions' _showOrParseArgs = |
| 54 | + [ optionVerbosity |
| 55 | + checkVerbosity |
| 56 | + (\v flags -> flags{checkVerbosity = v}) |
| 57 | + , option |
| 58 | + ['i'] |
| 59 | + ["ignore"] |
| 60 | + "ignore a specific warning (e.g. --ignore=missing-upper-bounds)" |
| 61 | + checkIgnore |
| 62 | + (\v c -> c{checkIgnore = v ++ checkIgnore c}) |
| 63 | + (reqArg' "WARNING" (: []) (const [])) |
| 64 | + ] |
| 65 | + |
| 66 | +------------------------------------------------------------------------------- |
| 67 | +-- Command |
| 68 | +------------------------------------------------------------------------------- |
| 69 | + |
| 70 | +checkCommand :: CommandUI CheckFlags |
| 71 | +checkCommand = |
| 72 | + CommandUI |
| 73 | + { commandName = "check" |
| 74 | + , commandSynopsis = "Check the package for common mistakes." |
| 75 | + , commandDescription = Just $ \_ -> |
| 76 | + wrapText $ |
| 77 | + "If no targets are passed, expects a .cabal package file in the " |
| 78 | + ++ "current directory.\n" |
| 79 | + ++ "\n" |
| 80 | + ++ "Some checks correspond to the requirements to packages on Hackage. " |
| 81 | + ++ "If no `Error` is reported, Hackage should accept the " |
| 82 | + ++ "package. If errors are present, `check` exits with 1 and Hackage " |
| 83 | + ++ "will refuse the package.\n" |
| 84 | + , commandNotes = Nothing |
| 85 | + , commandUsage = usageFlags "check" |
| 86 | + , commandDefaultFlags = defaultCheckFlags |
| 87 | + , commandOptions = checkOptions' |
| 88 | + } |
| 89 | + |
| 90 | +usageFlags :: String -> String -> String |
| 91 | +usageFlags name pname = |
| 92 | + "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n" |
| 93 | + |
| 94 | +------------------------------------------------------------------------------- |
| 95 | +-- Action |
| 96 | +------------------------------------------------------------------------------- |
| 97 | + |
| 98 | +checkAction :: CheckFlags -> [String] -> GlobalFlags -> IO () |
| 99 | +checkAction checkFlags extraArgs _globalFlags = do |
| 100 | + -- xxx questo solo se non è vuoto |
| 101 | + -- Compute base context. |
| 102 | + let verbosityFlag = checkVerbosity checkFlags |
| 103 | + verbosity = fromFlag verbosityFlag |
| 104 | + baseCtx <- establishProjectBaseContext verbosity mempty OtherCommand |
| 105 | + let localPkgs = localPackages baseCtx |
| 106 | + let localIdSrc = mapMaybe specifierPkgIdSrc localPkgs |
| 107 | + |
| 108 | + -- xxx qui astra con cmdinstall |
| 109 | + -- Get/process selectors. The only sensible selectors for `check` |
| 110 | + -- are only those which refer to a package as a whole. |
| 111 | + targetSelectors <- |
| 112 | + either (reportTargetSelectorProblems verbosity) return |
| 113 | + =<< readTargetSelectors localPkgs Nothing extraArgs |
| 114 | + let processedSels = concat $ mapMaybe (processSelector (map fst localIdSrc)) targetSelectors |
| 115 | + |
| 116 | + -- And finally go from selectors to a directory we can feed to `check`. |
| 117 | + selectedIdSrc = filter (flip elem processedSels . fst) localIdSrc |
| 118 | + namesSrcs = map (\(li, ls) -> (pkgName li, ls)) selectedIdSrc |
| 119 | + |
| 120 | + allOk <- multiCheck (fromFlag verbosityFlag) (checkIgnore checkFlags) namesSrcs |
| 121 | + unless allOk exitFailure |
| 122 | + where |
| 123 | + -- Good selectors for `check` are only those who refer to a |
| 124 | + -- package as a whole. |
| 125 | + processSelector :: [PackageId] -> TargetSelector -> Maybe [PackageId] |
| 126 | + processSelector _ (TargetPackage _ pIds _) = Just pIds |
| 127 | + processSelector _ (TargetPackageNamed{}) = Nothing |
| 128 | + processSelector allIds (TargetAllPackages{}) = Just allIds |
| 129 | + processSelector _ (TargetComponent{}) = Nothing |
| 130 | + processSelector _ (TargetComponentUnknown{}) = Nothing |
| 131 | + -- xxx errori qui |
| 132 | + -- xxx qua non solo Nothing, ma anche errori |
| 133 | + |
| 134 | + -- Only 'PackageSpecifier's with an actual directory. |
| 135 | + specifierPkgIdSrc |
| 136 | + :: PackageSpecifier UnresolvedSourcePackage |
| 137 | + -> Maybe (PackageId, FilePath) |
| 138 | + specifierPkgIdSrc (NamedPackage{}) = Nothing |
| 139 | + specifierPkgIdSrc (SpecificSourcePackage pkg) = |
| 140 | + let pId = srcpkgPackageId pkg |
| 141 | + in -- No interested in remote/compressed sources. |
| 142 | + case srcpkgSource pkg of |
| 143 | + (LocalUnpackedPackage fp) -> Just (pId, fp) |
| 144 | + (LocalTarballPackage{}) -> Nothing |
| 145 | + (RemoteTarballPackage{}) -> Nothing |
| 146 | + (RepoTarballPackage{}) -> Nothing |
| 147 | + (RemoteSourceRepoPackage{}) -> Nothing |
| 148 | + |
| 149 | +-- xxx orribile cambia |
| 150 | + |
0 commit comments