|
| 1 | +{-# LANGUAGE CPP #-} |
| 2 | +{-# LANGUAGE NamedFieldPuns #-} |
| 3 | +{-# LANGUAGE RankNTypes #-} |
| 4 | + |
| 5 | +-- | cabal-install CLI command: outdated |
| 6 | +module Distribution.Client.CmdOutdated |
| 7 | + ( outdatedCommand |
| 8 | + , outdatedAction |
| 9 | + ) where |
| 10 | + |
| 11 | +import Distribution.Client.Compat.Prelude |
| 12 | + |
| 13 | +import Distribution.Client.Config |
| 14 | + ( SavedConfig |
| 15 | + ( savedGlobalFlags |
| 16 | + ) |
| 17 | + ) |
| 18 | +import Distribution.Client.Errors (CabalInstallException (OutdatedAction)) |
| 19 | +import qualified Distribution.Client.IndexUtils as IndexUtils |
| 20 | +import Distribution.Client.NixStyleOptions |
| 21 | + ( NixStyleFlags (..) |
| 22 | + , defaultNixStyleFlags |
| 23 | + , nixStyleOptions |
| 24 | + ) |
| 25 | +import Distribution.Client.Outdated |
| 26 | + ( OutdatedFlags (..) |
| 27 | + ) |
| 28 | +import qualified Distribution.Client.Outdated as V1Outdated |
| 29 | +import Distribution.Client.ProjectConfig |
| 30 | + ( ProjectConfig (..) |
| 31 | + , commandLineFlagsToProjectConfig |
| 32 | + , fetchAndReadSourcePackages |
| 33 | + , findProjectPackages |
| 34 | + ) |
| 35 | +import Distribution.Client.ProjectFlags |
| 36 | + ( ProjectFlags (..) |
| 37 | + ) |
| 38 | +import Distribution.Client.ProjectOrchestration |
| 39 | + ( CurrentCommand (..) |
| 40 | + , ProjectBaseContext (..) |
| 41 | + , establishProjectBaseContext |
| 42 | + ) |
| 43 | +import Distribution.Client.RebuildMonad |
| 44 | + ( runRebuild |
| 45 | + ) |
| 46 | +import Distribution.Client.Sandbox |
| 47 | + ( loadConfigOrSandboxConfig |
| 48 | + ) |
| 49 | +import Distribution.Client.Setup |
| 50 | + ( GlobalFlags (..) |
| 51 | + , withRepoContext |
| 52 | + ) |
| 53 | +import Distribution.Client.Types.PackageLocation |
| 54 | + ( UnresolvedPkgLoc |
| 55 | + ) |
| 56 | +import Distribution.Client.Types.PackageSpecifier |
| 57 | + ( PackageSpecifier (..) |
| 58 | + ) |
| 59 | +import Distribution.Simple.Command |
| 60 | + ( CommandUI (..) |
| 61 | + , usageAlternatives |
| 62 | + ) |
| 63 | +import Distribution.Simple.Flag |
| 64 | + ( Flag (..) |
| 65 | + , flagToMaybe |
| 66 | + , fromFlagOrDefault |
| 67 | + ) |
| 68 | +import Distribution.Simple.Utils |
| 69 | + ( debug |
| 70 | + , dieWithException |
| 71 | + , wrapText |
| 72 | + ) |
| 73 | +import Distribution.Solver.Types.SourcePackage |
| 74 | + ( SourcePackage (..) |
| 75 | + ) |
| 76 | +import Distribution.Types.CondTree |
| 77 | + ( CondTree (..) |
| 78 | + , ignoreConditions |
| 79 | + ) |
| 80 | +import Distribution.Types.Dependency (Dependency (..)) |
| 81 | +import Distribution.Types.GenericPackageDescription |
| 82 | + ( GenericPackageDescription (..) |
| 83 | + ) |
| 84 | +import Distribution.Types.PackageVersionConstraint |
| 85 | + ( PackageVersionConstraint (..) |
| 86 | + ) |
| 87 | +import Distribution.Types.UnqualComponentName (UnqualComponentName) |
| 88 | +import Distribution.Verbosity |
| 89 | + ( normal |
| 90 | + , silent |
| 91 | + ) |
| 92 | +import Distribution.Version |
| 93 | + ( simplifyVersionRange |
| 94 | + ) |
| 95 | + |
| 96 | +outdatedCommand :: CommandUI (NixStyleFlags OutdatedFlags) |
| 97 | +outdatedCommand = |
| 98 | + CommandUI |
| 99 | + { commandName = "v2-outdated" |
| 100 | + , commandSynopsis = "Check for outdated dependencies." |
| 101 | + , commandUsage = usageAlternatives "v2-outdated" ["[FLAGS]", "[PACKAGES]"] |
| 102 | + , commandDefaultFlags = defaultNixStyleFlags V1Outdated.defaultOutdatedFlags |
| 103 | + , commandDescription = Just $ \_ -> |
| 104 | + wrapText $ |
| 105 | + "Checks for outdated dependencies in the package description file " |
| 106 | + ++ "or freeze file" |
| 107 | + , commandNotes = Nothing |
| 108 | + , commandOptions = nixStyleOptions V1Outdated.outdatedOptions |
| 109 | + } |
| 110 | + |
| 111 | +-- | To a first approximation, the @outdated@ command runs the first phase of |
| 112 | +-- the @build@ command where we bring the install plan up to date, and then |
| 113 | +-- based on the install plan we write out a @cabal.project.outdated@ config file. |
| 114 | +-- |
| 115 | +-- For more details on how this works, see the module |
| 116 | +-- "Distribution.Client.ProjectOrchestration" |
| 117 | +outdatedAction :: NixStyleFlags OutdatedFlags -> [String] -> GlobalFlags -> IO () |
| 118 | +outdatedAction flags _extraArgs globalFlags = do |
| 119 | + let mprojectDir = flagToMaybe . flagProjectDir $ projectFlags flags |
| 120 | + mprojectFile = flagToMaybe . flagProjectFile $ projectFlags flags |
| 121 | + |
| 122 | + config <- loadConfigOrSandboxConfig verbosity globalFlags |
| 123 | + let globalFlags' = savedGlobalFlags config `mappend` globalFlags |
| 124 | + |
| 125 | + withRepoContext verbosity globalFlags' $ \repoContext -> do |
| 126 | + when (isJust mprojectDir || isJust mprojectFile) $ |
| 127 | + dieWithException verbosity OutdatedAction |
| 128 | + |
| 129 | + sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext |
| 130 | + |
| 131 | + prjBaseCtxt <- establishProjectBaseContext verbosity cliConfig OtherCommand |
| 132 | + |
| 133 | + pkgSpecifiers <- |
| 134 | + runRebuild "." $ do |
| 135 | + plList <- findProjectPackages (distDirLayout prjBaseCtxt) (projectConfig prjBaseCtxt) |
| 136 | + fetchAndReadSourcePackages |
| 137 | + verbosity |
| 138 | + (distDirLayout prjBaseCtxt) |
| 139 | + (projectConfigShared $ projectConfig prjBaseCtxt) |
| 140 | + (projectConfigBuildOnly $ projectConfig prjBaseCtxt) |
| 141 | + plList |
| 142 | + |
| 143 | + let pkgVerConstraints = extractPackageVersionConstraints pkgSpecifiers |
| 144 | + |
| 145 | + debug verbosity $ |
| 146 | + "Dependencies loaded: " ++ intercalate ", " (map prettyShow pkgVerConstraints) |
| 147 | + |
| 148 | + let outdatedDeps = V1Outdated.listOutdated pkgVerConstraints sourcePkgDb (V1Outdated.ListOutdatedSettings (const True) (const True)) |
| 149 | + |
| 150 | + when (not quiet) $ |
| 151 | + V1Outdated.showResult verbosity outdatedDeps simpleOutput |
| 152 | + if exitCode && (not . null $ outdatedDeps) |
| 153 | + then exitFailure |
| 154 | + else pure () |
| 155 | + where |
| 156 | + cliConfig :: ProjectConfig |
| 157 | + cliConfig = |
| 158 | + commandLineFlagsToProjectConfig |
| 159 | + globalFlags |
| 160 | + flags |
| 161 | + mempty -- ClientInstallFlags, not needed here |
| 162 | + simpleOutput = fromFlagOrDefault False (Flag False) -- outdatedSimpleOutput |
| 163 | + exitCode = fromFlagOrDefault quiet (Flag False) -- outdatedExitCode |
| 164 | + quiet = fromFlagOrDefault False (Flag False) -- outdatedQuiet |
| 165 | + verbosity = |
| 166 | + if quiet |
| 167 | + then silent |
| 168 | + else fromFlagOrDefault normal (outdatedVerbosity outdatedFlags) |
| 169 | + |
| 170 | + outdatedFlags :: OutdatedFlags |
| 171 | + outdatedFlags = extraFlags flags |
| 172 | + |
| 173 | +extractPackageVersionConstraints :: [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] -> [PackageVersionConstraint] |
| 174 | +extractPackageVersionConstraints = |
| 175 | + map toPackageVersionConstraint . concatMap genericPackageDependencies . mapMaybe getGenericPackageDescription |
| 176 | + where |
| 177 | + getGenericPackageDescription :: PackageSpecifier (SourcePackage UnresolvedPkgLoc) -> Maybe GenericPackageDescription |
| 178 | + getGenericPackageDescription ps = |
| 179 | + case ps of |
| 180 | + NamedPackage{} -> Nothing |
| 181 | + SpecificSourcePackage x -> Just $ srcpkgDescription x |
| 182 | + |
| 183 | + toPackageVersionConstraint :: Dependency -> PackageVersionConstraint |
| 184 | + toPackageVersionConstraint (Dependency name versionRange _) = |
| 185 | + PackageVersionConstraint name (simplifyVersionRange versionRange) |
| 186 | + |
| 187 | +genericPackageDependencies :: GenericPackageDescription -> [Dependency] |
| 188 | +genericPackageDependencies gpd = |
| 189 | + concat |
| 190 | + [ maybe [] (snd . ignoreConditions) $ condLibrary gpd |
| 191 | + , concatMap extract $ condSubLibraries gpd |
| 192 | + , concatMap extract $ condForeignLibs gpd |
| 193 | + , concatMap extract $ condExecutables gpd |
| 194 | + , concatMap extract $ condTestSuites gpd |
| 195 | + , concatMap extract $ condBenchmarks gpd |
| 196 | + ] |
| 197 | + where |
| 198 | + extract :: forall a confVar. Semigroup a => (UnqualComponentName, CondTree confVar [Dependency] a) -> [Dependency] |
| 199 | + extract = snd . ignoreConditions . snd |
0 commit comments