|
| 1 | +{-# LANGUAGE NamedFieldPuns #-} |
| 2 | + |
| 3 | +module Distribution.Client.CmdGenBounds |
| 4 | + ( genBounds |
| 5 | + , genBoundsCommand |
| 6 | + , genBoundsAction |
| 7 | + , GenBoundsFlags (..) |
| 8 | + , defaultGenBoundsFlags |
| 9 | + ) where |
| 10 | + |
| 11 | +import Distribution.Client.Compat.Prelude |
| 12 | +import Prelude () |
| 13 | + |
| 14 | +import qualified Data.Map as Map |
| 15 | + |
| 16 | +import Control.Monad (mapM_) |
| 17 | + |
| 18 | +import Distribution.Client.Errors |
| 19 | + |
| 20 | +import Distribution.Client.ProjectPlanning hiding (pruneInstallPlanToTargets) |
| 21 | +import Distribution.Client.ProjectPlanning.Types |
| 22 | +import Distribution.Client.Types.ConfiguredId (confInstId) |
| 23 | +import Distribution.Client.Utils hiding (pvpize) |
| 24 | +import Distribution.InstalledPackageInfo (InstalledPackageInfo, installedComponentId) |
| 25 | +import Distribution.Package |
| 26 | +import Distribution.PackageDescription |
| 27 | +import Distribution.Simple.Utils |
| 28 | +import Distribution.Version |
| 29 | + |
| 30 | +import Distribution.Client.Setup (CommonSetupFlags (..), ConfigFlags (..), GlobalFlags (..)) |
| 31 | + |
| 32 | +-- Project orchestration imports |
| 33 | + |
| 34 | +import Distribution.Client.CmdErrorMessages |
| 35 | +import Distribution.Client.GenBounds |
| 36 | +import qualified Distribution.Client.InstallPlan as InstallPlan |
| 37 | +import Distribution.Client.NixStyleOptions |
| 38 | +import Distribution.Client.ProjectFlags |
| 39 | +import Distribution.Client.ProjectOrchestration |
| 40 | +import Distribution.Client.ScriptUtils |
| 41 | +import Distribution.Client.TargetProblem |
| 42 | +import Distribution.Simple.Command |
| 43 | +import Distribution.Simple.Flag |
| 44 | +import Distribution.Types.Component |
| 45 | +import Distribution.Verbosity |
| 46 | + |
| 47 | +-- | The data type for gen-bounds command flags |
| 48 | +data GenBoundsFlags = GenBoundsFlags {} |
| 49 | + |
| 50 | +-- | Default values for the gen-bounds flags |
| 51 | +defaultGenBoundsFlags :: GenBoundsFlags |
| 52 | +defaultGenBoundsFlags = GenBoundsFlags{} |
| 53 | + |
| 54 | +-- | The @gen-bounds@ command definition |
| 55 | +genBoundsCommand :: CommandUI (NixStyleFlags GenBoundsFlags) |
| 56 | +genBoundsCommand = |
| 57 | + CommandUI |
| 58 | + { commandName = "v2-gen-bounds" |
| 59 | + , commandSynopsis = "Generate dependency bounds for packages in the project." |
| 60 | + , commandUsage = usageAlternatives "v2-gen-bounds" ["[TARGETS] [FLAGS]"] |
| 61 | + , commandDescription = Just $ \_ -> |
| 62 | + "Generate PVP-compliant dependency bounds for packages in the project." |
| 63 | + , commandNotes = Just $ \pname -> |
| 64 | + "Examples:\n" |
| 65 | + ++ " " |
| 66 | + ++ pname |
| 67 | + ++ " v2-gen-bounds\n" |
| 68 | + ++ " Generate bounds for the package in the current directory " |
| 69 | + ++ "or all packages in the project\n" |
| 70 | + ++ " " |
| 71 | + ++ pname |
| 72 | + ++ " v2-gen-bounds pkgname\n" |
| 73 | + ++ " Generate bounds for the package named pkgname in the project\n" |
| 74 | + ++ " " |
| 75 | + ++ pname |
| 76 | + ++ " v2-gen-bounds ./pkgfoo\n" |
| 77 | + ++ " Generate bounds for the package in the ./pkgfoo directory\n" |
| 78 | + , commandDefaultFlags = defaultNixStyleFlags defaultGenBoundsFlags |
| 79 | + , commandOptions = |
| 80 | + removeIgnoreProjectOption |
| 81 | + . nixStyleOptions (const []) |
| 82 | + } |
| 83 | + |
| 84 | +-- | The action for the @gen-bounds@ command when used in a project context. |
| 85 | +genBoundsAction :: NixStyleFlags GenBoundsFlags -> [String] -> GlobalFlags -> IO () |
| 86 | +genBoundsAction flags targetStrings globalFlags = |
| 87 | + withContextAndSelectors RejectNoTargets Nothing flags targetStrings globalFlags OtherCommand $ \targetCtx ctx targetSelectors -> do |
| 88 | + let verbosity = fromFlagOrDefault normal (setupVerbosity $ configCommonFlags $ configFlags flags) |
| 89 | + |
| 90 | + baseCtx <- case targetCtx of |
| 91 | + ProjectContext -> return ctx |
| 92 | + GlobalContext -> return ctx |
| 93 | + ScriptContext path _ -> |
| 94 | + dieWithException verbosity $ |
| 95 | + GenBoundsDoesNotSupportScript path |
| 96 | + |
| 97 | + let ProjectBaseContext{distDirLayout, cabalDirLayout, projectConfig, localPackages} = baseCtx |
| 98 | + |
| 99 | + -- Step 1: Create the install plan for the project. |
| 100 | + (_, elaboratedPlan, _, _, _) <- |
| 101 | + rebuildInstallPlan |
| 102 | + verbosity |
| 103 | + distDirLayout |
| 104 | + cabalDirLayout |
| 105 | + projectConfig |
| 106 | + localPackages |
| 107 | + Nothing |
| 108 | + |
| 109 | + -- Step 2: Resolve the targets for the gen-bounds command. |
| 110 | + targets <- |
| 111 | + either (reportGenBoundsTargetProblems verbosity) return $ |
| 112 | + resolveTargets |
| 113 | + selectPackageTargets |
| 114 | + selectComponentTarget |
| 115 | + elaboratedPlan |
| 116 | + Nothing |
| 117 | + targetSelectors |
| 118 | + |
| 119 | + -- Step 3: Prune the install plan to the targets. |
| 120 | + let elaboratedPlan' = |
| 121 | + pruneInstallPlanToTargets |
| 122 | + TargetActionBuild |
| 123 | + targets |
| 124 | + elaboratedPlan |
| 125 | + |
| 126 | + let |
| 127 | + -- Step 4a: Find the local packages from the install plan. These are the |
| 128 | + -- candidates for which we will generate bounds. |
| 129 | + localPkgs :: [ElaboratedConfiguredPackage] |
| 130 | + localPkgs = mapMaybe (InstallPlan.foldPlanPackage (const Nothing) (\p -> Just p)) (InstallPlan.toList elaboratedPlan') |
| 131 | + |
| 132 | + -- Step 4b: Extract which versions we chose for each package from the pruned install plan. |
| 133 | + pkgVersionMap :: Map.Map ComponentId PackageIdentifier |
| 134 | + pkgVersionMap = Map.fromList (map (InstallPlan.foldPlanPackage externalVersion localVersion) (InstallPlan.toList elaboratedPlan')) |
| 135 | + |
| 136 | + externalVersion :: InstalledPackageInfo -> (ComponentId, PackageIdentifier) |
| 137 | + externalVersion pkg = (installedComponentId pkg, packageId pkg) |
| 138 | + |
| 139 | + localVersion :: ElaboratedConfiguredPackage -> (ComponentId, PackageIdentifier) |
| 140 | + localVersion pkg = (elabComponentId pkg, packageId pkg) |
| 141 | + |
| 142 | + let genBoundsActionForPkg :: ElaboratedConfiguredPackage -> [GenBoundsResult] |
| 143 | + genBoundsActionForPkg pkg = |
| 144 | + -- Step 5: Match up the user specified targets with the local packages. |
| 145 | + case Map.lookup (installedUnitId pkg) targets of |
| 146 | + Nothing -> [] |
| 147 | + Just tgts -> |
| 148 | + map (\(tgt, _) -> getBoundsForComponent tgt pkg pkgVersionMap) tgts |
| 149 | + |
| 150 | + -- Process each package to find the ones needing bounds |
| 151 | + let boundsActions = concatMap genBoundsActionForPkg localPkgs |
| 152 | + |
| 153 | + if (any isBoundsNeeded boundsActions) |
| 154 | + then do |
| 155 | + notice verbosity boundsNeededMsg |
| 156 | + mapM_ (renderBoundsResult verbosity) boundsActions |
| 157 | + else notice verbosity "All bounds up-to-date" |
| 158 | + |
| 159 | +data GenBoundsResult = GenBoundsResult PackageIdentifier ComponentTarget (Maybe [PackageIdentifier]) |
| 160 | + |
| 161 | +isBoundsNeeded :: GenBoundsResult -> Bool |
| 162 | +isBoundsNeeded (GenBoundsResult _ _ Nothing) = False |
| 163 | +isBoundsNeeded _ = True |
| 164 | + |
| 165 | +renderBoundsResult :: Verbosity -> GenBoundsResult -> IO () |
| 166 | +renderBoundsResult verbosity (GenBoundsResult pid tgt bounds) = |
| 167 | + case bounds of |
| 168 | + Nothing -> |
| 169 | + notice |
| 170 | + verbosity |
| 171 | + ("Congratulations, all dependencies for " ++ prettyShow (packageName pid) ++ ":" ++ showComponentTarget pid tgt ++ " have upper bounds!") |
| 172 | + Just pkgBounds -> do |
| 173 | + notice verbosity $ |
| 174 | + "For component " ++ prettyShow (pkgName pid) ++ ":" ++ showComponentTarget pid tgt ++ ":" |
| 175 | + let padTo = maximum $ map (length . unPackageName . packageName) pkgBounds |
| 176 | + traverse_ (notice verbosity . (++ ",") . showBounds padTo) pkgBounds |
| 177 | + |
| 178 | +-- | Process a single BuildInfo to identify and report missing upper bounds |
| 179 | +getBoundsForComponent |
| 180 | + :: ComponentTarget |
| 181 | + -> ElaboratedConfiguredPackage |
| 182 | + -> Map.Map ComponentId PackageIdentifier |
| 183 | + -> GenBoundsResult |
| 184 | +getBoundsForComponent tgt pkg pkgVersionMap = |
| 185 | + if null needBounds |
| 186 | + then boundsResult Nothing |
| 187 | + else -- All the things we depend on. |
| 188 | + |
| 189 | + let componentDeps = elabLibDependencies pkg |
| 190 | + -- Match these up to package names, this is a list of Package name to versions. |
| 191 | + -- Now just match that up with what the user wrote in the build-depends section. |
| 192 | + depsWithVersions = mapMaybe (\cid -> Map.lookup (confInstId $ fst cid) pkgVersionMap) componentDeps |
| 193 | + isNeeded = hasElem needBounds . packageName |
| 194 | + in boundsResult (Just (filter isNeeded depsWithVersions)) |
| 195 | + where |
| 196 | + pd = elabPkgDescription pkg |
| 197 | + -- Extract the build-depends for the right part of the cabal file. |
| 198 | + bi = buildInfoForTarget pd tgt |
| 199 | + |
| 200 | + -- We need to generate bounds if |
| 201 | + -- \* the dependency does not have an upper bound |
| 202 | + -- \* the dependency is not the same package as the one we are processing |
| 203 | + boundFilter dep = |
| 204 | + (not (hasUpperBound (depVerRange dep))) |
| 205 | + && packageName pd /= depPkgName dep |
| 206 | + |
| 207 | + -- The dependencies that need bounds. |
| 208 | + needBounds = map depPkgName $ filter boundFilter $ targetBuildDepends bi |
| 209 | + |
| 210 | + boundsResult = GenBoundsResult (packageId pkg) tgt |
| 211 | + |
| 212 | +buildInfoForTarget :: PackageDescription -> ComponentTarget -> BuildInfo |
| 213 | +buildInfoForTarget pd (ComponentTarget cname _) = componentBuildInfo $ getComponent pd cname |
| 214 | + |
| 215 | +-- | This defines what a 'TargetSelector' means for the @gen-bounds@ command. |
| 216 | +-- Copy of selectPackageTargets from CmdBuild.hs |
| 217 | +selectPackageTargets |
| 218 | + :: TargetSelector |
| 219 | + -> [AvailableTarget k] |
| 220 | + -> Either TargetProblem' [k] |
| 221 | +selectPackageTargets targetSelector targets |
| 222 | + -- If there are any buildable targets then we select those |
| 223 | + | not (null targetsBuildable) = |
| 224 | + Right targetsBuildable |
| 225 | + -- If there are targets but none are buildable then we report those |
| 226 | + | not (null targets) = |
| 227 | + Left (TargetProblemNoneEnabled targetSelector targets') |
| 228 | + -- If there are no targets at all then we report that |
| 229 | + | otherwise = |
| 230 | + Left (TargetProblemNoTargets targetSelector) |
| 231 | + where |
| 232 | + targets' = forgetTargetsDetail targets |
| 233 | + targetsBuildable = |
| 234 | + selectBuildableTargetsWith |
| 235 | + (buildable targetSelector) |
| 236 | + targets |
| 237 | + |
| 238 | + -- When there's a target filter like "pkg:tests" then we do select tests, |
| 239 | + -- but if it's just a target like "pkg" then we don't build tests unless |
| 240 | + -- they are requested by default (i.e. by using --enable-tests) |
| 241 | + buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False |
| 242 | + buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False |
| 243 | + buildable _ _ = True |
| 244 | + |
| 245 | +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be |
| 246 | +-- selected. Copy of selectComponentTarget from CmdBuild.hs |
| 247 | +selectComponentTarget |
| 248 | + :: SubComponentTarget |
| 249 | + -> AvailableTarget k |
| 250 | + -> Either TargetProblem' k |
| 251 | +selectComponentTarget = selectComponentTargetBasic |
| 252 | + |
| 253 | +-- | Report target problems for gen-bounds command |
| 254 | +reportGenBoundsTargetProblems :: Verbosity -> [TargetProblem'] -> IO a |
| 255 | +reportGenBoundsTargetProblems verbosity problems = |
| 256 | + reportTargetProblems verbosity "gen-bounds" problems |
0 commit comments