arch-hs 0.16 → 0.16.1
raw patch · 18 files changed
+1592/−207 lines, 18 filesdep +Cabal-syntaxdep −Cabaldep ~filepathdep ~template-haskellPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: Cabal-syntax
Dependencies removed: Cabal
Dependency ranges changed: filepath, template-haskell
API changes (from Hackage documentation)
+ Distribution.ArchHs.Core: getDepsWithVersion :: forall (r :: EffectRow). Members '[KnownGHCVersion, FlagAssignmentsEnv, DependencyRecord :: (Type -> Type) -> Type -> Type, Trace :: (Type -> Type) -> Type -> Type] r => GenericPackageDescription -> Sem r ([(PackageName, VersionRange)], [(PackageName, VersionRange)], [(PackageName, VersionRange)])
+ Distribution.ArchHs.DepCheck: dependencyFailuresByCategory :: forall (r :: EffectRow). Members '[KnownGHCVersion, ExtraEnv, FlagAssignmentsEnv, WithMyErr :: (Type -> Type) -> Type -> Type, Trace :: (Type -> Type) -> Type -> Type, DependencyRecord :: (Type -> Type) -> Type -> Type] r => GenericPackageDescription -> Sem r ([DependencyFailure], [DependencyFailure])
+ Distribution.ArchHs.Hackage: getLatestVersion :: forall (r :: EffectRow). Members '[HackageEnv, WithMyErr :: (Type -> Type) -> Type -> Type] r => PackageName -> Sem r Version
+ Distribution.ArchHs.PkgBuild: [_removeBoundsWithUusi] :: PkgBuild -> [String]
- Distribution.ArchHs.Core: cabalToPkgBuild :: forall (r :: EffectRow). Members '[HackageEnv, FlagAssignmentsEnv, WithMyErr :: (Type -> Type) -> Type -> Type] r => SolvedPackage -> Bool -> [ArchLinuxName] -> Sem r PkgBuild
+ Distribution.ArchHs.Core: cabalToPkgBuild :: forall (r :: EffectRow). Members '[Embed IO, ExtraEnv, RawHackageEnv, HackageEnv, KnownGHCVersion, FlagAssignmentsEnv, DependencyRecord :: (Type -> Type) -> Type -> Type, Trace :: (Type -> Type) -> Type -> Type, WithMyErr :: (Type -> Type) -> Type -> Type] r => ([(PackageName, Version)] -> IO (RawHackageDB, RawHackageDB)) -> SolvedPackage -> Bool -> [ArchLinuxName] -> Sem r PkgBuild
- Distribution.ArchHs.PkgBuild: PkgBuild :: String -> String -> String -> String -> String -> String -> String -> String -> String -> Maybe String -> Bool -> String -> PkgBuild
+ Distribution.ArchHs.PkgBuild: PkgBuild :: String -> String -> String -> String -> String -> String -> String -> String -> String -> Maybe String -> Bool -> [String] -> String -> PkgBuild
Files
- CHANGELOG.md +18/−0
- README.md +14/−5
- app/Main.hs +11/−6
- arch-hs.cabal +9/−5
- plan/Main.hs +10/−2
- plan/Plan.hs +685/−119
- plan/Plan/Args.hs +4/−2
- plan/Plan/Solver.hs +212/−0
- plan/Plan/Trace.hs +14/−0
- src/Distribution/ArchHs/Compat.hs +0/−11
- src/Distribution/ArchHs/Core.hs +80/−6
- src/Distribution/ArchHs/DepCheck.hs +11/−2
- src/Distribution/ArchHs/Hackage.hs +6/−1
- src/Distribution/ArchHs/PkgBuild.hs +18/−9
- src/Distribution/ArchHs/RDepCheck.hs +3/−8
- sync/Check.hs +28/−10
- test/Main.hs +99/−7
- test/PlanSpec.hs +370/−14
CHANGELOG.md view
@@ -3,6 +3,24 @@ `arch-hs` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +## 0.16.1++- Count existing direct dependency failures as `dep-old` warnings in `arch-hs-sync check --depcheck`, keeping only newly unmet dependencies blocking++- Speed up coordinated update solving in `arch-hs-plan --solve` with bounded constraint optimization, minimizing dependency blockers before release steps and pruning equivalent package choices and uncompetitive compiler alternatives++- Add `arch-hs-plan --debug` for solver progress and metadata diagnostics, and distinguish full-solution dependency conflicts from the selected partial plan's blockers++- Remove the obsolete `--ignore ghc-static` exclusion from generated GHC rebuild commands++- Automatically generate selective `uusi` commands for dependency bounds relaxed by Hackage revisions, retaining `--uusi` as a manual override++- Pass `MAKEFLAGS` to builds and show test details directly in generated PKGBUILDs++- Replace the `Cabal` dependency with `Cabal-syntax`, support its 3.16 license identifiers, and update dependency bounds and tested GHC versions to 9.6 through 9.12++- Fix Arch Linux CI by installing the planner's `yaml` dependency+ ## 0.16 - Add `arch-hs-plan` to check coordinated updates against dependencies and reverse dependencies, with optional search that automatically expands to blocking packages using the fewest incremental release steps
README.md view
@@ -349,15 +349,20 @@ ### Uusi +`arch-hs` automatically detects updated bounds in revisions and includes them using the `uusi` command where necessary.++If none are detected, the behaviour can be overridden manually via the `--uusi` flag:+ ``` $ arch-hs -o ~/test --uusi TARGET ``` -With `--uusi`, `arch-hs` will generate following snippet for each package:+With `--uusi`, `arch-hs` will generate the following snippet for each package: ```bash prepare() {- uusi $_hkgname-$pkgver/$_hkgname.cabal+ cd $_hkgname-$pkgver+ uusi } ``` @@ -592,7 +597,7 @@ GHC plans fetch [Stackage's upstream GHC bundled-library snapshots](https://github.com/commercialhaskell/stackage-content/blob/master/stack/global-hints.yaml); no built Arch GHC package is needed. Each candidate compiler fixes its entire Unix library bundle, including newly bundled and removed libraries. Missing or invalid compiler metadata is an error rather than a reason to guess library versions. Bundled libraries cannot be requested or upgraded independently. The snapshots do not specify versions of compiler-provided executables such as `hsc2hs`; dependencies on these tools are explicitly reported as unchecked, rather than assuming the tools were removed or retaining their old versions. -The planner rechecks every repository Haskell package with the proposed compiler and bundled versions, including `impl(ghc ...)` conditionals. Existing-failure comparisons still use the repository compiler and dependency versions, so newly activated incompatibilities block the plan. With `--solve`, blocking packages can be updated automatically. Only changed bundled versions, including added or removed libraries, are shown separately; unchanged versions and empty bundled summaries are hidden. Bundled libraries do not become individual package updates in the commit message or rebuild command. GHC rebuild commands include `--ignore ghc-static` to override `genrebuild -H`'s default exclusion of `ghc`.+The planner rechecks every repository Haskell package with the proposed compiler and bundled versions, including `impl(ghc ...)` conditionals. Existing-failure comparisons still use the repository compiler and dependency versions, so newly activated incompatibilities block the plan. With `--solve`, blocking packages can be updated automatically. Only changed bundled versions, including added or removed libraries, are shown separately; unchanged versions and empty bundled summaries are hidden. Bundled libraries do not become individual package updates in the commit message or rebuild command. Add `--solve` to search for a compatible combination: @@ -639,11 +644,15 @@ `rdep` counts ranges that accept the current [extra] version but reject the candidate. `rdep-old` counts ranges that reject both versions. Each failing range is counted separately, including different dependency sources of the same reverse dependency. Ranges satisfied by the candidate are not counted, even if they reject the current version. -Candidates with only existing reverse dependency failures are shown in yellow as `existing: rdep-old=N`. Candidates with direct dependency failures or newly unmet reverse dependency ranges are shown in red as `blocked`, with existing failures counted separately when present.+`dep` counts newly unmet direct dependency ranges. `dep-old` counts failing ranges for dependencies whose requirements are already unmet for the installed package, comparing runtime dependencies separately from build and test dependencies. Each candidate is compared with the installed version's latest Cabal revision, even if that version is deprecated. Dependencies removed or satisfied by the candidate are not counted. If the installed version's metadata cannot be read or checked, direct dependency failures remain blocking rather than being assumed existing. +Candidates with only existing direct or reverse dependency failures are shown in yellow as `existing: dep-old=N, rdep-old=M`, omitting zero counts. Candidates with newly unmet direct or reverse dependency ranges are shown in red as `blocked`, with existing failures counted separately when present. Existing failure warnings do not establish build compatibility.++For example, both `tree-diff` 0.3.3 and 0.3.4 require `ansi-wl-pprint ^>=1.0.2`, which rejects [extra]'s 1.1.1. Since upgrading does not introduce that failure, 0.3.4 is shown as `existing: dep-old=1`, not `blocked: dep=1`.+ If a candidate's `.cabal` file cannot be parsed, `--depcheck` marks it as `unchecked: cabal parse failed` and continues checking the other candidates. Use `--verbose` to include the lookup error. -Add `--verbose` with `--depcheck` to list the dependency and reverse dependency ranges that fail for a version, with existing reverse dependency failures labeled `rdep-old:`:+Add `--verbose` with `--depcheck` to list the dependency and reverse dependency ranges that fail for a version, with existing failures labeled `dep-old:` and `rdep-old:`: ``` $ arch-hs-sync check --depcheck --verbose
app/Main.hs view
@@ -44,7 +44,7 @@ import System.FilePath (takeFileName) app ::- (Members '[Embed IO, State (Set.Set PackageName), KnownGHCVersion, ExtraEnv, HackageEnv, FlagAssignmentsEnv, DependencyRecord, Trace, Aur, WithMyErr] r) =>+ (Members '[Embed IO, State (Set.Set PackageName), KnownGHCVersion, ExtraEnv, HackageEnv, RawHackageEnv, FlagAssignmentsEnv, DependencyRecord, Trace, Aur, WithMyErr] r) => PackageName -> FilePath -> Bool ->@@ -55,8 +55,9 @@ FilePath -> Bool -> (DBKind -> IO FilesDB) ->+ ([(PackageName, Version)] -> IO (RawHackageDB, RawHackageDB)) -> Sem r ()-app target path aurSupport skip uusi force installDeps jsonPath noSkipMissing loadFilesDB' = do+app target path aurSupport skip uusi force installDeps jsonPath noSkipMissing loadFilesDB' loadHackageRevisions' = do (deps, sublibs, sysDeps) <- getDependencies (fmap mkUnqualComponentName skip) Nothing target inExtra <- isInExtra target@@ -197,7 +198,7 @@ unless (null path) $ mapM_ ( \solved -> do- pkgBuild <- cabalToPkgBuild solved uusi $ getSysDeps (solved ^. pkgName)+ pkgBuild <- cabalToPkgBuild loadHackageRevisions' solved uusi $ getSysDeps (solved ^. pkgName) let pName = N._pkgName pkgBuild dir = path </> pName fileName = dir </> "PKGBUILD"@@ -264,6 +265,7 @@ ----------------------------------------------------------------------------- runApp ::+ RawHackageDB -> HackageDB -> ExtraDB -> Map.Map PackageName FlagAssignment ->@@ -271,9 +273,9 @@ FilePath -> IORef (Set.Set PackageName) -> Manager ->- Sem '[ExtraEnv, HackageEnv, FlagAssignmentsEnv, DependencyRecord, Trace, State (Set.Set PackageName), Aur, WithMyErr, Embed IO, Final IO] a ->+ Sem '[ExtraEnv, HackageEnv, RawHackageEnv, FlagAssignmentsEnv, DependencyRecord, Trace, State (Set.Set PackageName), Aur, WithMyErr, Embed IO, Final IO] a -> IO (Either MyException a)-runApp hackage extra flags traceStdout tracePath ref manager =+runApp rawHackage hackage extra flags traceStdout tracePath ref manager = runFinal . embedToFinal . errorToIOFinal@@ -282,6 +284,7 @@ . runTrace traceStdout tracePath . evalState Map.empty . runReader flags+ . runReader rawHackage . runReader hackage . runReader extra @@ -323,6 +326,7 @@ when optUusi $ printInfo "You specified --uusi, uusi will become makedepends of each package" hackage <- loadHackageDBFromOptions optHackage+ rawHackage <- loadRawHackageDBFromOptions optHackage let isExtraEmpty = null optExtraCabalDirs optExtraCabal <- mapM findCabalFile optExtraCabalDirs@@ -344,6 +348,7 @@ manager <- newTlsManager runApp+ rawHackage newHackage extra optFlags@@ -351,7 +356,7 @@ optFileTrace ref manager- (subsumeGHCVersion $ app optTarget optOutputDir optAur optSkip optUusi optForce optInstallDeps optJson optNoSkipMissing (loadFilesDBFromOptions optFilesDB))+ (subsumeGHCVersion $ app optTarget optOutputDir optAur optSkip optUusi optForce optInstallDeps optJson optNoSkipMissing (loadFilesDBFromOptions optFilesDB) (loadRawHackageRevisionsFromOptions optHackage)) & printAppResult -----------------------------------------------------------------------------
arch-hs.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: arch-hs-version: 0.16+version: 0.16.1 synopsis: Distribute hackage packages to archlinux description: @arch-hs@ is a command-line program, which simplifies the process of producing@@ -23,7 +23,7 @@ CHANGELOG.md README.md -tested-with: GHC ==9.2.8 || ==9.4.8 || ==9.6.7 || ==9.8.4+tested-with: GHC ==9.6.7 || ==9.8.4 || ==9.10.3 || ==9.12.4 source-repository head type: git@@ -41,14 +41,14 @@ , arch-web ^>=0.3.2 , base >=4.12 && <5 , bytestring- , Cabal >=3.8 && <3.11+ , Cabal-syntax >=3.8 && <3.17 , conduit ^>=1.3.2 , conduit-extra ^>=1.3.5 , containers , deepseq ^>=1.4.4 || ^>=1.5.0 , Diff ^>=0.4.0 || ^>=0.5 || ^>= 1.0 , directory ^>=1.3.6- , filepath ^>=1.4.2+ , filepath ^>=1.4.2 || ^>= 1.5.2.0 , hackage-db ^>=2.1.0 , http-client , http-client-tls@@ -64,7 +64,7 @@ , servant-client >=0.18.2 && <0.21 , split ^>=0.2.3 , tar-conduit ^>=0.3.2 || ^>=0.4.0- , template-haskell ^>=2.18.0 || ^>=2.19.0 || ^>=2.20.0 || ^>=2.21.0+ , template-haskell ^>=2.20.0 || ^>=2.21.0 || ^>=2.22.0 || ^>=2.23.0 || ^>=2.24.0 , text ghc-options:@@ -175,7 +175,9 @@ other-modules: Plan Plan.Args+ Plan.Solver Plan.Toolchain+ Plan.Trace build-depends: , arch-hs@@ -198,7 +200,9 @@ Diff Plan Plan.Args+ Plan.Solver Plan.Toolchain+ Plan.Trace PlanSpec RDepCheck RDepCheck.Args
plan/Main.hs view
@@ -17,18 +17,25 @@ import Plan import Plan.Args import Plan.Toolchain (loadGHCReleases)+import Plan.Trace (runPlanTrace, tracePlan) import System.Exit (die, exitFailure)+import System.IO (hFlush, hPutStrLn, stderr) main :: IO () main = Exception.handle @Exception.IOException (\err -> printError (viaShow err) >> exitFailure) $ do setLocaleEncoding utf8 Options {..} <- runArgsParser+ let debug message = when optDebug $ hPutStrLn stderr ("[plan] " <> message) >> hFlush stderr+ debug "Loading package databases..." releases <- if any ((== "ghc") . fst) optTargets then do+ debug "Loading upstream GHC bundled-library metadata..." printInfo "Loading upstream GHC bundled-library metadata..." either die pure =<< loadGHCReleases else pure Map.empty+ debug "Loading repository package metadata..." extra <- loadExtraDBFromOptions optExtraDB+ debug "Loading the Hackage index and Cabal revisions..." (hackage, raw, original) <- loadHackageDBsWithRevisionsFromOptions optHackage unless (Map.null optFlags) $ printInfo $ "Assigned flags:" <> line <> prettyFlagAssignments optFlags printInfo $ if optSolve then "Searching incremental update sets..." else "Checking update set..."@@ -37,7 +44,7 @@ . embedToFinal @IO . errorToIOFinal @MyException . evalState (Map.empty :: Map.Map PackageName [VersionRange])- . ignoreTrace+ . runPlanTrace optDebug stderr . runReader optFlags . runReader raw . runReader hackage@@ -45,6 +52,7 @@ . subsumeGHCVersion $ do planned <- planUpdates releases optSolve optTargets+ tracePlan "Comparing Cabal revisions for the selected plan..." traverse (comparePlanRevisions original) planned case result of Left err -> printError (viaShow err) >> exitFailure@@ -53,7 +61,7 @@ putDoc $ prettyPlanResult plan <> line unless (planIsReady plan) $ do if not $ null $ planSearchNotes plan- then printError "The available versions cannot satisfy this update set. Showing the requested starting versions."+ then printError "The available versions cannot satisfy this update set. Showing the attempted set with the fewest blockers." else if optSolve then printError "No verified working set found after considering updates to blocking dependencies and reverse dependencies. Showing the attempted set with the fewest blockers." else printInfo "Use --solve to find compatible versions and automatically update blocking dependencies and reverse dependencies."
plan/Plan.hs view
@@ -6,8 +6,10 @@ module Plan (PlanResult (..), PlanProblem (..), planUpdates, planIsReady, prettyPlanResult, comparePlanRevisions) where -import Control.Monad (foldM, forM)+import Control.Monad (foldM, forM, forM_, unless)+import Data.Foldable (toList) import Data.List (foldl', partition, sortOn)+import qualified Data.IntMap.Strict as IntMap import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe, isJust) import Data.Ord (Down (..))@@ -22,8 +24,13 @@ import Distribution.ArchHs.PP import Distribution.ArchHs.RDepCheck import Distribution.ArchHs.Types+import Distribution.Compiler (CompilerFlavor (GHC))+import Distribution.Types.CondTree (CondTree, condTreeComponents, condBranchCondition, condBranchIfTrue, condBranchIfFalse)+import Distribution.Types.ConfVar (ConfVar (Impl)) import Distribution.Version (asVersionIntervals, simplifyVersionRange) import Plan.Toolchain+import qualified Plan.Solver as Solver+import Plan.Trace (tracePlan) type PlanEffects r = Members@@ -57,6 +64,7 @@ | length names /= Set.size (Set.fromList names) = pure $ Left "Each target must be specified only once." | any (\name -> name /= "ghc" && isGHCLibs name) names = pure $ Left "GHC bundled libraries cannot be updated independently; request ghc to update the toolchain." | otherwise = do+ tracePlan "Selecting starting versions..." installed <- Map.fromList <$> forM names (\name -> (name,) <$> currentVersion name) choices <- forM targets $ \(name, requested) -> do newer <- if not solve && requested /= Nothing then pure [] else@@ -89,18 +97,22 @@ data DependencyCache = DependencyCache { cachedDependencies :: Map.Map (Version, PackageName, Version) (Either MyException (VersionedList, VersionedList)),+ cachedDependencyConditions :: Map.Map (PackageName, Version) [VersionRange],+ cachedDependencyVariants :: Map.Map (PackageName, Version, [Bool]) (Either MyException (VersionedList, VersionedList)), cachedExistingDependencies :: Map.Map PackageName ExistingDependencies,+ cachedCandidateChecks :: Map.Map (Version, PackageName, Version, Bool, Map.Map PackageName Version) ([PlanProblem], [PlanProblem]), cachedToolchain :: Maybe Toolchain } type ExistingDependencies = Map.Map (DepSrc, PackageName) (VersionRange, Maybe Version) type ReverseChecks = [(PackageName, [ReverseDep], [SkippedReverseDep])] emptyDependencies :: DependencyCache-emptyDependencies = DependencyCache Map.empty Map.empty Nothing+emptyDependencies = DependencyCache Map.empty Map.empty Map.empty Map.empty Map.empty Nothing selectToolchain :: PlanEffects r => GHCReleases -> Map.Map PackageName Version -> DependencyCache -> Sem r DependencyCache selectToolchain releases selected cache = case Map.lookup "ghc" selected of Nothing -> pure cache+ Just release | Just toolchain <- cachedToolchain cache, toolchainVersion toolchain == release -> pure cache Just release -> do compiler <- ask @Version extra <- ask @ExtraDB@@ -149,9 +161,20 @@ searchReversePackages :: Map.Map ArchLinuxName (Set.Set ArchLinuxName), searchRetainable :: Map.Map (PackageName, Int, PackageName, Maybe Version) Bool, searchRequiredRanges :: Map.Map PackageName VersionRange,- searchConflicts :: Map.Map PackageName PlanProblem+ searchRangeOrigins :: RangeOrigins,+ searchConflicts :: Map.Map PackageName PlanProblem,+ searchRepairBounds :: Map.Map (Maybe Int, PackageName, Maybe Int, PackageName, Maybe Int) RepairBound,+ searchUnavoidableFailures :: Map.Map (Maybe Int, PackageName, Int) Int } +data RangeOrigin+ = DependencyOrigin [Version] [DepSrc] VersionRange+ | ReverseUpdateOrigin [Version]++type RangeOrigins = Map.Map PackageName (Map.Map PackageName RangeOrigin)++data RepairBound = RepairBound Int [(Set.Set PackageName, Int)] (Map.Map Version Int)+ externalChecks :: PlanEffects r => [PackageName] -> Map.Map ArchLinuxName (Set.Set ArchLinuxName) -> DependencyCache -> Sem r (ReverseChecks, DependencyCache) externalChecks targets reversePackages cache = do let names = Set.toList $ Set.filter ((`notElem` targets) . toHackageName) $@@ -191,6 +214,7 @@ Map.Map PackageName [Version] -> Sem r PlanResult search releases solve installed choices = do+ tracePlan "Collecting required dependency ranges..." extra <- ask @ExtraDB let reversePackages = Map.fromListWith Set.union [ (_pdName dependency, Set.singleton $ _name desc)@@ -198,110 +222,177 @@ isHaskellPackage $ _name desc, dependency <- _depends desc <> _makeDepends desc <> _checkDepends desc ]- (requiredRanges, dependencies) <- if updatingGHC then pure (Map.empty, emptyDependencies) else requestedRanges choices emptyDependencies- let initial = SearchCache installed choices dependencies Map.empty reversePackages Map.empty requiredRanges Map.empty+ (requiredRanges, origins, dependencies) <- if updatingGHC then pure (Map.empty, Map.empty, emptyDependencies) else requestedRanges choices emptyDependencies+ let initial = SearchCache installed choices dependencies Map.empty reversePackages Map.empty requiredRanges origins Map.empty Map.empty Map.empty+ tracePlan "Propagating dependency constraints..." (conflict, directCache) <- if solve && not updatingGHC then propagateRanges False (Map.keysSet choices) initial else pure (Nothing, initial) cache <- case conflict of- Nothing | solve && not updatingGHC -> snd <$> propagateRanges True (Map.keysSet choices) directCache+ Nothing | solve && not updatingGHC -> do+ tracePlan "Propagating reverse-dependency constraints..."+ snd <$> propagateRanges True (Map.keysSet choices) directCache+ Just problem -> pure directCache {searchConflicts = Map.singleton (fst $ Map.findMin choices) problem} _ -> pure directCache- case conflict of- Nothing -> go- (Map.singleton (0 :: Int, Down (0 :: Int), start) Nothing)- (Set.singleton start)- cache 0 Nothing- Just problem -> do- let selected = versions choices start- (reverseChecks, known) <- externalChecks (Map.keys selected) reversePackages (searchDependencies cache)- (problems, warnings, _) <- checkSet installed selected reverseChecks known- pure $ PlanResult installed selected (Map.keysSet choices) (problem : problems) warnings 1 Nothing [] []+ let partial = not $ Map.null $ searchConflicts cache+ known = if partial then cache {searchRequiredRanges = Map.empty} else cache+ tracePlan $ if partial then "Constraints cannot all be satisfied; optimizing the partial plan..." else "Searching candidate update sets..."+ forM_ (Map.elems $ searchConflicts cache) $ tracePlan . show . prettySearchConflict (Map.keysSet choices) cache+ go partial+ startingQueue+ startingVisited+ known 0 Nothing where updatingGHC = Map.member "ghc" choices start = Map.map (const 0) choices+ startingStates = (0, start) :+ [(index, Map.insert name index start) | (name, candidates) <- Map.toList choices, index <- [1 .. length candidates - 1]]+ startingQueue = Map.fromList [((0 :: Int, cost, Down cost, indices), Nothing) | (cost, indices) <- startingStates]+ startingVisited = Set.fromList $ snd <$> startingStates versions catalog indices = Map.mapWithKey (\name index -> catalog Map.! name !! index) indices - go queue visited cache tried best =+ go partial queue visited cache tried best = case Map.minViewWithKey queue of Nothing -> case best of- Just (_, result) -> finish tried cache result+ Just (_, result)+ | solve && not partial -> do+ tracePlan "No complete solution; optimizing the partial plan..."+ go True+ startingQueue+ startingVisited cache {searchRequiredRanges = Map.empty} tried best+ | otherwise -> finish tried cache result Nothing -> error "planner search starts with one candidate set"- Just (((estimate, Down cost, _), Just (result, neighbors)), remaining) ->- continue estimate cost remaining visited cache tried best result neighbors- Just (((estimate, Down cost, indices), Nothing), remaining) -> do- toolchainDependencies <- selectToolchain releases (versions (searchChoices cache) indices) (searchDependencies cache)- let selected = Map.filterWithKey (\name _ -> name == "ghc" || not (fixedPackage toolchainDependencies name)) $ versions (searchChoices cache) indices- targets = Map.keysSet selected- (reverseChecks, dependencies) <- if updatingGHC then pure ([], toolchainDependencies) else case Map.lookup targets (searchReverseChecks cache) of- Just cached -> pure (cached, searchDependencies cache)- Nothing -> externalChecks (Map.keys selected) (searchReversePackages cache) (searchDependencies cache)- (problems, warnings, dependencies') <- checkSet (searchInstalled cache) selected reverseChecks dependencies- let cache' = cache- { searchDependencies = dependencies',- searchReverseChecks = Map.insert targets reverseChecks (searchReverseChecks cache)- }- result = PlanResult- { planInstalled = Map.filterWithKey (\name _ -> Map.member name selected) (searchInstalled cache),- planVersions = selected,- planRequested = Map.keysSet choices,- planProblems = problems,- planWarnings = warnings,- plansTried = tried + 1,- planToolchain = cachedToolchain dependencies',- planRevisionNotes = [],- planSearchNotes = []- }- best' = case best of- Just (previousCost, previous)- | (length (planProblems previous), previousCost) <= (length problems, cost) -> best- _ -> Just (cost, result)- case problems of- [] -> pure result- -- Once propagation proves the whole update impossible, report the- -- checked starting set and the conflict. Optimizing partial sets- -- cannot produce a working plan and can grow exponentially.- _ | not $ Map.null $ searchConflicts cache' -> finish (tried + 1) cache' result- _ -> do- (neighbors, cache'') <- foldM (advance indices) ([], cache') (nub $ ["ghc" | updatingGHC] <> concatMap problemTargets problems)- let movable = Set.fromList $ fst <$> neighbors- (repairs, cache''') <- if updatingGHC- then pure- ( filter (not . Set.null) [Set.intersection movable $ Set.fromList $ "ghc" : problemTargets problem | problem <- problems],- cache''- )- else repairChoices movable indices problems cache''- let lowerBound = max (requiredSteps indices cache''') (remainingSteps movable repairs)- priority = max estimate (cost + lowerBound)- -- Every complete solution must repair this clause. Keep all- -- of its alternatives, without enumerating interleavings of- -- unrelated repairs. Prefer small clauses and preserve the- -- requested versions when either choice costs the same.- branchKey clause = (Set.size clause, not $ Set.null $ Set.intersection (Map.keysSet choices) clause, Set.toList clause)- next = case sortOn branchKey repairs of- [] -> []- clause : _ -> [nextState | (name, nextState) <- neighbors, Set.member name clause]- -- Refine a queued lower bound before expanding the node. Retain- -- its evaluation so reordering does not repeat metadata checks.- if priority > estimate- then go- (Map.insert (priority, Down cost, indices) (Just (result, next)) remaining)- visited cache''' (tried + 1) best'- else continue priority cost remaining visited cache''' (tried + 1) best' result next+ Just (((failureEstimate, estimate, Down cost, indices), queued), remaining)+ | partial && prunable failureEstimate estimate best -> go partial remaining visited cache tried best+ | Just (result, neighbors) <- queued ->+ continue partial failureEstimate estimate cost remaining visited cache tried best result neighbors+ | otherwise -> do+ tracePlan $ "Candidate " <> show (tried + 1) <> ": " <> show cost <> " release steps, " <> show (Map.size remaining) <> " queued; " <>+ intercalate ", " [unPackageName name <> " " <> prettyShow version | (name, version) <- Map.toList $ versions (searchChoices cache) indices]+ toolchainDependencies <- selectToolchain releases (versions (searchChoices cache) indices) (searchDependencies cache)+ let selected = Map.filterWithKey (\name _ -> name == "ghc" || not (fixedPackage toolchainDependencies name)) $ versions (searchChoices cache) indices+ targets = Map.keysSet selected+ (reverseChecks, dependencies) <- if updatingGHC then pure ([], toolchainDependencies) else case Map.lookup targets (searchReverseChecks cache) of+ Just cached -> pure (cached, searchDependencies cache)+ Nothing -> externalChecks (Map.keys selected) (searchReversePackages cache) (searchDependencies cache)+ (problems, warnings, dependencies') <- checkSet (searchInstalled cache) selected reverseChecks dependencies+ tracePlan $ "Candidate " <> show (tried + 1) <> ": " <> show (length problems) <> " blockers, " <> show (length warnings) <> " warnings"+ let checkedCache = cache+ { searchDependencies = dependencies',+ searchReverseChecks = Map.insert targets reverseChecks (searchReverseChecks cache)+ }+ (initialBounds, boundedCache) <- if not (solve && updatingGHC) && (partial || solve && tried == 0)+ then repairBounds releases indices selected problems checkedCache+ else pure ([], checkedCache)+ (ownerFailures, ownerCache) <- if not (solve && updatingGHC) && not (null problems) && (partial || solve && tried == 0 || jointFailures initialBounds > 0)+ then unavoidableFailures releases indices boundedCache+ else pure (0, boundedCache)+ (bounds, cache') <- if ownerFailures > 0 && null initialBounds+ then repairBounds releases indices selected problems ownerCache+ else pure (initialBounds, ownerCache)+ let unavoidable = sum [minimumFailures | (_, RepairBound minimumFailures _ _) <- bounds]+ failureBound = max ownerFailures $ jointFailures bounds+ boundedQueue = if indices == start && failureBound > 0+ then Map.fromList+ [((max failureBound failures, priority, depth, candidate), queuedCandidate)+ | ((failures, priority, depth, candidate), queuedCandidate) <- Map.toList remaining]+ else remaining+ partial' = partial || failureBound > 0+ diagnosed = if not partial && failureBound > 0+ then cache' {searchConflicts = Map.fromList+ [(owner, problem) | (problem : _, RepairBound minimumFailures _ _) <- bounds,+ owner : _ <- [problemTargets problem], minimumFailures > 0]}+ else cache'+ result = PlanResult+ { planInstalled = Map.filterWithKey (\name _ -> Map.member name selected) (searchInstalled cache),+ planVersions = selected,+ planRequested = Map.keysSet choices,+ planProblems = problems,+ planWarnings = warnings,+ plansTried = tried + 1,+ planToolchain = cachedToolchain dependencies',+ planRevisionNotes = [],+ planSearchNotes = []+ }+ best' = case best of+ Just (previousCost, previous)+ | (length (planProblems previous), previousCost) <= (length problems, cost) -> best+ _ -> Just (cost, result)+ when (maybe True (\(previousCost, previous) -> (length problems, cost) < (length $ planProblems previous, previousCost)) best) $ do+ tracePlan $ "Best plan: " <> show (length problems) <> " blockers, " <> show cost <> " release steps"+ forM_ problems $ tracePlan . show . prettyProblem+ when (not partial && partial') $ tracePlan $ "At least " <> show failureBound <> " blockers are unavoidable; optimizing the partial plan..."+ case problems of+ [] -> finish (tried + 1) cache' result+ _ | solve && updatingGHC -> do+ tracePlan "Optimizing compiler alternatives without incremental update-set enumeration..."+ (checked, optimized) <- optimizePartial releases choices cache' (tried + 1) best'+ let conflicts = Map.fromList+ [(owner, problem) | problem <- planProblems optimized, owner : _ <- [problemTargets problem]]+ finish checked cache' {searchConflicts = conflicts} optimized+ _ | partial' -> do+ let active = [alternatives | (related, RepairBound minimumFailures alternatives _) <- bounds, length related > minimumFailures]+ names = Set.toList $ Set.unions $ fst <$> concat active+ (neighbors, known) <- foldM (advance indices) ([], diagnosed {searchRequiredRanges = Map.empty}) names+ let movable = Set.fromList $ fst <$> neighbors+ minimumFailures = max failureEstimate $ max 1 failureBound+ allowance = minimumFailures - unavoidable+ steps = remainingCost movable allowance active+ priority = if minimumFailures == failureEstimate then max estimate (cost + steps) else cost + steps+ tracePlan $ "Partial-plan lower bound: " <> show minimumFailures <> " blockers, " <> show priority <> " release steps"+ if prunable minimumFailures priority best'+ then go True boundedQueue visited known (tried + 1) best'+ else do+ (checked, optimized) <- optimizePartial releases choices known (tried + 1) best'+ finish checked known optimized+ _ -> do+ (neighbors, cache'') <- foldM (advance indices) ([], cache') (nub $ ["ghc" | updatingGHC] <> concatMap problemTargets problems)+ let movable = Set.fromList $ fst <$> neighbors+ (repairs, cache''') <- if updatingGHC+ then pure+ ( filter (not . Set.null) [Set.intersection movable $ Set.fromList $ "ghc" : problemTargets problem | problem <- problems],+ cache''+ )+ else repairChoices movable indices problems cache''+ let lowerBound = max (requiredSteps indices cache''') (remainingSteps movable repairs)+ priority = max estimate (cost + lowerBound)+ -- Every complete solution must repair this clause. Keep all+ -- of its alternatives, without enumerating interleavings of+ -- unrelated repairs. Prefer small clauses and preserve the+ -- requested versions when either choice costs the same.+ branchKey clause = (Set.size clause, not $ Set.null $ Set.intersection (Map.keysSet choices) clause, Set.toList clause)+ next = case sortOn branchKey repairs of+ [] -> []+ clause : _ -> [nextState | (name, nextState) <- neighbors, Set.member name clause]+ tracePlan $ "Complete-plan lower bound: " <> show priority <> " release steps; " <> show (length next) <> " branches"+ -- Refine a queued lower bound before expanding the node. Retain+ -- its evaluation so reordering does not repeat metadata checks.+ if priority > estimate+ then go+ False (Map.insert (0, priority, Down cost, indices) (Just (result, next)) boundedQueue)+ visited cache''' (tried + 1) best'+ else continue False 0 priority cost boundedQueue visited cache''' (tried + 1) best' result next - finish tried cache result = pure result- { plansTried = tried,+ prunable failures cost best = case best of+ Just (previousCost, previous) -> (failures, cost) >= (length $ planProblems previous, previousCost)+ Nothing -> False++ finish tried cache result = do+ tracePlan $ "Search finished after " <> show tried <> " candidates; " <> show (length $ planProblems result) <> " blockers remain"+ pure result { plansTried = tried, planSearchNotes =- [ vsep $ "The required updates cannot all be satisfied:" : (indent 2 . prettyProblem <$> Map.elems (searchConflicts cache))+ [ vsep $ "Full-solution conflicts (not additional blockers in the partial plan):"+ : (indent 2 . prettySearchConflict (planRequested result) cache <$> Map.elems (searchConflicts cache)) | not $ Map.null $ searchConflicts cache ] } - continue estimate cost remaining visited cache tried best result neighbors+ continue partial failureEstimate estimate cost remaining visited cache tried best result neighbors | null $ planProblems result = pure result {plansTried = tried} | otherwise = let unseen = filter (`Set.notMember` visited) neighbors -- One release step can reduce the remaining cost by at most one. priority = max estimate (cost + 1)- in go- (foldr (\indices -> Map.insert (priority, Down (cost + 1), indices) Nothing) remaining unseen)+ in go partial+ (foldr (\indices -> Map.insert (failureEstimate, priority, Down (cost + 1), indices) Nothing) remaining unseen) (foldr Set.insert visited unseen) cache tried best @@ -319,6 +410,381 @@ cache' <- discoverVersions name cache pure ([(name, Map.insert name 0 indices) | not $ null $ searchChoices cache' Map.! name] <> neighbors, cache') +data DomainOption = DomainOption+ { optionVersion :: Maybe Version,+ optionUpdated :: Bool,+ optionSteps :: Int+ }++data ConstraintView = ConstraintView Bool Int VersionedList++data ConstraintProblem = ConstraintProblem+ { constraintDomains :: Map.Map PackageName (IntMap.IntMap DomainOption),+ constraintViews :: Map.Map (PackageName, Int) ConstraintView,+ constraintCache :: SearchCache+ }++inspectConstraint :: PlanEffects r => PackageName -> DomainOption -> SearchCache -> Sem r (ConstraintView, SearchCache)+inspectConstraint owner option cache = case optionVersion option of+ Nothing -> pure (ConstraintView False 0 [], cache)+ Just version -> do+ (parsed, loaded) <- loadDependencies owner version $ searchDependencies cache+ (existing, known) <- existingDependencies owner loaded+ compiler <- ask @Version+ let updated = optionUpdated option+ repository = not updated+ checkingCompiler = isJust $ cachedToolchain known+ previous = Map.lookup (compiler, owner, version) (cachedDependencies known) >>= either (const Nothing) Just+ activeRanges = case parsed of+ Left _ -> []+ Right parts -> tagDependencies parts+ ranges <- fmap catMaybes $ forM activeRanges $ \(src, dependency, range) ->+ if updated || checkingCompiler+ then pure $ if dependencyWasBroken previous known existing src dependency range then Nothing else Just (dependency, range)+ else if Set.member (toArchLinuxName owner) $ Map.findWithDefault Set.empty (toArchLinuxName dependency) (searchReversePackages cache)+ then do+ installed <- availableVersion known Map.empty dependency+ pure $ if maybe False (not . (`withinRange` range)) installed then Nothing else Just (dependency, range)+ else pure Nothing+ pure (ConstraintView updated (case parsed of Left _ | not repository -> 1; _ -> 0) ranges,+ cache {searchDependencies = known})++introduceConstraints :: PlanEffects r => Map.Map PackageName [Version] -> Set.Set PackageName -> ConstraintProblem -> Sem r ConstraintProblem+introduceConstraints requested = go+ where+ go pending problem = case Set.minView pending of+ Nothing -> pure problem+ Just (name, rest)+ | Map.member name $ constraintDomains problem -> go rest problem+ | fixedPackage (searchDependencies $ constraintCache problem) name -> go rest problem+ | otherwise -> do+ known <- discoverVersions name $ constraintCache problem+ let installed = Map.lookup name $ searchInstalled known+ candidates = searchChoices known Map.! name+ values = case Map.lookup name requested of+ Just releases -> IntMap.fromList [(index, DomainOption (Just version) True index) | (index, version) <- zip [0 ..] releases]+ Nothing -> IntMap.fromList $ (-1, DomainOption installed False 0) :+ [(index, DomainOption (Just version) True (index + 1)) | (index, version) <- zip [0 ..] candidates]+ added = problem {constraintDomains = Map.insert name values $ constraintDomains problem, constraintCache = known}+ withInstalled <- case IntMap.lookup (-1) values of+ Nothing -> pure added+ Just option -> do+ (view, checked) <- inspectConstraint name option known+ pure added {constraintViews = Map.insert (name, -1) view $ constraintViews added, constraintCache = checked}+ (owners, checked) <- if isJust $ cachedToolchain $ searchDependencies $ constraintCache withInstalled+ then pure ([], constraintCache withInstalled)+ else reverseOwners name values $ constraintCache withInstalled+ let direct = case Map.lookup (name, -1) $ constraintViews withInstalled of+ Just (ConstraintView _ _ ranges) | isJust $ cachedToolchain $ searchDependencies checked -> fst <$> ranges+ _ -> []+ go (Set.unions [rest, Set.fromList owners, Set.fromList direct]) withInstalled {constraintCache = checked}++ reverseOwners target values initial = foldM inspect ([], initial) $ Set.toList $+ Map.findWithDefault Set.empty (toArchLinuxName target) (searchReversePackages initial)+ where+ inspect (owners, cache) archOwner = do+ let owner = toHackageName archOwner+ found <- try @MyException $ currentVersion owner+ case found of+ Left _ -> pure (owners, cache)+ Right version -> do+ (parsed, loaded) <- loadDependencies owner version $ searchDependencies cache+ installed <- availableVersion loaded Map.empty target+ let ranges = case parsed of+ Left _ -> []+ Right parts -> [range | (_, dependency, range) <- tagDependencies parts, dependency == target,+ not $ maybe False (not . (`withinRange` range)) installed]+ broken = any (\option -> optionUpdated option && any (\range -> maybe True (not . (`withinRange` range)) $ optionVersion option) ranges) $ IntMap.elems values+ pure ([owner | broken] <> owners, cache {searchDependencies = loaded})++expandConstraints :: PlanEffects r => Map.Map PackageName [Version] -> [(PackageName, Int)] -> ConstraintProblem -> Sem r ConstraintProblem+expandConstraints requested selections initial = do+ let names = Set.fromList $ fst <$> selections+ candidates = [(name, value) | name <- Set.toList names,+ (value, option) <- IntMap.toList $ constraintDomains initial Map.! name,+ optionUpdated option, Map.notMember (name, value) $ constraintViews initial]+ (expanded, dependencies) <- foldM inspect (initial, Set.empty) candidates+ introduceConstraints requested dependencies expanded+ where+ inspect (problem, dependencies) key@(name, value) = do+ tracePlan $ "Expanding constraint metadata for " <> unPackageName name <> " " <>+ maybe "(missing)" prettyShow (optionVersion $ constraintDomains problem Map.! name IntMap.! value)+ (view@(ConstraintView _ _ ranges), known) <- inspectConstraint name (constraintDomains problem Map.! name IntMap.! value) $ constraintCache problem+ pure (problem {constraintViews = Map.insert key view $ constraintViews problem, constraintCache = known},+ Set.union dependencies $ Set.fromList $ fst <$> ranges)++constraintModel :: PlanEffects r => Int -> ConstraintProblem -> Sem r (Solver.Model PackageName)+constraintModel compilerCost problem = foldM addView initial $ Map.toList $ constraintViews problem+ where+ domains = constraintDomains problem+ known = searchDependencies $ constraintCache problem+ checkingCompiler = isJust $ cachedToolchain known+ initial = Solver.Model (0, compilerCost) (Map.map (IntMap.map $ \option -> (0, optionSteps option)) domains) Map.empty+ addCost (failures, steps) (otherFailures, otherSteps) = (failures + otherFailures, steps + otherSteps)+ addUnary owner value failures model = model+ {Solver.modelDomains = Map.adjust (IntMap.adjust (addCost (failures, 0)) value) owner $ Solver.modelDomains model}+ addView model ((owner, value), ConstraintView updated unchecked ranges) =+ foldM (addRange owner value updated) (addUnary owner value unchecked model) ranges+ addRange owner value updated model (dependency, range)+ | unknownCompilerTool known dependency = pure model+ | dependency == owner = pure $ addUnary owner value (failure updated $ domains Map.! owner IntMap.! value) model+ | fixedPackage known dependency = do+ actual <- availableVersion known Map.empty dependency+ pure $ addUnary owner value (failure updated $ DomainOption actual False 0) model+ | Just available <- Map.lookup dependency domains = do+ let key = if owner < dependency then (owner, dependency) else (dependency, owner)+ emptyTable = IntMap.map (const $ IntMap.map (const (0, 0)) $ domains Map.! snd key) $ domains Map.! fst key+ table = Map.findWithDefault emptyTable key $ Solver.modelEdges model+ costs = IntMap.map (\option -> (failure updated option, 0)) available+ combined = if owner < dependency+ then IntMap.adjust (IntMap.unionWith addCost costs) value table+ else IntMap.mapWithKey (\other -> IntMap.adjust (addCost $ costs IntMap.! other) value) table+ pure model {Solver.modelEdges = Map.insert key combined $ Solver.modelEdges model}+ | otherwise = pure model+ where+ failure active option = if (active || checkingCompiler || optionUpdated option)+ && maybe True (not . (`withinRange` range)) (optionVersion option) then 1 else 0++optimizePartial :: PlanEffects r => GHCReleases -> Map.Map PackageName [Version] -> SearchCache -> Int -> Maybe (Int, PlanResult) -> Sem r (Int, PlanResult)+optimizePartial releases requested initial tried best = do+ tracePlan "Optimizing finite package domains instead of enumerating update subsets..."+ (_, checked, final) <- foldM compiler (initial, tried, best) compilers+ case final of+ Just (_, result) -> pure (checked, result)+ Nothing -> error "constraint solver starts with an evaluated plan"+ where+ compilers = case Map.lookup "ghc" requested of+ Nothing -> [(Nothing, 0)]+ Just versions -> [(Just version, index) | (index, version) <- zip [0 ..] versions]+ compiler (cache, checked, previous) (release, cost)+ | Just (steps, result) <- previous, null (planProblems result), cost >= steps = pure (cache, checked, previous)+ | otherwise = do+ tracePlan $ "Considering " <> maybe "package updates" (\version -> "GHC " <> prettyShow version) release <>+ "; best score " <> show ((\(steps, result) -> (length $ planProblems result, steps)) <$> previous)+ dependencies <- case release of+ Nothing -> pure $ (searchDependencies cache) {cachedToolchain = Nothing}+ Just version -> selectToolchain releases (Map.singleton "ghc" version) $ searchDependencies cache+ extra <- ask @ExtraDB+ let names = Map.keysSet (Map.delete "ghc" requested) `Set.union` case cachedToolchain dependencies of+ Nothing -> Set.empty+ Just toolchain -> Set.fromList+ [toHackageName $ _name desc | desc <- Map.elems extra, isHaskellPackage $ _name desc,+ Set.notMember (_name desc) $ toolchainArchPackages toolchain, isJust $ simpleParsec @Version $ _version desc]+ problem = ConstraintProblem Map.empty Map.empty cache {searchDependencies = dependencies, searchRequiredRanges = Map.empty}+ introduced <- introduceConstraints requested names problem+ let cachedSelections = [(name, value) | isJust release, (name, values) <- Map.toList $ constraintDomains introduced,+ (value, option) <- IntMap.toList values, optionUpdated option,+ Just version <- [optionVersion option],+ Map.member (name, version) $ cachedDependencyConditions $ searchDependencies $ constraintCache introduced]+ expanded <- expandConstraints requested+ (cachedSelections <> [(name, value) | name <- Map.keys $ Map.delete "ghc" requested,+ value <- IntMap.keys $ constraintDomains introduced Map.! name]) introduced+ let limit = (\(steps, result) -> (length $ planProblems result, steps)) <$> previous+ (improved, searched, known) <- refine limit cost checked expanded+ case improved of+ Nothing -> do+ tracePlan $ "Pruned " <> maybe "package updates" (\version -> "GHC " <> prettyShow version) release <>+ ": no improvement below " <> show limit+ pure (known, searched, previous)+ Just (score, selected) -> do+ let selectedCompiler = maybe selected (\version -> Map.insert "ghc" version selected) release+ (reverseChecks, loaded) <- case release of+ Just _ -> pure ([], searchDependencies known)+ Nothing -> externalChecks (Map.keys selectedCompiler) (searchReversePackages known) $ searchDependencies known+ (problems, warnings, finalDependencies) <- checkSet (searchInstalled known) selectedCompiler reverseChecks loaded+ unless (fst score == length problems) $ error $ "constraint solver blocker count differs from checked plan: " <> show score <> " versus " <> show (length problems)+ let result = PlanResult+ { planInstalled = Map.restrictKeys (searchInstalled known) $ Map.keysSet selectedCompiler,+ planVersions = selectedCompiler,+ planRequested = Map.keysSet requested,+ planProblems = problems,+ planWarnings = warnings,+ plansTried = searched,+ planToolchain = cachedToolchain finalDependencies,+ planRevisionNotes = [],+ planSearchNotes = []+ }+ tracePlan $ "Verified constraint optimum: " <> show (length problems) <> " blockers, " <> show (snd score) <> " release steps"+ pure (known {searchDependencies = finalDependencies}, searched, Just (snd score, result))++ refine limit cost checked problem = do+ model <- constraintModel cost problem+ tracePlan $ "Constraint model: " <> show (Map.size $ Solver.modelDomains model) <> " packages, " <>+ show (Map.size $ Solver.modelEdges model) <> " dependency edges"+ (improved, nodes) <- Solver.optimizeBelow tracePlan limit model+ case improved of+ Nothing -> pure (Nothing, checked, constraintCache problem)+ Just (score, assignment) -> do+ tracePlan $ "Constraint lower bound " <> show score <> " after " <> show nodes <> " branches"+ let unknown = [(name, value) | (name, value) <- Map.toList assignment,+ optionUpdated $ constraintDomains problem Map.! name IntMap.! value,+ Map.notMember (name, value) $ constraintViews problem]+ if null unknown+ then pure (Just (score, Map.mapMaybeWithKey+ (\name value -> let option = constraintDomains problem Map.! name IntMap.! value+ in if optionUpdated option then optionVersion option else Nothing) assignment), checked + 1, constraintCache problem)+ else do+ expanded <- expandConstraints requested unknown problem+ refine limit cost (checked + 1) expanded++jointFailures :: [([PlanProblem], RepairBound)] -> Int+jointFailures bounds = case Set.toList compilers of+ [] -> 0+ available -> minimum [sum [Map.findWithDefault 0 compiler failures | (_, RepairBound _ _ failures) <- bounds] | compiler <- available]+ where+ compilers = Set.unions [Map.keysSet failures | (_, RepairBound _ _ failures) <- bounds]++remainingCost :: Set.Set PackageName -> Int -> [[(Set.Set PackageName, Int)]] -> Int+remainingCost movable allowance repairs = sum $ drop allowance $ sortOn Down costs+ where+ branchKey (names, cost) = (Set.size names, Down cost, Set.toList names)+ clauses = if allowance == 0 then concat repairs else+ [first | alternatives <- repairs, first : _ <- [sortOn branchKey alternatives]]+ actionable = [(names', cost) | (names, cost) <- clauses, let names' = Set.intersection movable names, not $ Set.null names']+ (_, costs) = foldl' count (Set.empty, []) $ sortOn branchKey actionable+ count (used, totals) (names, cost)+ | Set.null $ Set.intersection used names = (Set.union used names, cost : totals)+ | otherwise = (used, totals)++repairBounds :: PlanEffects r => GHCReleases -> Map.Map PackageName Int -> Map.Map PackageName Version -> [PlanProblem] -> SearchCache -> Sem r ([([PlanProblem], RepairBound)], SearchCache)+repairBounds releases indices selected problems initial = foldM collect (unchecked, initial) $ Map.toList grouped+ where+ groupKey problem = case problem of+ DependencyProblem owner dependency _ _ -> Just (owner, dependency)+ ReverseDependencyProblem owner dependency _ _ _ -> Just (toHackageName owner, dependency)+ _ -> Nothing+ grouped = Map.fromListWith (<>) [(key, [problem]) | problem <- problems, Just key <- [groupKey problem]]+ unchecked = [([problem], RepairBound 0 [(Set.fromList $ problemTargets problem, 1)] Map.empty) | problem <- problems, Nothing <- [groupKey problem]]++ collect (bounds, cache) ((owner, dependency), related) = do+ let key = (Map.lookup "ghc" indices, owner, Map.lookup owner indices, dependency, Map.lookup dependency indices)+ case Map.lookup key $ searchRepairBounds cache of+ Just bound -> pure ((related, bound) : bounds, cache)+ Nothing -> do+ tracePlan $ "Analyzing repairs for " <> unPackageName owner <> " -> " <> unPackageName dependency+ (bound, checked) <- check owner dependency (length related) cache+ pure ((related, bound) : bounds, checked {searchRepairBounds = Map.insert key bound $ searchRepairBounds checked})++ check owner dependency failures cache = do+ (owners, known) <- domain owner cache+ (dependencies, known') <- domain dependency known+ installedCompiler <- ask @Version+ let compilers = case Map.lookup "ghc" indices of+ Nothing -> [(installedCompiler, 0)]+ Just index -> [(compiler, offset) | (offset, compiler) <- zip [0 :: Int ..] $ drop index $ searchChoices cache Map.! "ghc"]+ ((minimumFailures, mandatory, alternatives, minimumCost, compilerFailures), checked) <- foldM+ (compilerBounds owner dependency failures owners dependencies)+ ((failures, Nothing, Set.empty, maxBound, Map.empty), known') compilers+ let restored = checked {searchDependencies = (searchDependencies checked)+ { cachedToolchain = cachedToolchain $ searchDependencies cache }}+ repairs = case mandatory of+ Nothing -> []+ Just required+ | Map.null required -> [(alternatives, minimumCost)]+ | otherwise -> [(Set.singleton name, cost) | (name, cost) <- Map.toList required]+ pure (RepairBound minimumFailures repairs compilerFailures, restored)++ domain name cache+ | isGHCLibs name || unknownCompilerTool (searchDependencies cache) name = pure ([], cache)+ | otherwise = do+ known <- discoverVersions name cache+ let versions = Map.findWithDefault [] name $ searchChoices known+ available = case Map.lookup name indices of+ Just index -> [(Just version, offset) | (offset, version) <- zip [0 :: Int ..] $ drop index versions]+ Nothing -> (Map.lookup name $ searchInstalled known, 0) : [(Just version, cost) | (cost, version) <- zip [1 :: Int ..] versions]+ pure (available, known)++ compilerBounds owner dependency failures owners dependencies (summary, cache) (compiler, compilerCost) = do+ toolchain <- if Map.member "ghc" selected+ then selectToolchain releases (Map.singleton "ghc" compiler) (searchDependencies cache)+ else pure $ searchDependencies cache+ let known = cache {searchDependencies = toolchain}+ available <- if fixedPackage toolchain dependency+ then (\actual -> [(actual, 0)]) <$> availableVersion toolchain Map.empty dependency+ else pure dependencies+ foldM (candidateBounds owner dependency failures compiler compilerCost available) (summary, known) owners++ candidateBounds owner dependency failures targetCompiler compilerCost available (summary, cache) (candidate, ownerCost) = do+ let toolchain = searchDependencies cache+ (ranges, known) <- if fixedPackage toolchain owner || unknownCompilerTool toolchain dependency+ then pure ([], toolchain)+ else case candidate of+ Nothing -> pure ([], toolchain)+ Just version -> do+ (parsed, loaded) <- loadDependencies owner version toolchain+ (existing, loaded') <- existingDependencies owner loaded+ compiler <- ask @Version+ let previous = Map.lookup (compiler, owner, version) (cachedDependencies loaded') >>= either (const Nothing) Just+ required = case parsed of+ Left _ -> []+ Right parts -> [range | (src, name, range) <- tagDependencies parts, name == dependency,+ not $ dependencyWasBroken previous loaded' existing src name range]+ pure (required, loaded')+ let summarize (minimumFailures, mandatory, alternatives, minimumCost, compilerFailures) (actual, dependencyCost) =+ let count = length [range | range <- ranges, maybe True (not . (`withinRange` range)) actual]+ changed = Map.fromListWith max $ [(owner, ownerCost) | ownerCost > 0] <>+ [(dependency, dependencyCost) | dependencyCost > 0] <> [("ghc", compilerCost) | compilerCost > 0]+ perCompiler = Map.insertWith min targetCompiler count compilerFailures+ in if count < failures+ then (min minimumFailures count, Just $ maybe changed (Map.intersectionWith min changed) mandatory,+ Set.union (Map.keysSet changed) alternatives, min minimumCost $ sum $ Map.elems changed, perCompiler)+ else (minimumFailures, mandatory, alternatives, minimumCost, perCompiler)+ pure (foldl' summarize summary available, cache {searchDependencies = known})++unavoidableFailures :: PlanEffects r => GHCReleases -> Map.Map PackageName Int -> SearchCache -> Sem r (Int, SearchCache)+unavoidableFailures releases indices initial = foldM collect (0, initial) $ Map.toList $ Map.delete "ghc" indices+ where+ collect (total, cache) (owner, index) = do+ let key = (Map.lookup "ghc" indices, owner, index)+ case Map.lookup key $ searchUnavoidableFailures cache of+ Just count -> pure (total + count, cache)+ Nothing -> do+ tracePlan $ "Checking unavoidable future failures of " <> unPackageName owner+ installedCompiler <- ask @Version+ let compilers = case Map.lookup "ghc" indices of+ Nothing -> [installedCompiler]+ Just compilerIndex -> drop compilerIndex $ searchChoices cache Map.! "ghc"+ candidates = drop index $ searchChoices cache Map.! owner+ (counts, known) <- foldM (compilerFailures owner candidates) ([], cache) compilers+ let count = minimum counts+ restored = known {searchDependencies = (searchDependencies known)+ {cachedToolchain = cachedToolchain $ searchDependencies cache}}+ pure (total + count, restored {searchUnavoidableFailures = Map.insert key count $ searchUnavoidableFailures restored})++ compilerFailures owner candidates (counts, cache) compiler = do+ toolchain <- if Map.member "ghc" indices+ then selectToolchain releases (Map.singleton "ghc" compiler) (searchDependencies cache)+ else pure $ searchDependencies cache+ if fixedPackage toolchain owner+ then pure (0 : counts, cache)+ else foldM (candidateFailures owner) (counts, cache {searchDependencies = toolchain}) candidates++ candidateFailures owner (counts, cache) candidate = do+ (parsed, loaded) <- loadDependencies owner candidate $ searchDependencies cache+ (existing, known) <- existingDependencies owner loaded+ compiler <- ask @Version+ let previous = Map.lookup (compiler, owner, candidate) (cachedDependencies known) >>= either (const Nothing) Just+ grouped = case parsed of+ Left _ -> Map.empty+ Right parts -> Map.fromListWith (<>)+ [(dependency, [range]) | (src, dependency, range) <- tagDependencies parts,+ not $ dependencyWasBroken previous known existing src dependency range]+ (count, checked) <- foldM dependencyFailures (0, cache {searchDependencies = known}) $ Map.toList grouped+ pure (count : counts, checked)++ dependencyFailures (total, cache) (dependency, ranges)+ | unknownCompilerTool (searchDependencies cache) dependency = pure (total, cache)+ | fixedPackage (searchDependencies cache) dependency = do+ actual <- availableVersion (searchDependencies cache) Map.empty dependency+ pure (total + failures actual, cache)+ | otherwise = do+ known <- discoverVersions dependency cache+ let available = Map.lookup dependency (searchInstalled known) :+ (Just <$> Map.findWithDefault [] dependency (searchChoices known))+ pure (total + minimum (failures <$> available), known)+ where+ failures actual = length [range | range <- ranges, maybe True (not . (`withinRange` range)) actual]+ -- Disjoint repair choices each require at least one separate release step. -- Shared dependencies are deliberately counted only once, so the estimate -- cannot rule out a smaller update set. Unrepairable constraints contribute@@ -401,23 +867,32 @@ -- constrain the whole search. Their ranges are unions across releases and -- intersections across targets. These bounds prevent impossible later releases -- from weakening the estimate for an otherwise mandatory update.-requestedRanges :: PlanEffects r => Map.Map PackageName [Version] -> DependencyCache -> Sem r (Map.Map PackageName VersionRange, DependencyCache)-requestedRanges choices cache = foldM collect (Map.empty, cache) (Map.toList choices)+requestedRanges :: PlanEffects r => Map.Map PackageName [Version] -> DependencyCache -> Sem r (Map.Map PackageName VersionRange, RangeOrigins, DependencyCache)+requestedRanges choices cache = foldM collect (Map.empty, Map.empty, cache) (Map.toList choices) where- collect (required, known) (name, releases) = do+ collect (required, origins, known) (name, releases) = do+ tracePlan $ "Required ranges for " <> unPackageName name <> ": " <> show (length releases) <> " releases" (existing, known') <- existingDependencies name known- (common, known'') <- foldM- (\(previous, parsed) release -> do+ (common, sources, known'') <- foldM+ (\(previous, previousSources, parsed) release -> do (result, parsed') <- loadDependencies name release parsed- let bounds = case result of- Left _ -> Map.empty- Right parts -> Map.fromListWith intersectVersionRanges $ requiredDependencies existing parts- pure (Just $ maybe bounds (Map.intersectionWith unionVersionRanges bounds) previous, parsed'))- (Nothing, known')+ let dependencies = case result of+ Left _ -> []+ Right parts -> [(src, dependency, range) | (src, dependency, range) <- tagDependencies parts,+ not $ existingDependencyFailure existing src dependency range]+ bounds = Map.fromListWith intersectVersionRanges [(dependency, range) | (_, dependency, range) <- dependencies]+ dependencySources = Map.fromListWith Set.union [(dependency, Set.singleton src) | (src, dependency, _) <- dependencies]+ pure (Just $ maybe bounds (Map.intersectionWith unionVersionRanges bounds) previous,+ Map.unionWith Set.union previousSources dependencySources, parsed'))+ (Nothing, Map.empty, known') releases let own = foldr (unionVersionRanges . thisVersion) noVersion releases- bounds = Map.insertWith intersectVersionRanges name own (maybe Map.empty id common)- pure (Map.map simplifyVersionRange $ Map.unionWith intersectVersionRanges required bounds, known'')+ dependencies = Map.map simplifyVersionRange $ fromMaybe Map.empty common+ bounds = Map.insertWith intersectVersionRanges name own dependencies+ reasons = Map.mapWithKey (\dependency range -> Map.singleton name $+ DependencyOrigin releases (Set.toList $ Map.findWithDefault Set.empty dependency sources) range) dependencies+ pure (Map.map simplifyVersionRange $ Map.unionWith intersectVersionRanges required bounds,+ Map.unionWith Map.union reasons origins, known'') -- Propagate only dependencies required by every remaining release. A package -- that can stay installed does not need its existing dependencies revalidated.@@ -428,6 +903,7 @@ go pending examined cache = case Set.minView pending of Nothing -> pure (Nothing, cache) Just (name, rest) -> do+ tracePlan $ "Propagating " <> unPackageName name <> "; " <> show (Set.size rest) <> " packages pending" let required = searchRequiredRanges cache Map.! name current <- case Map.lookup name (searchInstalled cache) of Just version -> pure $ Just version@@ -457,9 +933,10 @@ else if Map.lookup name examined == Just eligible then go rest examined known' else do- (implied, dependencies) <- requestedRanges (Map.singleton name eligible) (searchDependencies known')+ (implied, origins, dependencies) <- requestedRanges (Map.singleton name eligible) (searchDependencies known') let combined = Map.map simplifyVersionRange $ Map.unionWith intersectVersionRanges (searchRequiredRanges known') implied- forward = known' {searchDependencies = dependencies, searchRequiredRanges = combined}+ forward = known' {searchDependencies = dependencies, searchRequiredRanges = combined,+ searchRangeOrigins = Map.unionWith Map.union origins (searchRangeOrigins known')} expanded <- if includeReverse then forceReverseUpdates name eligible current forward else pure forward let finalRanges = searchRequiredRanges expanded changed = Map.keysSet $ Map.filterWithKey@@ -513,7 +990,9 @@ then pure checked else pure checked { searchRequiredRanges = Map.insertWith (\a b -> simplifyVersionRange $ intersectVersionRanges a b) owner- (foldr (unionVersionRanges . thisVersion) noVersion releases) (searchRequiredRanges checked)+ (foldr (unionVersionRanges . thisVersion) noVersion releases) (searchRequiredRanges checked),+ searchRangeOrigins = Map.insertWith Map.union owner (Map.singleton target $ ReverseUpdateOrigin eligible)+ (searchRangeOrigins checked) } -- Adding a package starts at its next preferred release and costs one step,@@ -532,6 +1011,7 @@ Right releases -> pure releases Left (PkgNotFound _) -> pure [] Left err -> throw err+ tracePlan $ "Discovered " <> show (length available) <> " newer releases of " <> unPackageName name pure cache { searchInstalled = maybe id (Map.insert name) installed (searchInstalled cache), searchChoices = Map.insert name available (searchChoices cache)@@ -598,19 +1078,28 @@ (existing, known'') <- existingDependencies name known' compiler <- ask @Version let previous = Map.lookup (compiler, name, version) (cachedDependencies known'') >>= either (const Nothing) Just- problems <- case dependencies of- Left err -> pure [if repository then (True, UncheckedReverseDependency (toArchLinuxName name) ["ghc"] err) else (False, UncheckedCandidate name version err)]- Right parts -> concat <$> forM (tagDependencies parts) (\(src, dependency, range) -> do- actual <- availableVersion known'' selected dependency- let problem = case (repository, actual) of- (True, Just candidate) -> ReverseDependencyProblem (toArchLinuxName name) dependency src range candidate- _ -> DependencyProblem name dependency range actual- pure $ if unknownCompilerTool known'' dependency- then [(True, UncheckedCompilerTool name dependency range)]- else [(dependencyWasBroken previous known'' existing src dependency range, problem) | maybe True (not . (`withinRange` range)) actual])- let (warnings, failures) = partition fst problems- (others, otherWarnings, finalCache) <- checkCandidates repository rest known''- pure ((snd <$> failures) <> others, (snd <$> warnings) <> otherWarnings, finalCache)+ proposedCompiler = maybe compiler toolchainVersion $ cachedToolchain known''+ targets = either (const Set.empty) (Set.fromList . fmap (\(_, dependency, _) -> dependency) . tagDependencies) dependencies+ key = (proposedCompiler, name, version, repository, Map.restrictKeys selected targets)+ (failures, warnings, checked) <- case Map.lookup key $ cachedCandidateChecks known'' of+ Just (failures, warnings) -> pure (failures, warnings, known'')+ Nothing -> do+ problems <- case dependencies of+ Left err -> pure [if repository then (True, UncheckedReverseDependency (toArchLinuxName name) ["ghc"] err) else (False, UncheckedCandidate name version err)]+ Right parts -> concat <$> forM (tagDependencies parts) (\(src, dependency, range) -> do+ actual <- availableVersion known'' selected dependency+ let problem = case (repository, actual) of+ (True, Just candidate) -> ReverseDependencyProblem (toArchLinuxName name) dependency src range candidate+ _ -> DependencyProblem name dependency range actual+ pure $ if unknownCompilerTool known'' dependency+ then [(True, UncheckedCompilerTool name dependency range)]+ else [(dependencyWasBroken previous known'' existing src dependency range, problem) | maybe True (not . (`withinRange` range)) actual])+ let (old, introduced) = partition fst problems+ failures = snd <$> introduced+ warnings = snd <$> old+ pure (failures, warnings, known'' {cachedCandidateChecks = Map.insert key (failures, warnings) $ cachedCandidateChecks known''})+ (others, otherWarnings, finalCache) <- checkCandidates repository rest checked+ pure (failures <> others, warnings <> otherWarnings, finalCache) loadDependencies :: PlanEffects r =>@@ -628,12 +1117,36 @@ loadDependenciesWith :: PlanEffects r => Version -> PackageName -> Version -> DependencyCache -> Sem r (Either MyException (VersionedList, VersionedList), DependencyCache) loadDependenciesWith compiler name version known = case Map.lookup (compiler, name, version) (cachedDependencies known) of Just cached -> pure (cached, known)- Nothing -> do- dependencies <- try @MyException $ do- cabal <- getCabalIncludingDeprecated name version- local @Version (const compiler) $ localDependencyRecord $ directDependencies cabal- pure (dependencies, known {cachedDependencies = Map.insert (compiler, name, version) dependencies (cachedDependencies known)})+ Nothing -> case Map.lookup (name, version) (cachedDependencyConditions known) >>= \conditions ->+ Map.lookup (name, version, fmap (withinRange compiler) conditions) (cachedDependencyVariants known) of+ Just cached -> pure (cached, known {cachedDependencies = Map.insert (compiler, name, version) cached (cachedDependencies known)})+ Nothing -> do+ tracePlan $ "Reading " <> unPackageName name <> " " <> prettyShow version <> " metadata for GHC " <> prettyShow compiler+ parsed <- try @MyException $ getCabalIncludingDeprecated name version+ let conditions = either (const []) compilerConditions parsed+ dependencies <- case parsed of+ Left err -> pure $ Left err+ Right cabal -> try @MyException $ local @Version (const compiler) $ localDependencyRecord $ directDependencies cabal+ pure (dependencies, known+ { cachedDependencies = Map.insert (compiler, name, version) dependencies (cachedDependencies known),+ cachedDependencyConditions = Map.insert (name, version) conditions (cachedDependencyConditions known),+ cachedDependencyVariants = Map.insert (name, version, fmap (withinRange compiler) conditions) dependencies (cachedDependencyVariants known)+ }) +compilerConditions :: GenericPackageDescription -> [VersionRange]+compilerConditions cabal = maybe [] compilerRanges (condLibrary cabal)+ <> concatMap (compilerRanges . snd) (condSubLibraries cabal)+ <> concatMap (compilerRanges . snd) (condExecutables cabal)+ <> concatMap (compilerRanges . snd) (condTestSuites cabal)++compilerRanges :: CondTree ConfVar constraints component -> [VersionRange]+compilerRanges tree = concat+ [ [range | Impl GHC range <- toList $ condBranchCondition branch]+ <> compilerRanges (condBranchIfTrue branch)+ <> maybe [] compilerRanges (condBranchIfFalse branch)+ | branch <- condTreeComponents tree+ ]+ tagDependencies :: (VersionedList, VersionedList) -> [(DepSrc, PackageName, VersionRange)] tagDependencies (depends, makeDepends) = [(src, name, range) | (src, deps) <- [(Run, depends), (Make, makeDepends)], (name, range) <- deps]@@ -825,7 +1338,7 @@ <> [line <> vsep planSearchNotes | not $ null planSearchNotes] <> [line <> vsep planRevisionNotes | not $ null planRevisionNotes] <> [ line <> "Commit message:" <> line <> pretty (intercalate ", " updates)- <> line <> line <> ("genrebuild -H" <> (if isJust planToolchain then " --ignore ghc-static" else mempty)+ <> line <> line <> ("genrebuild -H" <+> hsep [if name == "ghc" then "ghc" else pretty $ unArchLinuxName $ toArchLinuxName name | name <- Map.keys planVersions]) | not $ null updates ]@@ -843,6 +1356,59 @@ unchecked (UncheckedReverseDependency _ _ _) = True unchecked (UncheckedCompilerTool _ _ _) = True unchecked _ = False++prettySearchConflict :: Set.Set PackageName -> SearchCache -> PlanProblem -> Doc AnsiStyle+prettySearchConflict requested cache problem = case problem of+ UnavailableDependency dependency _ _ -> vsep $ prettyProblem problem :+ [ indent 2 $ vsep $ prettyOrigin dependency owner origin :+ [ "Required through:" <+> prettyPath (path <> [dependency])+ | let path = requiredThrough owner, not $ null path+ ]+ | (owner, origin) <- Map.toList $ contributingOrigins dependency+ ]+ _ -> prettyProblem problem+ where+ origins = searchRangeOrigins cache+ contributingOrigins dependency = foldl' removeRedundant available $ Map.keys available+ where+ available = Map.findWithDefault Map.empty dependency origins+ bounds reasons = asVersionIntervals $ foldr intersectVersionRanges anyVersion+ [range | DependencyOrigin _ _ range <- Map.elems reasons]+ removeRedundant reasons owner = case Map.lookup owner reasons of+ Just (DependencyOrigin _ _ _)+ | Map.size reasons > 1,+ let remaining = Map.delete owner reasons,+ bounds remaining == bounds reasons -> Map.delete owner reasons+ _ -> reasons+ prettyOwner owner [release] = viaPretty owner <+> viaPretty release+ prettyOwner owner releases = viaPretty owner <+> parens (pretty (length releases) <+> "eligible releases")+ prettyOrigin dependency owner (DependencyOrigin releases sources range) =+ prettyOwner owner releases <+> hcat (punctuate "/" $ pretty <$> sources)+ <+> "requires" <+> viaPretty dependency <+> viaPretty range+ prettyOrigin dependency owner (ReverseUpdateOrigin releases) =+ prettyOwner owner releases <+> "forces" <+> viaPretty dependency <+> "to update (reverse dependency)"+ requiredThrough owner = go Set.empty $ Map.singleton owner [owner]+ where+ go visited pending+ | Just (_, path) <- Map.lookupMin $ Map.restrictKeys pending requested = path+ | Map.null pending = []+ | otherwise =+ let seen = Set.union visited $ Map.keysSet pending+ next = Map.fromList+ [ (parent, parent : path)+ | (dependency, path) <- Map.toList pending,+ parent <- Map.keys $ Map.findWithDefault Map.empty dependency origins,+ Set.notMember parent seen+ ]+ in go seen next+ prettyPath [] = mempty+ prettyPath (first : rest) = foldl' append (viaPretty first) $ zip (first : rest) rest+ where+ append path (parent, dependency) = path <+> arrow <+> viaPretty dependency+ where+ arrow = case Map.lookup dependency origins >>= Map.lookup parent of+ Just (ReverseUpdateOrigin _) -> "-[reverse dependency]->"+ _ -> "->" prettyProblem :: PlanProblem -> Doc AnsiStyle prettyProblem = \case
plan/Plan/Args.hs view
@@ -11,6 +11,7 @@ optExtraDB :: ExtraDBOptions, optHackage :: HackageDBOptions, optSolve :: Bool,+ optDebug :: Bool, optTargets :: [(PackageName, Maybe Version)] } @@ -21,10 +22,11 @@ <*> extraDBOptionsParser <*> hackageDBOptionsParser <*> switch (long "solve" <> help "Expand to blocking dependencies and reverse dependencies, minimizing release steps; supplied versions are minimums")+ <*> switch (long "debug" <> help "Show solver progress and metadata checks on stderr") <*> some (strArgument (metavar "TARGET [VERSION]...")) where- makeOptions flags extra hackage solve targets =- Options flags extra hackage solve <$> parsePackageTargets targets+ makeOptions flags extra hackage solve debug targets =+ Options flags extra hackage solve debug <$> parsePackageTargets targets runArgsParser :: IO Options runArgsParser = do
+ plan/Plan/Solver.hs view
@@ -0,0 +1,212 @@+module Plan.Solver (Score, Model (..), optimize, optimizeBelow) where++import Control.Applicative ((<|>))+import Control.Monad (foldM)+import qualified Data.IntMap.Strict as IntMap+import Data.List (foldl', sortOn)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Data.Ord (Down (..))+import qualified Data.Set as Set++type Score = (Int, Int)+type Table = IntMap.IntMap (IntMap.IntMap Score)++data Model key = Model+ { modelConstant :: Score,+ modelDomains :: Map.Map key (IntMap.IntMap Score),+ modelEdges :: Map.Map (key, key) Table+ }++data Elimination key+ = Fixed key Int+ | Leaf key key (IntMap.IntMap Int)++add :: Score -> Score -> Score+add (failures, steps) (otherFailures, otherSteps) = (failures + otherFailures, steps + otherSteps)++subtractScore :: Score -> Score -> Score+subtractScore (failures, steps) (otherFailures, otherSteps) = (failures - otherFailures, steps - otherSteps)++entry :: Table -> Int -> Int -> Score+entry table left right = table IntMap.! left IntMap.! right++evaluate :: Ord key => Model key -> Map.Map key Int -> Score+evaluate model assignment = foldl' add (modelConstant model) $+ [values IntMap.! (assignment Map.! name) | (name, values) <- Map.toList $ modelDomains model] <>+ [entry table (assignment Map.! left) (assignment Map.! right) | ((left, right), table) <- Map.toList $ modelEdges model]++restore :: Ord key => [Elimination key] -> Map.Map key Int -> Map.Map key Int+restore eliminated assignment = foldl' insert assignment eliminated+ where+ insert known (Fixed name value) = Map.insert name value known+ insert known (Leaf name neighbor choices) = Map.insert name (choices IntMap.! (known Map.! neighbor)) known++restrictTables :: Ord key => Model key -> Model key+restrictTables model = model {modelEdges = Map.mapWithKey restrict $ modelEdges model}+ where+ restrict (left, right) table =+ IntMap.map (\row -> IntMap.restrictKeys row $ IntMap.keysSet $ modelDomains model Map.! right) $+ IntMap.restrictKeys table $ IntMap.keysSet $ modelDomains model Map.! left++project :: Ord key => Model key -> Model key+project initial = normalize $ foldl' shift initial $ Map.keys $ modelEdges initial+ where+ shift model key@(left, right) =+ let table = modelEdges model Map.! key+ rows = IntMap.map (minimum . IntMap.elems) table+ reduced = IntMap.mapWithKey (\value -> IntMap.map (`subtractScore` (rows IntMap.! value))) table+ columns = IntMap.fromList+ [(value, minimum [row IntMap.! value | row <- IntMap.elems reduced])+ | value <- IntMap.keys $ modelDomains model Map.! right]+ finalTable = IntMap.map (IntMap.mapWithKey (\value cost -> subtractScore cost $ columns IntMap.! value)) reduced+ domains = Map.adjust (IntMap.unionWith add rows) left $ Map.adjust (IntMap.unionWith add columns) right $ modelDomains model+ in model {modelDomains = domains, modelEdges = Map.insert key finalTable $ modelEdges model}+ normalize model =+ let minima = Map.map (minimum . IntMap.elems) $ modelDomains model+ in model+ { modelConstant = foldl' add (modelConstant model) $ Map.elems minima,+ modelDomains = Map.mapWithKey (\name -> IntMap.map (`subtractScore` (minima Map.! name))) $ modelDomains model,+ modelEdges = Map.filter (any (/= (0, 0)) . concatMap IntMap.elems . IntMap.elems) $ modelEdges model+ }++neighbors :: Ord key => Model key -> Map.Map key [key]+neighbors model = Map.fromListWith (<>) $+ concat [[(left, [right]), (right, [left])] | (left, right) <- Map.keys $ modelEdges model]++equivalentDomains :: Ord key => Model key -> Map.Map key (IntMap.IntMap Score)+equivalentDomains model = Map.mapWithKey reduce $ modelDomains model+ where+ adjacent = neighbors model+ reduce name values = case Map.findWithDefault [] name adjacent of+ [] -> values+ related ->+ let signature value = concat+ [ [if name < neighbor then entry table value other else entry table other value+ | other <- IntMap.keys $ modelDomains model Map.! neighbor]+ | neighbor <- related,+ let key = if name < neighbor then (name, neighbor) else (neighbor, name),+ let table = modelEdges model Map.! key+ ]+ representatives = Map.fromListWith min+ [(signature value, (cost, value)) | (value, cost) <- IntMap.toList values]+ in IntMap.fromList [(value, cost) | (cost, value) <- Map.elems representatives]++fixValue :: Ord key => key -> Int -> Model key -> Model key+fixValue name value model = foldl' fixEdge without $ Map.toList $ modelEdges model+ where+ without = model+ { modelConstant = add (modelConstant model) $ modelDomains model Map.! name IntMap.! value,+ modelDomains = Map.delete name $ modelDomains model,+ modelEdges = Map.filterWithKey (\(left, right) _ -> left /= name && right /= name) $ modelEdges model+ }+ fixEdge known ((left, right), table)+ | left == name = known {modelDomains = Map.adjust (IntMap.unionWith add $ table IntMap.! value) right $ modelDomains known}+ | right == name = known {modelDomains = Map.adjust (IntMap.unionWith add $ IntMap.map (IntMap.! value) table) left $ modelDomains known}+ | otherwise = known++eliminateLeaf :: Ord key => key -> key -> Model key -> (Model key, Elimination key)+eliminateLeaf name neighbor model =+ let values = modelDomains model Map.! name+ key = if name < neighbor then (name, neighbor) else (neighbor, name)+ table = modelEdges model Map.! key+ cost own other = if name < neighbor then entry table own other else entry table other own+ choices = IntMap.mapWithKey+ (\other _ -> minimum [(add unary $ cost own other, own) | (own, unary) <- IntMap.toList values])+ (modelDomains model Map.! neighbor)+ reduced = model+ { modelDomains = Map.adjust (IntMap.unionWith add $ fst <$> choices) neighbor $ Map.delete name $ modelDomains model,+ modelEdges = Map.delete key $ modelEdges model+ }+ in (reduced, Leaf name neighbor $ snd <$> choices)++simplify :: Ord key => Maybe Score -> Model key -> Maybe (Model key, [Elimination key])+simplify cutoff = go []+ where+ go eliminated initial =+ let model = project $ restrictTables initial+ adjacent = neighbors model+ independent = [(name, values) | (name, values) <- Map.toList $ modelDomains model,+ IntMap.size values == 1 || Map.notMember name adjacent]+ leaves = [(name, neighbor) | (name, [neighbor]) <- Map.toList adjacent]+ permitted = Map.map (IntMap.filter (\cost -> maybe True (add (modelConstant model) cost <) cutoff)) $ modelDomains model+ allowed = equivalentDomains model {modelDomains = permitted}+ in if maybe False (modelConstant model >=) cutoff || any IntMap.null (Map.elems allowed)+ then Nothing+ else if Map.map IntMap.size allowed /= Map.map IntMap.size (modelDomains model)+ then go eliminated model {modelDomains = allowed}+ else case independent of+ _ : _ ->+ let fixed = [(name, snd $ minimum [(cost, candidate) | (candidate, cost) <- IntMap.toList values])+ | (name, values) <- independent]+ reduced = foldl' (\known (name, value) -> fixValue name value known) model fixed+ in go (reverse [Fixed name value | (name, value) <- fixed] <> eliminated) reduced+ [] -> case leaves of+ (name, neighbor) : _ ->+ let (reduced, removed) = eliminateLeaf name neighbor model+ in go (removed : eliminated) reduced+ [] -> Just (model, eliminated)++components :: Ord key => Model key -> [Set.Set key]+components model = go (Map.keysSet $ modelDomains model) []+ where+ adjacent = neighbors model+ connected pending found = case Set.minView pending of+ Nothing -> found+ Just (name, rest)+ | Set.member name found -> connected rest found+ | otherwise -> connected (Set.union rest $ Set.fromList $ Map.findWithDefault [] name adjacent) $ Set.insert name found+ go pending found = case Set.minView pending of+ Nothing -> found+ Just (name, _) ->+ let group = connected (Set.singleton name) Set.empty+ in go (Set.difference pending group) (group : found)++optimize :: (Monad monad, Ord key, Show key) => (String -> monad ()) -> Model key -> monad (Score, Map.Map key Int, Int)+optimize debug original = do+ (result, tried) <- optimizeBelow debug Nothing original+ case result of+ Just (score, assignment) -> pure (score, assignment, tried)+ Nothing -> error "unbounded constraint optimization always has an assignment"++optimizeBelow :: (Monad monad, Ord key, Show key) => (String -> monad ()) -> Maybe Score -> Model key -> monad (Maybe (Score, Map.Map key Int), Int)+optimizeBelow debug upperBound original = do+ let initial = Map.map (fst . IntMap.findMin) $ modelDomains original+ initialScore = evaluate original initial+ limit = Just $ maybe initialScore (min initialScore) upperBound+ fallback = if maybe True (initialScore <) upperBound then Just (initialScore, initial) else Nothing+ (improved, tried) <- search limit original+ pure (improved <|> fallback, tried)+ where+ search cutoff initial = case simplify cutoff initial of+ Nothing -> pure (Nothing, 1)+ Just (model, eliminated)+ | Map.null $ modelDomains model -> pure (Just (modelConstant model, restore eliminated Map.empty), 1)+ | groups@(_ : _ : _) <- components model -> do+ (result, tried) <- foldM (component model cutoff) (Just (modelConstant model, Map.empty), 1) groups+ pure ((\(score, assignment) -> (score, restore eliminated assignment)) <$> result, tried)+ | otherwise -> do+ let adjacent = neighbors model+ (_, _, name) = minimum+ [(Down $ length $ Map.findWithDefault [] candidate adjacent, IntMap.size values, candidate)+ | (candidate, values) <- Map.toList $ modelDomains model]+ candidates = sortOn (\(value, cost) -> (cost, value)) $ IntMap.toList $ modelDomains model Map.! name+ debug $ "Constraint branch: " <> show name <> ", " <> show (length candidates) <> " choices; lower bound " <> show (modelConstant model)+ (best, tried) <- foldM (branch model name cutoff) (Nothing, 1) candidates+ pure ((\(score, assignment) -> (score, restore eliminated assignment)) <$> best, tried)++ branch model name cutoff (best, tried) (value, _) = do+ let limit = maybe cutoff (Just . fst) best+ (result, count) <- search limit $ fixValue name value model+ pure ((\(score, assignment) -> (score, Map.insert name value assignment)) <$> result <|> best, tried + count)++ component _ _ (Nothing, tried) _ = pure (Nothing, tried)+ component model cutoff (Just (score, assignment), tried) group = do+ let isolated = Model (0, 0) (Map.restrictKeys (modelDomains model) group)+ (Map.filterWithKey (\(left, _) _ -> Set.member left group) $ modelEdges model)+ initial = Map.map (fst . IntMap.findMin) $ modelDomains isolated+ initialScore = evaluate isolated initial+ (result, count) <- search (Just initialScore) isolated+ let (cost, selected) = fromMaybe (initialScore, initial) result+ combined = add score cost+ pure (if maybe False (combined >=) cutoff then Nothing else Just (combined, Map.union assignment selected), tried + count)
+ plan/Plan/Trace.hs view
@@ -0,0 +1,14 @@+module Plan.Trace (tracePlan, runPlanTrace) where++import Distribution.ArchHs.Internal.Prelude+import System.IO (Handle, hFlush, hPutStrLn)++tracePlan :: Member Trace r => String -> Sem r ()+tracePlan = trace . ("[plan] " <>)++runPlanTrace :: Member (Embed IO) r => Bool -> Handle -> Sem (Trace ': r) a -> Sem r a+runPlanTrace False _ = ignoreTrace+runPlanTrace True handle = interpret $ \case+ Trace message -> when ("[plan] " `isPrefixOf` message) $ embed $ do+ hPutStrLn handle message+ hFlush handle
src/Distribution/ArchHs/Compat.hs view
@@ -12,24 +12,13 @@ import Distribution.Types.ConfVar import Distribution.Types.Flag import Distribution.Types.PackageDescription (PackageDescription, licenseFiles)-#if MIN_VERSION_Cabal(3,6,0) import Distribution.Utils.Path (getSymbolicPath)-#endif pattern PkgFlag :: FlagName -> ConfVar {-# COMPLETE PkgFlag #-} -#if MIN_VERSION_Cabal(3,4,0) type PkgFlag = PackageFlag pattern PkgFlag x = PackageFlag x-#else-type PkgFlag = Flag-pattern PkgFlag x = Flag x-#endif licenseFile :: PackageDescription -> Maybe FilePath-#if MIN_VERSION_Cabal(3,6,0) licenseFile = fmap getSymbolicPath . listToMaybe . licenseFiles-#else-licenseFile = listToMaybe . licenseFiles-#endif
src/Distribution/ArchHs/Core.hs view
@@ -20,12 +20,14 @@ collectTestDeps, collectSubLibDeps, collectSetupDeps,+ getDepsWithVersion, ) where import qualified Algebra.Graph.Labelled.AdjacencyMap as G import Data.Bifunctor (second) import Data.Containers.ListUtils (nubOrd)+import Data.Function (on) import qualified Data.Map as Map import Data.List (sort) import Data.Maybe (fromMaybe)@@ -37,6 +39,9 @@ ( getLatestCabal, getLatestSHA256, getPackageFlag,+ getLatestVersion,+ getCabalIncludingDeprecated,+ RawHackageDB, ) import Distribution.ArchHs.Internal.Prelude import Distribution.ArchHs.Local (ignoreList)@@ -54,7 +59,6 @@ import Distribution.System (Arch (X86_64), OS (Linux)) import qualified Distribution.Types.BuildInfo.Lens as L import Distribution.Types.CondTree (simplifyCondTree)-import Distribution.Types.Dependency (Dependency) import Distribution.Utils.ShortText (fromShortText) archEnv :: Version -> FlagAssignment -> ConfVar -> Either ConfVar Bool@@ -278,6 +282,28 @@ return result _ -> return mempty +getDepsWithVersion ::+ Members+ [ KnownGHCVersion,+ FlagAssignmentsEnv,+ DependencyRecord,+ Trace+ ]+ r =>+ GenericPackageDescription ->+ Sem r ([(PackageName, VersionRange)], [(PackageName, VersionRange)], [(PackageName, VersionRange)])+getDepsWithVersion cabal = do+ (libDeps, libToolsDeps, _) <- collectLibDeps id cabal+ (subLibDeps, subLibToolsDeps, _) <- collectSubLibDeps id cabal []+ (exeDeps, exeToolsDeps, _) <- collectExeDeps id cabal []+ (testDeps, testToolsDeps, _) <- collectTestDeps id cabal []+ setupDeps <- collectSetupDeps id cabal+ let flatten = mconcat . fmap snd+ deps = libDeps <> concatMap flatten [exeDeps, subLibDeps]+ makeDeps = libToolsDeps <> setupDeps <> concatMap flatten [subLibToolsDeps, exeToolsDeps]+ checkDeps = concatMap flatten [testDeps, testToolsDeps]+ pure $ (deps, makeDeps, checkDeps)+ updateDependencyRecord :: Member DependencyRecord r => PackageName -> VersionRange -> Sem r () updateDependencyRecord name range = modify' $ Map.insertWith (<>) name [range] @@ -286,9 +312,31 @@ ----------------------------------------------------------------------------- +-- | Get the version of a package in archlinux extra repo as 'Version'.+-- If the package does not exist, returns 'Nothing'.+-- If the package has an unparsable version, 'VersionNoParse' will be thrown.+getVersionInExtra :: Members [ExtraEnv, WithMyErr] r => PackageName -> Sem r (Maybe Version)+getVersionInExtra name =+ try @MyException (versionInExtra name)+ >>= \case+ Right rawVersion ->+ case simpleParsec rawVersion of+ Just version -> return $ Just version+ Nothing -> throw $ VersionNoParse rawVersion+ Left _ -> return $ Nothing++-- | Get a map from the dependencies to their combined version ranges, as declared in the given 'GenericPackageDescription'.+depsVersionMap :: Members [KnownGHCVersion, FlagAssignmentsEnv, DependencyRecord, Trace] r => GenericPackageDescription -> Sem r (Map.Map PackageName VersionRange)+depsVersionMap cabalfile = do+ (deps, makeDeps, checkDeps) <- getDepsWithVersion cabalfile+ return $ Map.fromList $ map (\l -> (fst (head l), foldr1 intersectVersionRanges (map snd l)))+ $ groupBy ((==) `on` fst)+ $ sortBy (compare `on` fst)+ $ deps <> makeDeps <> checkDeps+ -- | Generate 'PkgBuild' for a 'SolvedPackage'.-cabalToPkgBuild :: Members [HackageEnv, FlagAssignmentsEnv, WithMyErr] r => SolvedPackage -> Bool -> [ArchLinuxName] -> Sem r PkgBuild-cabalToPkgBuild pkg uusi sysDeps = do+cabalToPkgBuild :: Members [Embed IO, ExtraEnv, RawHackageEnv, HackageEnv, KnownGHCVersion, FlagAssignmentsEnv, DependencyRecord, Trace, WithMyErr] r => ([(PackageName, Version)] -> IO (RawHackageDB, RawHackageDB)) -> SolvedPackage -> Bool -> [ArchLinuxName] -> Sem r PkgBuild+cabalToPkgBuild loadHackageRevisions' pkg uusi sysDeps = do let name = pkg ^. pkgName cabal <- packageDescription <$> getLatestCabal name pkgFlags <- getPackageFlag name@@ -298,7 +346,8 @@ _sha256sums <- (\case Just s -> "'" <> s <> "'"; Nothing -> "'SKIP'") <$> getLatestSHA256 name let _hkgName = pkg ^. pkgName & unPackageName _pkgName = unArchLinuxName . toArchLinuxName $ pkg ^. pkgName- _pkgVer = prettyShow $ getPkgVersion cabal+ pkgVersion = getPkgVersion cabal+ _pkgVer = prettyShow $ pkgVersion _pkgDesc = fromShortText $ synopsis cabal getL NONE = "" getL (License e) = getE e@@ -339,11 +388,36 @@ ) depsToString k deps = (sort $ deps <&> (wrap . unArchLinuxName . toArchLinuxName . k)) & mconcat _depends = depsToString _depName depends <> depsToString id sysDeps- _makeDepends = (if uusi then " 'uusi'" else "") <> depsToString _depName makeDepends _url = getUrl cabal wrap s = " '" <> s <> "'" _licenseFile = licenseFile cabal- _enableUusi = uusi++ let packages = [(name, pkgVersion)]+ (revised, original) <- embed $ loadHackageRevisions' packages++ combinedDepVersionRanges <- (local @RawHackageDB (const revised) (getCabalIncludingDeprecated name pkgVersion)) >>= depsVersionMap+ combinedUnrevisedDepVersionRanges <- (local @RawHackageDB (const original) (getCabalIncludingDeprecated name pkgVersion)) >>= depsVersionMap++ -- Resolve versions associated with the declared dependencies+ let deps = Map.keys $ Map.union combinedDepVersionRanges combinedUnrevisedDepVersionRanges+ depsWithExtraVersion <- mapM (\d -> getVersionInExtra d >>= (\v -> return (d, v))) deps+ -- If dep doesn't have version in extra, use latest version from Hackage+ depsWithVersion <- mapM (\case (d, Just v) -> return (d, v); (d, Nothing) -> (getLatestVersion d >>= (\v -> return (d, v)))) depsWithExtraVersion+ let depToResolvedVersionMap = Map.fromList depsWithVersion+ isInRange dep range = withinRange (fromMaybe (error $ "Internal error: Dependency '" <> prettyShow dep <> "' is not in the dependency version map")+ $ Map.lookup dep depToResolvedVersionMap) range+ isNotInRange dep range = not (isInRange dep range)++ -- If dep has been removed in revision, then it clearly isn't needed, so ignore the version bounds+ revisedIsInRange dep = (\case Just range -> isInRange dep range; Nothing -> True) (Map.lookup dep combinedDepVersionRanges)+ -- If dep has been added in revision, manual intervention is needed+ unrevisedIsNotInRange dep = (\case Just range -> isNotInRange dep range; Nothing -> False) (Map.lookup dep combinedUnrevisedDepVersionRanges)++ outOfBounds = filter unrevisedIsNotInRange $ sort $ deps+ revisedInBounds = filter revisedIsInRange $ outOfBounds+ _removeBoundsWithUusi = map prettyShow revisedInBounds+ _enableUusi = uusi || (not (null _removeBoundsWithUusi))+ _makeDepends = (if _enableUusi then " 'uusi'" else "") <> depsToString _depName makeDepends return PkgBuild {..} -----------------------------------------------------------------------------
src/Distribution/ArchHs/DepCheck.hs view
@@ -5,6 +5,7 @@ ( DependencyFailure (..), VersionedList, dependencyFailures,+ dependencyFailuresByCategory, directDependencies, inRange, )@@ -27,9 +28,17 @@ Members [KnownGHCVersion, ExtraEnv, FlagAssignmentsEnv, WithMyErr, Trace, DependencyRecord] r => GenericPackageDescription -> Sem r [DependencyFailure]-dependencyFailures cabal = do+dependencyFailures cabal = uncurry (<>) <$> dependencyFailuresByCategory cabal++dependencyFailuresByCategory ::+ Members [KnownGHCVersion, ExtraEnv, FlagAssignmentsEnv, WithMyErr, Trace, DependencyRecord] r =>+ GenericPackageDescription ->+ Sem r ([DependencyFailure], [DependencyFailure])+dependencyFailuresByCategory cabal = do (depends, makedepends) <- directDependencies cabal- concat <$> traverse dependencyFailure (depends <> makedepends)+ depFailures <- concat <$> traverse dependencyFailure depends+ makeDepFailures <- concat <$> traverse dependencyFailure makedepends+ pure (depFailures, makeDepFailures) dependencyFailure :: Members [ExtraEnv, WithMyErr] r => (PackageName, VersionRange) -> Sem r [DependencyFailure] dependencyFailure dep =
src/Distribution/ArchHs/Hackage.hs view
@@ -16,6 +16,7 @@ insertDB, parseCabalFile, getLatestCabal,+ getLatestVersion, getNewerVersions, getCabal, getCabalIncludingDeprecated,@@ -27,7 +28,7 @@ ) where -import Control.Monad (filterM)+import Control.Monad (filterM, liftM) import Conduit import qualified Data.ByteString as BS import qualified Data.Conduit.Tar as Tar@@ -205,6 +206,10 @@ -- | Get the latest 'GenericPackageDescription'. getLatestCabal :: Members [HackageEnv, WithMyErr] r => PackageName -> Sem r GenericPackageDescription getLatestCabal = withLatestVersion cabalFile++-- | Get the latest 'Version'.+getLatestVersion :: Members [HackageEnv, WithMyErr] r => PackageName -> Sem r Version+getLatestVersion = (liftM $ getPkgVersion . packageDescription) . getLatestCabal -- | Get all Hackage versions newer than the given version. --
src/Distribution/ArchHs/PkgBuild.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-}@@ -19,6 +20,7 @@ import Data.Text (Text, pack, unpack) import Distribution.SPDX.LicenseId+import Lens.Micro ((&), (<&>)) import NeatInterpolation (text) import qualified Web.ArchLinux.Types as Arch @@ -46,13 +48,19 @@ _licenseFile :: Maybe String, -- | Whether generate @prepare()@ bash function which calls @uusi@ _enableUusi :: Bool,+ -- | List of dependencies whose version ranges will be removed in the @prepare()@ bash function using @uusi@+ _removeBoundsWithUusi :: [String], -- | Command-line flags _flags :: String } -- | Map 'LicenseId' to 'ArchLicense'. License not provided by system will be mapped to @custom:...@. mapLicense :: LicenseId -> Arch.License+#if MIN_VERSION_Cabal_syntax(3,16,0)+mapLicense N_0BSD = Arch.N_0BSD+#else mapLicense NullBSD = Arch.N_0BSD+#endif mapLicense AAL = Arch.AAL mapLicense Abstyles = Arch.Abstyles mapLicense Adobe_2006 = Arch.Adobe_2006@@ -533,7 +541,7 @@ Just n -> "\n" <> installLicense (pack n) _ -> "\n" )- (if _enableUusi then "\n" <> uusi <> "\n\n" else "\n")+ (if _enableUusi then "\n" <> (prepare . pack $ "uusi" <> (_removeBoundsWithUusi <&> (\r -> " -u " <> r) & mconcat)) <> "\n\n" else "\n") ("\n" <> check <> "\n\n") ( pack $ case _flags of [] -> ""@@ -546,7 +554,7 @@ [text| check() { cd $$_hkgname-$$pkgver- runhaskell Setup test+ runhaskell Setup test --show-details=direct } |] @@ -558,17 +566,18 @@ rm -f "$$pkgdir"/usr/share/doc/$$pkgname/$licenseFile |] -uusi :: Text-uusi =+prepare :: Text -> Text+prepare uusi = [text| prepare() {- uusi $$_hkgname-$$pkgver/$$_hkgname.cabal+ cd $$_hkgname-$$pkgver+ $uusi } |] --- | A fixed template of haskell package in archlinux. See <https://wiki.archlinux.org/index.php/Haskell_package_guidelines Haskell package guidelines> .+-- | A fixed template of haskell package in archlinux. See <https://manual.archlinux.page/package-guidelines/haskell/ Haskell package guidelines>. felixTemplate :: Text -> Text -> Text -> Text -> Text -> Text -> Text -> Text -> Text -> Text -> Text -> Text -> Text -> Text-felixTemplate hkgname pkgname pkgver pkgdesc url license depends makedepends sha256sums licenseF uusiF checkF flags =+felixTemplate hkgname pkgname pkgver pkgdesc url license depends makedepends sha256sums licenseF prepareF checkF flags = [text| # This file was generated by https://github.com/berberman/arch-hs, please check it manually. # Maintainer: Your Name <youremail@domain.com>@@ -585,7 +594,7 @@ makedepends=('ghc'$makedepends) source=("https://hackage.haskell.org/packages/archive/$$_hkgname/$$pkgver/$$_hkgname-$$pkgver.tar.gz") sha256sums=($sha256sums)- $uusiF+ $prepareF build() { cd $$_hkgname-$$pkgver @@ -595,7 +604,7 @@ --ghc-option=-optl-Wl\,-z\,relro\,-z\,now \ --ghc-option='-pie' $flags - runhaskell Setup build+ runhaskell Setup build $$MAKEFLAGS runhaskell Setup register --gen-script runhaskell Setup unregister --gen-script sed -i -r -e "s|ghc-pkg.*update[^ ]* |&'--force' |" register.sh
src/Distribution/ArchHs/RDepCheck.hs view
@@ -165,14 +165,9 @@ [DepSrc] -> Sem r [(DepSrc, VersionRange)] getDepVersion cabal name src = do- (libDeps, libToolsDeps, _) <- collectLibDeps id cabal- (subLibDeps, subLibToolsDeps, _) <- collectSubLibDeps id cabal []- (exeDeps, exeToolsDeps, _) <- collectExeDeps id cabal []- (testDeps, testToolsDeps, _) <- collectTestDeps id cabal []- setupDeps <- collectSetupDeps id cabal- let flatten = mconcat . fmap snd- deps = libDeps <> concatMap flatten [exeDeps, subLibDeps]- makeOrCheckDeps = libToolsDeps <> setupDeps <> concatMap flatten [subLibToolsDeps, exeToolsDeps, testDeps, testToolsDeps]+ depsWithVersion <- getDepsWithVersion cabal+ let (deps, makeDeps, checkDeps) = depsWithVersion+ makeOrCheckDeps = makeDeps <> checkDeps pure $ catMaybes [ case s of
sync/Check.hs view
@@ -24,6 +24,7 @@ data CheckResult = CheckResult { depFailures :: [DependencyFailure],+ existingDepFailures :: [DependencyFailure], rdepFailures :: [ReverseDependencyFailure], existingRdepFailures :: [ReverseDependencyFailure] }@@ -103,6 +104,8 @@ pure ((\hackageVersion -> NewerVersion hackageVersion Nothing) <$> hackageVersions, []) checkNewerVersions True hackageName archVersion hackageVersions = do (reverseDeps, skipped) <- reverseDependencyRangesWithSkips hackageName+ currentFailures <- try @MyException $ getCabalIncludingDeprecated hackageName archVersion >>= dependencyFailuresByCategory+ let (currentDepends, currentMakeDepends) = either (const ([], [])) id currentFailures newerVersions <- forM hackageVersions $ \hackageVersion -> do -- Candidates are already filtered by preferred versions. Parse the raw@@ -111,8 +114,10 @@ case eCabal of Left err -> pure $ UncheckedVersion hackageVersion err Right cabal -> do- depFailureDetails <- dependencyFailures cabal- let (newRdepFailures, oldRdepFailures) =+ (depends, makeDepends) <- dependencyFailuresByCategory cabal+ let (newDepends, oldDepends) = classifyDependencyFailures currentDepends depends+ (newMakeDepends, oldMakeDepends) = classifyDependencyFailures currentMakeDepends makeDepends+ (newRdepFailures, oldRdepFailures) = partition (\(ReverseDependencyFailure _ _ range) -> withinRange archVersion range) (rdepFailureDetails hackageVersion reverseDeps)@@ -121,13 +126,24 @@ hackageVersion ( Just CheckResult- { depFailures = depFailureDetails,+ { depFailures = newDepends <> newMakeDepends,+ existingDepFailures = oldDepends <> oldMakeDepends, rdepFailures = newRdepFailures, existingRdepFailures = oldRdepFailures } ) pure (newerVersions, skipped) +classifyDependencyFailures :: [DependencyFailure] -> [DependencyFailure] -> ([DependencyFailure], [DependencyFailure])+classifyDependencyFailures current = partition ((`Set.notMember` existing) . dependencyFailureName)+ where+ existing = Set.fromList $ dependencyFailureName <$> current++dependencyFailureName :: DependencyFailure -> PackageName+dependencyFailureName = \case+ MissingDependency name _ -> name+ DependencyOutOfRange name _ _ -> name+ uniqueSkippedReverseDeps :: [SkippedReverseDep] -> [SkippedReverseDep] uniqueSkippedReverseDeps = Map.elems@@ -188,7 +204,7 @@ prettyNewerVersion (UncheckedVersion version _) = annRed $ viaPretty version <+> parens "unchecked: cabal parse failed" prettyNewerVersion (NewerVersion version Nothing) = annGreen $ viaPretty version-prettyNewerVersion (NewerVersion version (Just CheckResult {depFailures = [], rdepFailures = [], existingRdepFailures = []})) =+prettyNewerVersion (NewerVersion version (Just CheckResult {depFailures = [], existingDepFailures = [], rdepFailures = [], existingRdepFailures = []})) = annGreen $ viaPretty version <+> parens "ok" prettyNewerVersion (NewerVersion version (Just failures@CheckResult {depFailures = [], rdepFailures = []})) = annYellow $ viaPretty version <+> parens ("existing:" <+> prettyCheckFailures failures)@@ -199,6 +215,7 @@ prettyCheckFailures CheckResult {..} = hsep . punctuate comma $ ["dep=" <> pretty (length depFailures) | not (null depFailures)]+ <> ["dep-old=" <> pretty (length existingDepFailures) | not (null existingDepFailures)] <> ["rdep=" <> pretty (length rdepFailures) | not (null rdepFailures)] <> ["rdep-old=" <> pretty (length existingRdepFailures) | not (null existingRdepFailures)] @@ -206,17 +223,18 @@ prettyVerboseNewerVersion (UncheckedVersion version err) = [viaPretty version <> colon, indent 2 $ viaShow err] prettyVerboseNewerVersion (NewerVersion _ Nothing) = []-prettyVerboseNewerVersion (NewerVersion _ (Just CheckResult {depFailures = [], rdepFailures = [], existingRdepFailures = []})) = []+prettyVerboseNewerVersion (NewerVersion _ (Just CheckResult {depFailures = [], existingDepFailures = [], rdepFailures = [], existingRdepFailures = []})) = [] prettyVerboseNewerVersion (NewerVersion version (Just CheckResult {..})) = (viaPretty version <> colon)- : fmap (indent 2 . prettyDependencyFailure) depFailures+ : fmap (indent 2 . prettyDependencyFailure (annRed "dep:")) depFailures+ <> fmap (indent 2 . prettyDependencyFailure (annYellow "dep-old:")) existingDepFailures <> fmap (indent 2 . prettyReverseDependencyFailure (annRed "rdep:")) rdepFailures <> fmap (indent 2 . prettyReverseDependencyFailure (annYellow "rdep-old:")) existingRdepFailures -prettyDependencyFailure :: DependencyFailure -> Doc AnsiStyle-prettyDependencyFailure = \case+prettyDependencyFailure :: Doc AnsiStyle -> DependencyFailure -> Doc AnsiStyle+prettyDependencyFailure label = \case MissingDependency name range ->- annRed "dep:"+ label <+> viaPretty name <+> "requires" <+> viaPretty range@@ -224,7 +242,7 @@ <+> ppExtra <+> "missing" DependencyOutOfRange name range version ->- annRed "dep:"+ label <+> viaPretty name <+> "requires" <+> viaPretty range
test/Main.hs view
@@ -260,6 +260,92 @@ show result `shouldBe` "Right ()" output `shouldContain` "haskell-hsc2hs" + describe "sync direct dependency failure classification" $ do+ forM_+ [ ("warns about unchanged upper bounds", ["ansi-wl-pprint ^>=1.0.2"], ["ansi-wl-pprint ^>=1.0.2"], "existing: dep-old=1"),+ ("warns about changed bounds that remain unmet", ["ansi-wl-pprint <1"], ["ansi-wl-pprint <1.1"], "existing: dep-old=1"),+ ("blocks newly unmet bounds", ["ansi-wl-pprint ^>=1.1.1"], ["ansi-wl-pprint ^>=1.0.2"], "blocked: dep=1"),+ ("blocks newly added dependencies", [], ["ansi-wl-pprint ^>=1.0.2"], "blocked: dep=1"),+ ("drops failures repaired by the candidate", ["ansi-wl-pprint ^>=1.0.2"], ["ansi-wl-pprint ^>=1.0.2 || ^>=1.1.1"], "ok"),+ ("drops removed dependencies", ["ansi-wl-pprint ^>=1.0.2"], [], "ok")+ ] $ \(label, installedDeps, candidateDeps, expected) ->+ it label $ do+ let (hackage, raw, baseExtra, name) = syncDepCheckDBsWithVersions [("1.0", installedDeps), ("2.0", candidateDeps)] []+ dependency = toArchLinuxName $ mkPackageName "ansi-wl-pprint"+ desc = (baseExtra Map.! toArchLinuxName name) {_name = dependency, _version = "1.1.1", _rawVersion = "1.1.1-1"}+ extra = Map.insert dependency desc baseExtra+ output <- runSyncDepCheckDBs True (hackage, raw, extra, name)+ output `shouldContain` ("2.0 (" <> expected <> ")")+ if expected == "existing: dep-old=1"+ then do+ output `shouldContain` "dep-old: ansi-wl-pprint requires"+ output `shouldNotContain` "dep: ansi-wl-pprint"+ else output `shouldNotContain` "dep-old:"++ it "warns about missing dependencies already required by the installed version" $ do+ output <- runSyncDepCheckDBs False $+ syncDepCheckDBsWithVersions [("1.0", ["missing >=1"]), ("2.0", ["missing >=2"])] []+ output `shouldContain` "2.0 (existing: dep-old=1)"+ output `shouldNotContain` "blocked:"+ output `shouldNotContain` "dep-old:"++ it "combines new and existing direct and reverse dependency failures" $ do+ output <- runSyncDepCheckDBs True $+ syncDepCheckDBsWithVersions+ [("1.0", ["missing >=1"]), ("2.0", ["missing >=1", "new-missing >=1"])]+ [("new", [Run], "<2"), ("old", [Run], "<1")]+ output `shouldContain` "2.0 (blocked: dep=1, dep-old=1, rdep=1, rdep-old=1)"+ output `shouldContain` "dep: new-missing requires >=1, [extra] missing"+ output `shouldContain` "dep-old: missing requires >=1, [extra] missing"++ it "shows existing direct and reverse failures together as warnings" $ do+ output <- runSyncDepCheckDBs False $+ syncDepCheckDBsWithVersions [("1.0", ["missing >=1"]), ("2.0", ["missing >=1"])] [("old", [Run], "<1")]+ output `shouldContain` "2.0 (existing: dep-old=1, rdep-old=1)"+ output `shouldNotContain` "blocked:"++ it "compares every candidate against the installed version" $ do+ output <- runSyncDepCheckDBs False $+ syncDepCheckDBsWithVersions [("1.0", []), ("1.1", ["missing >=1"]), ("2.0", ["missing >=1"]), ("3.0", ["missing >=1"])] []+ forM_ ["1.1", "2.0", "3.0"] $ \version ->+ output `shouldContain` (version <> " (blocked: dep=1)")+ output `shouldNotContain` "dep-old="++ it "does not classify new build dependency failures as existing runtime failures" $ do+ let (_, baseRaw, extra, name) = syncDepCheckDBsWithVersions [("1.0", ["missing <1"]), ("2.0", ["missing <1"])] []+ raw = Map.adjust+ (\package ->+ package+ { RawHackage.versions = Map.adjust+ (\version -> version {RawHackage.cabalFile = RawHackage.cabalFile version <> B8.pack "custom-setup\n setup-depends: missing >=2\n"})+ (parseVersion "2.0")+ (RawHackage.versions package)+ })+ name+ baseRaw+ output <- runSyncDepCheckDBs True (Hackage.parseDB raw, raw, extra, name)+ output `shouldContain` "2.0 (blocked: dep=1, dep-old=1)"+ output `shouldContain` "dep: missing requires >=2, [extra] missing"+ output `shouldContain` "dep-old: missing requires <1, [extra] missing"++ it "reads installed metadata even when that version is deprecated" $ do+ let (_, baseRaw, extra, name) = syncDepCheckDBsWithVersions [("1.0", ["missing >=1"]), ("2.0", ["missing >=1"])] []+ raw = Map.adjust (\package -> package {RawHackage.preferredVersions = B8.pack "Diff >1"}) name baseRaw+ output <- runSyncDepCheckDBs False (Hackage.parseDB raw, raw, extra, name)+ output `shouldContain` "2.0 (existing: dep-old=1)"++ forM_ [False, True] $ \unparseable ->+ it ("keeps failures blocking without readable installed metadata, unparseable=" <> show unparseable) $ do+ let (_, baseRaw, extra, name) = syncDepCheckDBsWithVersions [("1.0", ["missing >=1"]), ("2.0", ["missing >=1"])] []+ changeVersions =+ if unparseable+ then Map.adjust (\version -> version {RawHackage.cabalFile = B8.pack "cabal-version: 999.0\nname: Diff\nversion: 1.0\n"}) (parseVersion "1.0")+ else Map.delete (parseVersion "1.0")+ raw = Map.adjust (\package -> package {RawHackage.versions = changeVersions $ RawHackage.versions package}) name baseRaw+ output <- runSyncDepCheckDBs False (Hackage.parseDB raw, raw, extra, name)+ output `shouldContain` "2.0 (blocked: dep=1)"+ output `shouldNotContain` "dep-old="+ describe "sync reverse dependency failure classification" $ do it "counts newly broken and already unmet ranges separately" $ do output <- runSyncDepCheck True [] [("new", [Run], "<2"), ("old", [Run], "<1")]@@ -765,9 +851,12 @@ action path runSyncDepCheck :: Bool -> [String] -> [(String, [DepSrc], String)] -> IO String-runSyncDepCheck verbose deps reverseDeps = do- let (hackage, raw, extra, name) = syncDepCheckDBs deps reverseDeps- currentVersion = parseVersion "1.0"+runSyncDepCheck verbose deps reverseDeps =+ runSyncDepCheckDBs verbose $ syncDepCheckDBs deps reverseDeps++runSyncDepCheckDBs :: Bool -> (Hackage.HackageDB, RawHackage.HackageDB, ExtraDB, PackageName) -> IO String+runSyncDepCheckDBs verbose (hackage, raw, extra, name) = do+ let currentVersion = parseVersion "1.0" result <- runM . runError @MyException@@ -791,7 +880,10 @@ pure "" syncDepCheckDBs :: [String] -> [(String, [DepSrc], String)] -> (Hackage.HackageDB, RawHackage.HackageDB, ExtraDB, PackageName)-syncDepCheckDBs deps reverseDeps =+syncDepCheckDBs deps = syncDepCheckDBsWithVersions $ ("1.0", []) : [(version, deps) | version <- ["1.1", "2.0", "3.0"]]++syncDepCheckDBsWithVersions :: [(String, [String])] -> [(String, [DepSrc], String)] -> (Hackage.HackageDB, RawHackage.HackageDB, ExtraDB, PackageName)+syncDepCheckDBsWithVersions candidates reverseDeps = (Hackage.parseDB raw, raw, extra, name) where name = mkPackageName "Diff"@@ -799,20 +891,20 @@ grouped = Map.fromListWith (<>) [(rdep, [(sources, range)]) | (rdep, sources, range) <- reverseDeps] raw = Map.fromList $- (name, packageData [(version, candidate) | version <- ["1.1", "2.0", "3.0"]] "Diff")+ (name, packageData [(version, candidate deps) | (version, deps) <- candidates] "Diff") : [(mkPackageName rdep, packageData [("1.0", components ranges)] rdep) | (rdep, ranges) <- Map.toList grouped] packageData versions package = RawHackage.PackageData B8.empty . Map.fromList $ [ ( parseVersion version, RawHackage.VersionData- (B8.pack $ unlines $ ["cabal-version: 1.24", "name: " <> package, "version: " <> version, "build-type: Simple"] <> body)+ (B8.pack $ unlines $ ["cabal-version: 2.2", "name: " <> package, "version: " <> version, "build-type: Simple"] <> body) B8.empty ) | (version, body) <- versions ] - candidate =+ candidate deps = if null deps then [] else ["library", " build-depends: " <> intercalate ", " deps]
test/PlanSpec.hs view
@@ -2,11 +2,13 @@ module PlanSpec (spec) where +import Control.Exception (bracket) import Control.Monad (forM_) import qualified Data.ByteString.Char8 as B8 import Data.Either (isLeft) import Data.List (intercalate) import qualified Data.Map.Strict as Map+import qualified Data.IntMap.Strict as IntMap import Distribution.ArchHs.Exception import Distribution.ArchHs.Name (toArchLinuxName) import Distribution.ArchHs.Options (ParserResult (..), defaultPrefs, execParserPure, info)@@ -21,22 +23,96 @@ import qualified Plan import qualified Plan.Args as Args import qualified Plan.Toolchain as Toolchain+import qualified Plan.Solver as Solver+import Plan.Trace (runPlanTrace, tracePlan) import Polysemy (runM) import Polysemy.Error (runError) import Polysemy.Reader (runReader) import Polysemy.State (evalState)-import Polysemy.Trace (ignoreTrace)+import Polysemy.Trace (ignoreTrace, trace)+import System.Directory (getTemporaryDirectory, removeFile)+import System.IO (hClose, openBinaryTempFile)+import System.Timeout (timeout) import Test.Hspec spec :: Spec spec = describe "coordinated update planner" $ do+ it "matches exhaustive finite-domain optimization on varied constraint graphs" $+ forM_ [0 :: Int .. 63] $ \seed -> do+ let names = ["alpha", "bravo", "charlie"]+ domains = Map.fromList+ [(package, IntMap.fromList [(value, ((seed + position * 7 + value * 3) `mod` 4, value)) | value <- [0 .. 2]])+ | (position, package) <- zip [0 :: Int ..] names]+ edges = Map.fromList+ [((left, right), IntMap.fromList+ [(own, IntMap.fromList [(other, ((seed + position * 3 + own * 5 + other * 7 + own * other) `mod` 4, 0)) | other <- [0 .. 2]]) | own <- [0 .. 2]])+ | (position, (left, right)) <- zip [0 :: Int ..] [("alpha", "bravo"), ("alpha", "charlie"), ("bravo", "charlie")],+ (seed + position) `mod` 4 /= 0]+ model = Solver.Model (seed `mod` 2, seed `mod` 3) domains edges+ assignments = [Map.fromList $ zip names values | values <- sequence $ replicate 3 [0 .. 2]]+ add (failures, steps) (otherFailures, otherSteps) = (failures + otherFailures, steps + otherSteps)+ score assignment = foldl add (Solver.modelConstant model) $+ [values IntMap.! (assignment Map.! package) | (package, values) <- Map.toList domains] <>+ [table IntMap.! (assignment Map.! left) IntMap.! (assignment Map.! right) | ((left, right), table) <- Map.toList edges]+ (actual, selected, _) <- Solver.optimize (const $ pure ()) model+ actual `shouldBe` minimum (score <$> assignments)+ score selected `shouldBe` actual+ forM_ [(fst actual, snd actual - 1), actual, (fst actual, snd actual + 1)] $ \limit -> do+ (bounded, _) <- Solver.optimizeBelow (const $ pure ()) (Just limit) model+ case bounded of+ Nothing -> actual `shouldSatisfy` (>= limit)+ Just (boundedScore, boundedSelection) -> do+ boundedScore `shouldBe` actual+ boundedScore `shouldSatisfy` (< limit)+ score boundedSelection `shouldBe` actual++ it "reduces large independent domains in one optimization pass" $ do+ let domains = Map.fromList+ [(package, IntMap.fromList [(0, (2, 0)), (1, (0, 1))]) | package <- [1 :: Int .. 4096]]+ model = Solver.Model (1, 0) domains Map.empty+ result <- timeout 5000000 $ Solver.optimize (const $ pure ()) model+ case result of+ Nothing -> expectationFailure "independent domain reduction took too long"+ Just (score, selected, _) -> do+ score `shouldBe` (1, 4096)+ selected `shouldBe` Map.map (const 1) domains++ it "collapses releases with equivalent dependency outcomes before branching" $ do+ let packages = ["alpha", "bravo", "charlie"]+ domains = Map.fromList+ [(package, IntMap.fromList [(value, (0, value `div` 3)) | value <- [0 .. 29]]) | package <- packages]+ edges = Map.fromList+ [((left, right), IntMap.fromList+ [(own, IntMap.fromList [(other, (if own `mod` 3 == (other + shift) `mod` 3 then 0 else 1, 0)) | other <- [0 .. 29]]) | own <- [0 .. 29]])+ | (left, right, shift) <- [("alpha", "bravo", 1), ("alpha", "charlie", 2), ("bravo", "charlie", 1)]]+ (score, selected, branches) <- Solver.optimize (const $ pure ()) $ Solver.Model (0, 0) domains edges+ score `shouldBe` (0, 0)+ Map.elems selected `shouldSatisfy` all (< 3)+ branches `shouldSatisfy` (<= 4)+ it "parses solve mode with per-package minimum versions" $ case execParserPure defaultPrefs (info Args.cmdOptions mempty) ["--solve", "alpha", "2.0", "bravo"] of Success (Right options) -> do Args.optSolve options `shouldBe` True+ Args.optDebug options `shouldBe` False Args.optTargets options `shouldBe` [(name "alpha", Just $ version "2.0"), (name "bravo", Nothing)] _ -> expectationFailure "expected planner arguments to parse" + it "parses opt-in solver diagnostics" $+ case execParserPure defaultPrefs (info Args.cmdOptions mempty) ["--debug", "--solve", "alpha"] of+ Success (Right options) -> do+ Args.optDebug options `shouldBe` True+ Args.optSolve options `shouldBe` True+ _ -> expectationFailure "expected debug arguments to parse"++ it "keeps diagnostics silent by default" $ do+ output <- capturePlanTrace False+ output `shouldBe` ""++ it "prints planner diagnostics without internal dependency traces" $ do+ output <- capturePlanTrace True+ output `shouldBe` "[plan] Checking candidate...\n"+ forM_ [[], ["2.0"], ["alpha", "2..0"]] $ \args -> it ("rejects malformed arguments " <> show args) $ case execParserPure defaultPrefs (info Args.cmdOptions mempty) args of@@ -311,7 +387,7 @@ assertBlocked result "dep: alpha requires bravo <2" length (Plan.planWarnings result) `shouldBe` 0 - it "detects impossible transitive bounds before enumerating independent updates" $ do+ it "keeps independent updates despite impossible transitive bounds" $ do let plugins = ["plugin" <> show i | i <- [1 :: Int .. 12]] result <- runPlan True [("alpha", Just "2.0")] ([ ("alpha", [], [(v, lib (["bravo ==" <> v] <> [package <> " ==" <> v | package <- plugins])) | v <- ["2.0", "3.0"]]),@@ -319,10 +395,72 @@ ("charlie", [], [("2.0", [])]) ] <> [(package, [], [(v, []) | v <- ["2.0", "3.0"]]) | package <- plugins]) assertBlocked result "no installed or newer preferred version of charlie satisfies"- Plan.plansTried result `shouldBe` 1+ Plan.planVersions result `shouldBe` Map.fromList [(name package, version "2.0") | package <- "alpha" : plugins]+ length (Plan.planProblems result) `shouldBe` 1+ Plan.plansTried result `shouldSatisfy` (<= 40) + forM_+ [ ("test", ["test-suite checks", " type: exitcode-stdio-1.0", " main-is: Test.hs", " build-depends: hedgehog <1"]),+ ("setup", ["custom-setup", " setup-depends: hedgehog <1"])+ ] $ \(component, dependencies) ->+ it ("explains transitive " <> component <> " conflicts without adding partial-plan blockers") $ do+ result <- runPlan True [("alpha", Just "2.0")]+ [ ("alpha", [], [("2.0", lib ["plugin ==2.0"])]),+ ("plugin", [], [("2.0", lib ["stan ==2.0"])]),+ ("stan", [], [("2.0", lib ["trial ==2.0"])]),+ ("trial", [], [("2.0", dependencies)]),+ ("hedgehog", [], [])+ ]+ assertBlocked result "dep: alpha requires plugin ==2.0"+ Plan.planVersions result `shouldBe` Map.singleton (name "alpha") (version "2.0")+ length (Plan.planProblems result) `shouldBe` 1+ let notes = unlines $ show <$> Plan.planSearchNotes result+ notes `shouldContain` "Full-solution conflicts (not additional blockers in the partial plan):"+ notes `shouldContain` "trial 2.0 MakeDepends requires hedgehog <1"+ notes `shouldContain` "Required through: alpha -> plugin -> stan -> trial -> hedgehog"++ it "retains both owners of incompatible propagated bounds" $ do+ result <- runPlan True [("alpha", Just "2.0"), ("bravo", Just "2.0")]+ [ ("alpha", [], [("2.0", lib ["hedgehog <2"])]),+ ("bravo", [], [("2.0", lib ["hedgehog >=2"])]),+ ("hedgehog", [], [("2.0", [])])+ ]+ length (Plan.planProblems result) `shouldBe` 1+ let notes = unlines $ show <$> Plan.planSearchNotes result+ notes `shouldContain` "alpha 2.0 Depends requires hedgehog <2"+ notes `shouldContain` "bravo 2.0 Depends requires hedgehog >=2"++ it "omits redundant owners from propagated conflict explanations" $ do+ result <- runPlan True [("alpha", Just "2.0")]+ [ ("alpha", [], [("2.0", lib ["trial ==2.0", "hedgehog <3"])]),+ ("trial", [], [("2.0", lib ["hedgehog <1"])]),+ ("hedgehog", [], [("2.0", [])])+ ]+ let notes = unlines $ show <$> Plan.planSearchNotes result+ notes `shouldContain` "trial 2.0 Depends requires hedgehog <1"+ notes `shouldNotContain` "alpha 2.0 Depends requires hedgehog <3"+ notes `shouldContain` "Required through: alpha -> trial -> hedgehog"++ it "keeps provenance for missing dependencies without version bounds" $ do+ result <- runPlan True [("alpha", Just "2.0")]+ [("alpha", [], [("2.0", lib ["missing"])])]+ let notes = unlines $ show <$> Plan.planSearchNotes result+ notes `shouldContain` "alpha 2.0 Depends requires missing >=0"+ notes `shouldContain` "Required through: alpha -> missing"++ it "finds a finite provenance path through dependency cycles" $ do+ result <- runPlan True [("alpha", Just "2.0")]+ [ ("alpha", [], [("2.0", lib ["bravo ==2.0"])]),+ ("bravo", [], [("2.0", lib ["charlie ==2.0"])]),+ ("charlie", [], [("2.0", lib ["bravo ==2.0", "hedgehog <1"])]),+ ("hedgehog", [], [])+ ]+ let notes = unlines $ show <$> Plan.planSearchNotes result+ notes `shouldContain` "charlie 2.0 Depends requires hedgehog <1"+ notes `shouldContain` "Required through: alpha -> bravo -> charlie -> hedgehog"+ forM_ [["bravo"], ["bravo", "charlie", "delta"]] $ \required ->- it ("stops on proven conflicts with " <> show (length required) <> " initial failures") $ do+ it ("minimizes partial plans with " <> show (length required) <> " initial failures") $ do let plugins = ["plugin" <> show i | i <- [1 :: Int .. 12]] result <- runPlan True [("alpha", Just "2.0")] ([ ("alpha", [], [("2.0", lib [package <> " ==2.0" | package <- required])]),@@ -332,10 +470,13 @@ ("base", [], []) ] <> [(package, [], [("2.0", [])]) | package <- plugins <> required]) assertBlocked result "dep: alpha requires bravo ==2.0"- Plan.planVersions result `shouldBe` Map.singleton (name "alpha") (version "2.0")- length (Plan.planProblems result) `shouldBe` length required- Plan.plansTried result `shouldBe` 1+ Plan.planVersions result `shouldBe` Map.fromList [(name package, version "2.0") | package <- "alpha" : filter (/= "bravo") required]+ length (Plan.planProblems result) `shouldBe` 1+ Plan.plansTried result `shouldSatisfy` (<= 40) show (Plan.prettyPlanResult result) `shouldContain` "base is fixed at 1.0 by the installed GHC"+ let notes = unlines $ show <$> Plan.planSearchNotes result+ notes `shouldContain` "consumer 2.0 Depends requires base >=2"+ notes `shouldContain` "Required through: alpha -> bravo -[reverse dependency]-> consumer -> base" it "does not infer a global conflict when a later target avoids the reverse update" $ do result <- runPlan True [("alpha", Just "2.0")]@@ -346,6 +487,59 @@ assertWorking result [("alpha", "3.0")] length (Plan.planSearchNotes result) `shouldBe` 0 + it "repairs wide partial plans without enumerating independent update subsets" $ do+ let plugins = ["plugin" <> show index | index <- [1 :: Int .. 24]]+ result <- runPlan True [("alpha", Just "2.0")]+ ([ ("alpha", [], [("2.0", lib $ "base >=2" : [package <> " ==2.0" | package <- plugins])]),+ ("base", [], [])+ ] <> [(package, [], [("2.0", [])]) | package <- plugins])+ assertBlocked result "dep: alpha requires base >=2"+ Plan.planVersions result `shouldBe` Map.fromList [(name package, version "2.0") | package <- "alpha" : plugins]+ length (Plan.planProblems result) `shouldBe` 1+ Plan.plansTried result `shouldSatisfy` (<= 50)++ it "keeps future package failures consistent when bounding wide partial plans" $ do+ let plugins = ["plugin" <> show index | index <- [1 :: Int .. 24]]+ dependencies = [package <> " ==2.0" | package <- plugins]+ result <- runPlan True [("alpha", Just "2.0"), ("bravo", Just "2.0")]+ ([ ("alpha", [], [("2.0", lib $ "base >=2" : dependencies), ("3.0", lib $ "ghc-prim >=2" : dependencies)]),+ ("bravo", [], [("2.0", lib ["ghc-prim >=2"]), ("3.0", lib ["base >=2"])]),+ ("base", [], []),+ ("ghc-prim", [], [])+ ] <> [(package, [], [("2.0", [])]) | package <- plugins])+ assertBlocked result "dep: alpha requires base >=2"+ Plan.planVersions result `shouldBe` Map.fromList [(name package, version "2.0") | package <- "alpha" : "bravo" : plugins]+ length (Plan.planProblems result) `shouldBe` 2+ Plan.plansTried result `shouldSatisfy` (<= 60)++ it "checks later requested releases before enumerating partial update subsets" $ do+ let plugins = ["plugin" <> show index | index <- [1 :: Int .. 24]]+ dependencies = "base >=2" : [package <> " ==2.0" | package <- plugins]+ result <- runPlan True [("alpha", Just "2.0")]+ ([ ("alpha", [], [("2.0", lib dependencies), ("3.0", lib dependencies), ("4.0", lib ["base >=2"])]),+ ("base", [], [])+ ] <> [(package, [], [("2.0", [])]) | package <- plugins])+ assertBlocked result "dep: alpha requires base >=2"+ Plan.planVersions result `shouldBe` Map.singleton (name "alpha") (version "4.0")+ length (Plan.planProblems result) `shouldBe` 1+ Plan.plansTried result `shouldSatisfy` (<= 60)++ it "solves a coordinated plugin family with unavoidable blockers promptly" $ do+ let plugins = ["plugin" <> show index | index <- [1 :: Int .. 24]]+ releases = ["2.0", "3.0"]+ specs =+ [ ("server", [], [(release, lib $ "missing ==1" : ("core ==" <> release) : [package <> " ==" <> release | package <- plugins]) | release <- releases]),+ ("core", [], [(release, lib ["base >=2"]) | release <- releases]),+ ("base", [], [])+ ] <> [(package, [], [(release, lib ["core ==" <> release]) | release <- releases]) | package <- plugins]+ completed <- timeout 5000000 $ runPlan True [("server", Just "2.0")] specs+ case completed of+ Nothing -> expectationFailure "coordinated partial optimization exceeded five seconds"+ Just result -> do+ Plan.planVersions result `shouldBe` Map.fromList [(name package, version "2.0") | package <- "server" : "core" : plugins]+ length (Plan.planProblems result) `shouldBe` 2+ Plan.plansTried result `shouldSatisfy` (<= 10)+ it "does not revalidate unrelated dependencies of packages kept installed" $ do result <- runPlan True [("alpha", Just "2.0")] [("alpha", [], [("2.0", lib ["bravo >=1"])]), ("bravo", [], [("1.0", lib ["missing >=2"])])]@@ -398,6 +592,51 @@ Plan.planVersions result `shouldBe` Map.fromList [(name "alpha", version "2.0"), (name "consumer", version "2.0")] length (Plan.planProblems result) `shouldBe` 1 + it "prefers the cheapest partial plan when repairing one bound breaks another" $ do+ result <- runPlan True [("alpha", Just "2.0")]+ [ ("alpha", [], [("2.0", lib ["bravo >=2", "charlie >=2"])]),+ ("bravo", [], [("2.0", [])]),+ ("charlie", [], [("2.0", [])]),+ ("consumer", ["bravo"], [("1.0", lib ["bravo <2"])])+ ]+ assertBlocked result "dep: alpha requires bravo"+ Plan.planVersions result `shouldBe` Map.fromList [(name package, version "2.0") | package <- ["alpha", "charlie"]]+ length (Plan.planProblems result) `shouldBe` 1++ it "agrees with exhaustive partial search on non-monotonic package versions" $ do+ forM_ ["bravo <2", "bravo >=3", "bravo >=4"] $ \initialRange -> do+ let specs =+ [ ("alpha", [], [("2.0", lib ["missing >=1", initialRange]), ("3.0", lib ["missing >=1", "bravo <3"])]),+ ("bravo", [], [("2.0", lib ["alpha <3"]), ("3.0", lib ["alpha >=3"])])+ ]+ releases = ["2.0", "3.0"]+ combinations = [(alphaCost + bravoCost, alpha, bravo) |+ (alphaCost, alpha) <- zip [0 :: Int ..] releases, (bravoCost, bravo) <- zip [0 ..] releases]+ exhaustive <- mapM+ (\(cost, alpha, bravo) -> do+ checked <- runPlan False [("alpha", Just alpha), ("bravo", Just bravo)] specs+ pure (length $ Plan.planProblems checked, cost)) combinations+ solved <- runPlan True [("alpha", Just "2.0"), ("bravo", Just "2.0")] specs+ let cost = length $ filter (== version "3.0") $ Map.elems $ Plan.planVersions solved+ (length $ Plan.planProblems solved, cost) `shouldBe` minimum exhaustive++ it "agrees with exhaustive partial search across varied three-package constraints" $ do+ let packages = ["alpha", "bravo", "charlie"]+ ranges = ["<2", "<3", ">=3", "==2", "==3", ">=4"]+ forM_ [0 .. 31 :: Int] $ \seed -> do+ let specs = ("consumer", ["alpha"], [("1.0", lib ["alpha <2"])]) :+ [(owner, [], [(release, lib [dependency <> " " <> ranges !! ((seed `div` (ownerIndex + 1) + releaseIndex * 3 + ownerIndex) `mod` length ranges)]) |+ (releaseIndex, release) <- zip [0 :: Int ..] ["2.0", "3.0"]]) |+ (ownerIndex, (owner, dependency)) <- zip [0 :: Int ..] $ zip packages (drop 1 packages <> take 1 packages)]+ combinations = sequence $ replicate 3 ["2.0", "3.0"]+ exhaustive <- mapM+ (\releases -> do+ checked <- runPlan False (zip packages $ Just <$> releases) specs+ pure (length $ Plan.planProblems checked, length $ filter (== "3.0") releases)) combinations+ solved <- runPlan True [(package, Just "2.0") | package <- packages] specs+ let cost = length $ filter (== version "3.0") $ Map.elems $ Plan.planVersions solved+ (length $ Plan.planProblems solved, cost) `shouldBe` minimum exhaustive+ it "expands recursively and checks reverse dependencies of added targets" $ do result <- runPlan True [("alpha", Just "2.0")] [ ("alpha", [], [("2.0", lib ["bravo >=2"])]),@@ -625,14 +864,11 @@ checked <- mapM (\versions -> do result <- runPlan False (zip packages $ Just <$> versions) specs- pure (length $ filter (== "3.0") versions, Plan.planIsReady result))+ pure (length $ Plan.planProblems result, length $ filter (== "3.0") versions)) combinations solved <- runPlan True [(package, Just "2.0") | package <- packages] specs- let costs = [cost | (cost, True) <- checked]- Plan.planIsReady solved `shouldBe` not (null costs)- if null costs- then length (Plan.planProblems solved) `shouldSatisfy` (> 0)- else length (filter (== version "3.0") $ Map.elems $ Plan.planVersions solved) `shouldBe` minimum costs+ let cost = length $ filter (== version "3.0") $ Map.elems $ Plan.planVersions solved+ (length $ Plan.planProblems solved, cost) `shouldBe` minimum checked it "searches beyond supplied minimum versions without jumping to the latest" $ do result <- runPlan True [("alpha", Just "2.0"), ("bravo", Just "2.0")]@@ -755,7 +991,8 @@ output `shouldContain` "base 1.0 -> 2.0" output `shouldNotContain` "ghc-prim 1.0 -> 1.0" output `shouldNotContain` "template-haskell 1.0 -> 1.0"- output `shouldContain` "Commit message:\nghc 9.6.7\n\ngenrebuild -H --ignore ghc-static ghc"+ output `shouldContain` "Commit message:\nghc 9.6.7\n\ngenrebuild -H ghc"+ output `shouldNotContain` "--ignore" it "hides the bundled summary when all library versions are unchanged" $ do let releases = Map.adjust (Map.insert (name "base") (version "1.0")) (version "9.6.7") toolchainReleases@@ -838,6 +1075,115 @@ assertBlocked result "rdep: haskell-consumer" Plan.planVersions result `shouldBe` Map.singleton (name "ghc") (version "9.6.7") + it "keeps the best partial compiler plan despite impossible bounds" $ do+ let consumers = ["consumer" <> show index | index <- [1 .. 8 :: Int]]+ specs = ("stuck", [], [("1.0", lib ["base <2"])]) :+ [(consumer, [], [("1.0", lib ["base <2"]), ("1.1", lib ["base >=2"])]) | consumer <- consumers]+ result <- runToolchainPlan True [("ghc", Nothing)] specs+ assertBlocked result "rdep: haskell-stuck"+ Plan.planVersions result `shouldBe` Map.fromList ((name "ghc", version "9.6.7") : [(name consumer, version "1.1") | consumer <- consumers])+ length (Plan.planProblems result) `shouldBe` 1+ Plan.plansTried result `shouldSatisfy` (<= 12)+ show (Plan.prettyPlanResult result) `shouldContain` "Full-solution conflicts (not additional blockers in the partial plan):"++ it "prunes dozens of dominated compiler patches after repairing the first plan" $ do+ let consumers = ["consumer" <> show index | index <- [1 .. 8 :: Int]]+ specs = ("stuck", [], [("1.0", lib ["base <2"])]) :+ [(consumer, [], [("1.0", lib ["base <2"]), ("1.1", lib ["base >=2"])]) | consumer <- consumers]+ releases = Map.fromList+ [(compiler, Map.insert (name "ghc") compiler $ toolchainReleases Map.! version "9.6.7") |+ patch <- [1 .. 48 :: Int], let compiler = version $ "9.8." <> show patch]+ (extra, raw) = toolchainFixture specs+ result <- requireResult =<< runDBWithToolchains releases Nothing Map.empty True [("ghc", Nothing)] extra raw+ Plan.planVersions result `shouldBe` Map.fromList ((name "ghc", version "9.8.1") : [(name consumer, version "1.1") | consumer <- consumers])+ length (Plan.planProblems result) `shouldBe` 1+ Plan.plansTried result `shouldSatisfy` (<= 3)++ it "does not prune a later patch which changes a compiler conditional" $ do+ let releases = Map.fromList+ [(compiler, Map.insert (name "ghc") compiler $ toolchainReleases Map.! version "9.6.7") |+ patch <- [1 .. 48 :: Int], let compiler = version $ "9.8." <> show patch]+ (extra, raw) = toolchainFixture+ [("consumer", [], [("1.0", ["library", " if impl(ghc >=9.8.40)", " build-depends: base >=2", " else", " build-depends: base <2"])])]+ result <- requireResult =<< runDBWithToolchains releases Nothing Map.empty True [("ghc", Nothing)] extra raw+ assertWorking result [("ghc", "9.8.40")]+ Plan.plansTried result `shouldBe` 2++ forM_+ [ ["executable tool", " main-is: Main.hs"],+ ["test-suite checks", " type: exitcode-stdio-1.0", " main-is: Test.hs"],+ ["library helper"]+ ] $ \component ->+ it ("reevaluates compiler conditionals in " <> head component) $ do+ result <- runToolchainPlan True [("ghc", Nothing)]+ [("consumer", [], [("1.0", component <> [" if impl(ghc >=9.6.7 && <9.8)", " build-depends: missing", " else", " build-depends: base >=1"])])]+ assertWorking result [("ghc", "9.8.1")]++ it "reduces failures even when a dependency cannot be repaired completely" $ do+ let specs = [("consumer", [], [("1.0", lib ["base <2"] <>+ ["test-suite spec", " type: exitcode-stdio-1.0", " main-is: Spec.hs", " build-depends: base <1.5"]),+ ("1.1", lib ["base <2"])])]+ checked <- runToolchainPlan False [("ghc", Nothing)] specs+ length (Plan.planProblems checked) `shouldBe` 2+ result <- runToolchainPlan True [("ghc", Nothing)] specs+ assertBlocked result "consumer requires base"+ Plan.planVersions result `shouldBe` Map.fromList [(name "ghc", version "9.6.7"), (name "consumer", version "1.1")]+ length (Plan.planProblems result) `shouldBe` 1++ it "keeps compiler alternatives consistent when minimizing remaining failures" $ do+ result <- runToolchainPlan True [("ghc", Nothing)]+ [ ("alpha", [], [("1.0", ["library", " if impl(ghc >=9.8 && <9.8.2)",+ " build-depends: base >=3", " else", " build-depends: base <2"])]),+ ("bravo", [], [("1.0", ["library", " if impl(ghc >=9.6.7)",+ " build-depends: base >=4", " else", " build-depends: base >=1"])])+ ]+ assertBlocked result "haskell-bravo"+ Plan.planVersions result `shouldBe` Map.singleton (name "ghc") (version "9.8.1")+ length (Plan.planProblems result) `shouldBe` 1++ it "agrees with exhaustive partial search across compiler and package versions" $ do+ let specs =+ [ ("stuck", [], [("1.0", lib ["base <2"])]),+ ("consumer", [], [("1.0", lib ["base <2", "helper >=1"]),+ ("1.1", lib ["base >=2", "helper >=2"]), ("2.0", lib ["base >=3", "helper >=1"])]),+ ("helper", [], [("2.0", [])])+ ]+ compilers = ["9.6.7", "9.8.1", "9.8.2"]+ consumers = ["1.0", "1.1", "2.0"]+ helpers = ["1.0", "2.0"]+ combinations = [(compilerCost + consumerCost + helperCost, compiler, consumer, helper) |+ (compilerCost, compiler) <- zip [0 :: Int ..] compilers,+ (consumerCost, consumer) <- zip [0 ..] consumers, (helperCost, helper) <- zip [0 ..] helpers]+ exhaustive <- mapM+ (\(cost, compiler, consumer, helper) -> do+ checked <- runToolchainPlan False [("ghc", Just compiler), ("consumer", Just consumer), ("helper", Just helper)] specs+ pure (length $ Plan.planProblems checked, cost)) combinations+ solved <- runToolchainPlan True [("ghc", Nothing), ("consumer", Just "1.0"), ("helper", Just "1.0")] specs+ let cost = sum [index | (package, releases) <- [("ghc", compilers), ("consumer", consumers), ("helper", helpers)],+ (index, release) <- zip [0 :: Int ..] releases, Plan.planVersions solved Map.! name package == version release]+ (length $ Plan.planProblems solved, cost) `shouldBe` minimum exhaustive++ it "does not use installed versions below requested minimums to dismiss compiler conflicts" $ do+ result <- runToolchainPlan True [("ghc", Nothing), ("consumer", Just "2.0")]+ [("consumer", [], [("1.0", lib ["base >=1"]), ("2.0", lib ["base <2"])])]+ assertBlocked result "dep: consumer requires base"+ Plan.plansTried result `shouldBe` 1+ show (Plan.prettyPlanResult result) `shouldContain` "Full-solution conflicts (not additional blockers in the partial plan):"++ it "allows combined compiler, owner, and dependency updates when checking conflicts" $ do+ result <- runToolchainPlan True [("ghc", Nothing)]+ [ ("consumer", [], [("1.0", lib ["base <2"]),+ ("1.1", ["library", " if impl(ghc >=9.8)", " build-depends: helper >=2", " else", " build-depends: base <2"])]),+ ("helper", [], [("2.0", [])])+ ]+ assertWorking result [("ghc", "9.8.1"), ("consumer", "1.1"), ("helper", "2.0")]++ it "allows a standalone library after a later compiler stops bundling it" $ do+ let releases = Map.adjust (Map.insert (name "os-string") (version "2.0")) (version "9.6.7") toolchainReleases+ (extra, raw) = toolchainFixture [("consumer", [], [("1.0", lib ["os-string <2"])]), ("os-string", [], [])]+ result <- requireResult =<< runDBWithToolchains releases Nothing Map.empty True [("ghc", Nothing)] extra raw+ assertWorking result [("ghc", "9.8.1")]+ it "does not retain libraries removed from the compiler bundle" $ do result <- runToolchainPlan False [("ghc", Nothing)] [("consumer", [], [("1.0", lib ["libiserv >=1"])]), ("libiserv", [], [])]@@ -978,6 +1324,16 @@ runPlan solve targets specs = do let (extra, raw) = fixture specs requireResult =<< runDB solve targets extra raw++capturePlanTrace :: Bool -> IO String+capturePlanTrace debug = do+ temporary <- getTemporaryDirectory+ bracket (openBinaryTempFile temporary "arch-hs-plan-debug") (\(path, handle) -> hClose handle >> removeFile path) $ \(path, handle) -> do+ runM . runPlanTrace debug handle $ do+ trace "Internal dependency trace"+ tracePlan "Checking candidate..."+ hClose handle+ B8.unpack <$> B8.readFile path runRevisionPlan :: Bool -> [(String, Maybe String)] -> Fixture -> Fixture -> IO Plan.PlanResult runRevisionPlan solve targets latest original = do