diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,17 @@ +# Changelog + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), +and versions follow the [Haskell PVP](https://pvp.haskell.org/), as described in +[CONTRIBUTING.md](https://github.com/tweag/pubgrub-hs/blob/main/CONTRIBUTING.md). +Every package of the repository has the version of the release; a package's own +changelog lists the changes under its directory. + +## [0.1.0.0] - 2026-11-06 + +First release. + +[0.1.0.0]: https://github.com/tweag/pubgrub-hs/releases/tag/v0.1.0.0 + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright 2026 Tweag I/O by Modus Create + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation and/or +other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors +may be used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS “AS IS” +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,24 @@ +# pubgrub-cabal + +The cabal domain for the [`pubgrub`][pubgrub] solver: a package name or one of +its automatic flags is a variable, an installed unit or a source release is a +value, a dependency's declared range is one symbolic set of instances, and the +leaves of every proof are what the request asks for, what a `.cabal` file states, +and what the compiler and the machine rule out. + +- `PubGrub.Cabal` is the variables and the facts; `PubGrub.Cabal.Value` and + `PubGrub.Cabal.InstanceSet` are the values and their sets. +- `PubGrub.Cabal.Flatten` reads a `GenericPackageDescription` into the solver's + input, with the machine passed in as plain data. +- `PubGrub.Cabal.Installed` is the installed package set and its unit graph. +- `PubGrub.Cabal.Provider.mkExpand` is the rule that picks an instance of a + package and states what it entails, over a `ReleaseSource` the caller + supplies. `releaseOf` reduces a `GenericPackageDescription` to the `Release` + a source reads. +- `PubGrub.Cabal.Report` prints a failed resolution as a proof in cabal's + range syntax. + +Of the cabal ecosystem it depends on `Cabal-syntax` only. The Hackage index, +the compiler and the installed database are the caller's to supply. + +[pubgrub]: https://hackage.haskell.org/package/pubgrub diff --git a/pubgrub-cabal.cabal b/pubgrub-cabal.cabal new file mode 100644 --- /dev/null +++ b/pubgrub-cabal.cabal @@ -0,0 +1,110 @@ +cabal-version: 3.0 +name: pubgrub-cabal +version: 0.1.0.0 +synopsis: The PubGrub version solver for cabal packages +description: + The cabal domain for the @pubgrub@ solver: a package name or one of its + automatic flags is a variable, an installed unit or a source release is a + value, a dependency's declared range is one symbolic set of instances, and + the leaves of every proof are what the request asks for, what a @.cabal@ + file states, and what the compiler and the machine rule out. + + It provides the translation from @GenericPackageDescription@ and an + installed package set into the solver's input (@PubGrub.Cabal.Flatten@, + @PubGrub.Cabal.Installed@), the rule that picks an instance of a package + and states what it entails (@PubGrub.Cabal.Provider@), and the renderer + that prints a failed resolution as a proof in cabal's range syntax + (@PubGrub.Cabal.Report@). Of the cabal ecosystem it needs @Cabal-syntax@ + only: the index, the compiler and the installed database are the caller's + to supply. +category: Distribution +license: BSD-3-Clause +license-file: LICENSE +author: Andrea Bedini +maintainer: andrea.bedini@moduscreate.com +copyright: (c) 2026 Tweag I/O by Modus Create +homepage: https://github.com/tweag/pubgrub-hs +bug-reports: https://github.com/tweag/pubgrub-hs/issues +build-type: Simple +tested-with: GHC ==9.12.2 || ==9.14.1 +extra-doc-files: + CHANGELOG.md + README.md + +-- The expected proofs for the two error-reporting cases in test/PaperSpec.hs, +-- shipped so that the test suite runs from the sdist. They are golden files so +-- that each can be read as the proof a user would see, and +-- `cabal test --test-options=--accept` rewrites them when the wording changes on +-- purpose. +extra-source-files: test/golden/*.txt + +source-repository head + type: git + location: https://github.com/tweag/pubgrub-hs.git + subdir: pubgrub-cabal + +common warnings + ghc-options: -Wall + +common language + default-language: GHC2021 + default-extensions: ImportQualifiedPost + +library + import: warnings, language + hs-source-dirs: src + exposed-modules: + PubGrub.Cabal + PubGrub.Cabal.Flatten + PubGrub.Cabal.Installed + PubGrub.Cabal.InstanceSet + PubGrub.Cabal.PreInstalled + PubGrub.Cabal.Pretty + PubGrub.Cabal.Provider + PubGrub.Cabal.Report + PubGrub.Cabal.Report.Headline + PubGrub.Cabal.Report.Layout + PubGrub.Cabal.Report.Rule + PubGrub.Cabal.Report.Wording + PubGrub.Cabal.Value + + PubGrub.Cabal.Version + PubGrub.Cabal.VersionSet + build-depends: + , base >=4.21 && <4.23 + , Cabal-syntax >=3.14 && <3.20 + , co-log-core >=0.3.2 && <0.4 + , containers >=0.7 && <0.9 + , pubgrub ^>=0.1 + , text >=2.1 && <2.2 + +test-suite pubgrub-cabal-test + import: warnings + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + default-language: GHC2021 + other-modules: + ConstraintSpec + FlagSolveSpec + InstalledSpec + InstanceSetSpec + PaperSpec + ReleaseSpec + ReportSpec + SolverSpec + StoreSpec + VersionSetSpec + build-depends: + , base + , Cabal-syntax + , co-log-core + , bytestring + , containers + , pubgrub + , pubgrub-cabal + , tasty >=1.5 && <1.6 + , tasty-golden >=2.3 && <2.4 + , tasty-hunit >=0.10 && <0.11 + , tasty-quickcheck >=0.11 && <0.12 + , text diff --git a/src/PubGrub/Cabal.hs b/src/PubGrub/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/PubGrub/Cabal.hs @@ -0,0 +1,402 @@ +{-# LANGUAGE TypeFamilies #-} + +-- | The cabal domain: the solver instantiated for cabal packages. +-- +-- A variable is a package name or one automatic flag of a package; a value is +-- an instance (a pre-installed unit or a source release) or a Boolean, and a set +-- of values is a set of instances or a set of Booleans ("PubGrub.Cabal.Value"). +-- The facts are what a @.cabal@ file states, what this machine rules out and +-- what the request asks for. The provider states facts through the constructors +-- here, and the domain's 'mergeRule' rebuilds a merged clause through them, so a +-- clause's cause agrees with its terms. What the solver learns from the facts is +-- the core's own 'Cause'. +module PubGrub.Cabal + ( -- * Variables + Flag (..) + , Var (..) + , varPackage + -- * Facts + , CabalFact (..) + , Guard + , UnbuildableReason (..) + -- * Constructors + , request + , constraint + , flagConstraint + , onlyInstalled + , unbuildable + , fromDependency + , declaresFlag + -- * The answer + , foldFlags + ) where + +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Text as T +import Distribution.Types.Flag (FlagName, + insertFlagAssignment, + mkFlagAssignment) +import Distribution.Types.PackageName (PackageName) +import Distribution.Types.PkgconfigDependency (PkgconfigDependency) +import PubGrub.Cabal.InstanceSet (Instance (..), + InstanceSet) +import PubGrub.Cabal.Pretty () +import PubGrub.Cabal.Value (Resolved (..), + Value (..), ValueSet, + boolSet, bothValues, + flagSet, instanceSet, + singletonValue) +import PubGrub.Cabal.Version (Version) +import PubGrub.Incompatibility (Cause (..), + Domain (..), + Incompatibility (..), + MergeRule (MergeRule), + fact, seed) +import PubGrub.Pretty (Pretty (..)) +import PubGrub.SetOps (SetOps (..)) +import PubGrub.Term (Term (..)) + +-- -------------------------------------------------------------------------- +-- Variables +-- -------------------------------------------------------------------------- + + +-- | A flag as a @.cabal@ file declares it: a name and a default. The @manual@ +-- marking is not here because a manual flag never reaches the solver: it is +-- resolved at its default when a release is flattened. +-- +-- A flag variable is identified by this /declaration/, not by the release that +-- declares it. Two releases that declare @fast@ with the same default share the +-- variable, so a guarded dependency they both carry can be stated once over +-- both, as one incompatibility over adjacent versions; a release that changed +-- the default declares a different flag and gets a variable of its own. At most +-- one release of a package is ever in a plan, so the shared variable is always +-- that release's flag. Carrying the default in the identity lets the provider +-- offer it first from the variable alone, without knowing which release was +-- decided. +data Flag = Flag + { flagName :: FlagName + , flagDefault :: Bool + } + deriving (Eq, Ord, Show) + +-- | A solver variable. +data Var + = PackageVar PackageName + | FlagVar PackageName Flag + -- ^ an automatic flag of the package, searched alongside its version + deriving (Eq, Ord, Show) + +-- | The package a variable belongs to: itself, or the owner of the flag. +varPackage :: Var -> PackageName +varPackage (PackageVar p) = p +varPackage (FlagVar p _) = p + +instance Pretty Flag where + pretty = pretty . flagName + +-- | @foo@, or @foo:fast@ for a flag. The set a flag term ranges over says on or +-- off; the variable alone only says which flag. +instance Pretty Var where + pretty (PackageVar p) = pretty p + pretty (FlagVar p f) = pretty p <> T.pack ":" <> pretty f + +-- -------------------------------------------------------------------------- +-- The domain +-- -------------------------------------------------------------------------- + +-- | The domain of cabal packages: its variables are 'Var', a package or a +-- flag, and that type names the instantiation, as in @t'Incompatibility' Var@. +instance Domain Var where + type ValueOf Var = Value + type SetOf Var = ValueSet + type FactOf Var = CabalFact + + singleton _ = singletonValue + + mergeRule = MergeRule mergeParts mergeBuild + +-- -------------------------------------------------------------------------- +-- Facts +-- -------------------------------------------------------------------------- + +-- | The flags a dependency holds under, each with the value it needs. Empty for +-- an unconditional dependency. Every flag is one of the depender's own. +type Guard = Map Flag Bool + +-- | What a leaf of a cabal proof says. The two seeds are stated as +-- 'Seed's, the rest as 'Fact's; the solver's own leaf — no release in a +-- range — is the core's 'NoValues', and a derived step is its 'Derived'. +data CabalFact + = CauseRequest PackageName InstanceSet -- request + | CauseOnlyInstalled PackageName [Version] -- onlyInstalled + | CauseUnbuildable PackageName InstanceSet Guard (NonEmpty UnbuildableReason) -- unbuildable + | CauseDependency PackageName InstanceSet Guard (PackageName, InstanceSet) -- fromDependency + | CauseDeclaresFlag PackageName InstanceSet Flag -- declaresFlag + | CauseConstraint Var ValueSet -- constraint: the set allowed + +-- | Why a release's library cannot be built on this machine: one entry per +-- thing that rules it out, read off the library's @BuildInfo@ at the flag +-- assignment in force. A release can carry several — two missing @pkg-config@ +-- modules, say — and the proof names each, which is why the cause holds a +-- non-empty list rather than one reason. +-- +-- The @pkg-config@ dependency is kept whole, name and range, so the proof can +-- spell it as the @.cabal@ did. +data UnbuildableReason + = NotBuildable + -- ^ the library declares @buildable: False@ + | MissingPkgConfig PkgconfigDependency + -- ^ a @pkgconfig-depends@ this machine's @pkg-config@ cannot satisfy + deriving (Eq, Ord, Show) + +-- -------------------------------------------------------------------------- +-- Constructors +-- -------------------------------------------------------------------------- + +-- | A seed: what the solve is asked for. It is impossible for @p@ to be +-- /outside/ @s@, which forces @p@ into the plan at an instance in @s@. One per +-- target. The PubGrub algorithm opens with one incompatibility on a synthetic +-- root package; this states the request directly instead, so no package stands +-- in front of the targets to be printed, planned and filtered out again. +-- +-- A seed is a unit clause, so propagation turns it into a derivation at decision +-- level 0 before anything is decided; "PubGrub.Solver" recognises a conflict that +-- rests on those derivations alone as the end of the search. +request :: PackageName -> InstanceSet -> Incompatibility Var +request p s = seed (CauseRequest p s) (PackageVar p) (Negative (instanceSet s)) + +-- | A constraint: if @v@ is in the plan at all, it is in @allowed@. It is +-- impossible for @v@ to be in @forbidden@, the complement of @allowed@ in the +-- variable's universe: +-- +-- @{ v: Positive forbidden }@ +-- +-- The other seed. A 'request' forces its package /into/ the plan; a constraint +-- says nothing about whether the package is chosen, only what it may be if it is +-- — @cabal build --constraint@, a @constraints:@ stanza, and a lock entry a +-- planner holds at its version. Propagation turns it into the level-0 derivation +-- @Negative forbidden@, which is \"absent, or in @allowed@\", so a package nobody +-- depends on is left alone; and because it is a seed, a conflict that rests on +-- it together with the requests is terminal ('PubGrub.Solver.solve'), and the +-- proof closes on \"@v@ is constrained to @allowed@\". +-- +-- Both sets are taken because the core's set operations have no complement: a +-- package's universe holds the installed units of the compiler, which only the +-- provider side knows. 'PubGrub.Cabal.Provider.constrainTo' computes the +-- complement from a 'PubGrub.Cabal.Installed.InstalledDb'; 'flagConstraint' is +-- the two-valued case, which needs nothing. +constraint :: Var -> ValueSet -> ValueSet -> Incompatibility Var +constraint v allowed forbidden = seed (CauseConstraint v allowed) v (Positive forbidden) + +-- | A flag held at a value: @p:f@ is @b@ if it is in play at all. A 'constraint' +-- over the flag's own variable, as a user's @--constraint 'p +f'@ is. +flagConstraint :: PackageName -> Flag -> Bool -> Incompatibility Var +flagConstraint p f b = + constraint (FlagVar p f) (flagSet (boolSet b)) (flagSet (boolSet (not b))) + +-- | A package that may not be built from source at all: only an already-installed +-- unit of it can be selected. The term is /every source instance/ — any version +-- — so the clause forbids the whole source side of the package at once. +-- +-- This is a fact about the world rather than about a range, which is why it has +-- its own cause. Rendered as 'NoValues' it would read \"no version for base in +-- >=0\", which is false-sounding and unhelpful: there are plenty of versions of +-- @base@, and the reason none may be used is that the compiler provides it. +-- +-- The installed versions are there for the proof only. The clause bans the +-- source side and says nothing about the installed units, but a reader of +-- \"@base@ cannot be built from source\" has to know which @base@ /is/ installed +-- to see why a bound on it fails; cabal's message names it too +-- (@base-4.21.0.0\/installed-5b43@). An empty list is a boot package with no +-- installed unit at all, and the proof says that instead. +-- +-- The provider states it for the non-reinstallable boot packages +-- ('PubGrub.Cabal.Installed.nonReinstallablePackages'); the core only needs the +-- shape. +onlyInstalled :: PackageName -> [Version] -> InstanceSet -> Incompatibility Var +onlyInstalled p installed anySource = + fact (CauseOnlyInstalled p installed) [(PackageVar p, Positive (instanceSet anySource))] + +-- | Instances that cannot be built in this environment, and so must never be +-- selected. This is the PubGrub algorithm's rule for a version that cannot be +-- selected: instead of its dependencies, state an incompatibility saying that +-- it, and any adjacent versions that cannot be selected either, should never be +-- selected. +-- +-- @{ p: Positive instances, f₁: Positive {b₁}, … }@ +-- +-- The guard is the flags the verdict holds under, as for 'fromDependency': a +-- @pkgconfig-depends@ or a @buildable: False@ inside a flag-guarded block of the +-- library rules out the flag values that reach it, not the release. With the +-- release decided and one of the guard's flags open, propagation derives the +-- other value for that flag, and the release stays in the plan under it. An +-- empty guard is the unconditional case: the release is never selected, and +-- the provider states it instead of the release's dependencies. +-- +-- It is stated rather than the release silently skipped because of the report: +-- a release that is merely absent leaves the solver to discover that its range +-- is empty, which reads as \"no version for foo in …\" when the versions exist +-- and cannot be built here. +-- +-- The adjacent versions are not gathered here. The domain's 'mergeRule' merges two of +-- these facts about the same package under the same guard and with the same +-- reasons into one clause over the union of their instances, and when the +-- instances are adjacent release slots the union is one contiguous range. Two +-- runs ruled out for different reasons stay two facts, so the proof never +-- attributes one release's missing module to another. +-- +-- The reasons are there for the proof only, like the installed versions of +-- 'onlyInstalled': the clause's terms are the ban, and the reasons are what the +-- sentence says instead of a bare \"cannot be built\". The sentence gives them +-- sorted, not in the order of the @.cabal@. +unbuildable :: PackageName -> InstanceSet -> Guard -> NonEmpty UnbuildableReason -> Incompatibility Var +unbuildable p s guard why = + fact + (CauseUnbuildable p s guard (NE.nub (NE.sort why))) + ( (PackageVar p, Positive (instanceSet s)) + : [(FlagVar p f, Positive (flagSet (boolSet b))) | (f, b) <- Map.toList guard] + ) + +-- | Dependency incompatibility: @package@ in @instances@, with each flag of +-- @guard@ at the value it names, requires @dep@ in @depSet@: +-- +-- @{ package: Positive instances, f₁: Positive {b₁}, …, dep: Negative depSet }@ +-- +-- The guard's terms are /positive/: they are antecedents, like the depender's +-- own term, and a positive singleton over a flag is \"the flag is in play and has +-- this value\". With the depender decided and the dependee out of range, unit +-- propagation derives @Negative {b}@ for the one open flag — \"absent or the +-- other value\" — and the owner's standing 'declaresFlag' clause narrows that to +-- the other value. With the flags in place instead, it derives the dependee's +-- range. An empty guard is an unconditional dependency, the common case. +-- +-- A guard is a conjunction. A disjunctive @.cabal@ condition is several of +-- these, one per disjunct, each of which implies the dependency on its own. +-- +-- If @depSet@ is empty the dependency is unsatisfiable and its term is always +-- true, so it is left out, leaving a ban on the depender under the guard. +-- +-- When @package == dep@, a __self-dependency__, both terms are about one +-- variable, and since an incompatibility is a conjunction of its terms they +-- must be /intersected/, which is why the map is built with 'Map.fromListWith' +-- and not 'Map.fromList': @intersectTerm (Positive V) (Negative R) = +-- Positive (V \\ R)@, exactly \"no instance of p in @V@ falls outside its own +-- requirement @R@\". Keeping only one of the two terms would be wrong: +-- @{p: Negative R}@ alone asserts \"p must be in R\" of every instance of @p@ +-- rather than of those in @V@. The provider states a release's dependency on its +-- own package only when the range excludes that release, as a ban on it. +fromDependency :: PackageName -> InstanceSet -> Guard -> PackageName -> InstanceSet -> Incompatibility Var +fromDependency pkgName pkgSet guard depName depSet = + fact + (CauseDependency pkgName pkgSet guard (depName, depSet)) + ( (PackageVar pkgName, Positive (instanceSet pkgSet)) + : (PackageVar depName, Negative (instanceSet depSet)) + : [(FlagVar pkgName f, Positive (flagSet (boolSet b))) | (f, b) <- Map.toList guard] + ) + +-- | A release declares an automatic flag: @package@ in @instances@ requires the +-- flag to be in play, at either value: +-- +-- @{ package: Positive instances, flag: Negative {False, True} }@ +-- +-- This is what makes a flag a goal — propagation derives a positive term for +-- it the moment its owner is decided, and the provider is then asked to decide +-- it, offering the declared default first. Nothing else ever derives a positive +-- term for a flag, so a flag is only ever decided while a release declaring it +-- is decided, and a learned clause that mentions it under a wider term about +-- the owner is inert for the owner's other releases. +declaresFlag :: PackageName -> InstanceSet -> Flag -> Incompatibility Var +declaresFlag p s f = + fact + (CauseDeclaresFlag p s f) + [ (PackageVar p, Positive (instanceSet s)) + , (FlagVar p f, Negative (flagSet bothValues)) + ] + +-- -------------------------------------------------------------------------- +-- Merging +-- -------------------------------------------------------------------------- + +-- | What has to match for two clauses to be merged. +-- +-- Three shapes qualify. A dependency fact ('MergeDep') matches on the depender +-- package, the dependee package, the guard, and the __dependee instance set__, +-- which must be identical rather than merely overlapping. A flag declaration +-- ('MergeDeclares') matches on the package and the flag. An unbuildable fact +-- ('MergeUnbuildable') matches on the package, the guard and the __reasons__: +-- there is no dependee term to agree about, and two of them giving the same +-- reasons under the same flags are the same fact about two runs of releases; +-- merging them is how the adjacent versions of 'unbuildable' are gathered. +-- Merging two runs ruled out for different reasons would put one release's +-- missing module on the other's range in the proof. 'unbuildable' keeps the +-- reasons sorted and without repeats, so their order in the @.cabal@ does not +-- keep two identical facts apart. +-- +-- The dependee set is compared with 'Eq', which 'InstanceSet' has lawfully: +-- both of its halves are canonical. The depender term is in no key: it is what +-- the merge grows. +data MergeKey + = MergeDep PackageName PackageName Guard InstanceSet + -- ^ a dependency fact merges only with one under the /same/ guard, so + -- the guard's terms are identical on both sides and the union argument + -- in 'PubGrub.Store' holds term for term + | MergeDeclares PackageName Flag + -- ^ two releases declaring the same flag: one clause over both + | MergeUnbuildable PackageName Guard (NonEmpty UnbuildableReason) + deriving (Eq, Ord) + +-- | The key and the depender set of a clause that may take part in a merge: a +-- dependency fact, a flag declaration or an unbuildable fact. +-- +-- A clause is keyed by its /cause/ rather than by its term map, because the +-- term map may have lost what is needed: 'fromDependency' drops the dependee +-- entry when the dependency is unsatisfiable, and the unit ban that remains does +-- not say which dependee it came from. The cause still names it, so two such +-- clauses about the same dependee merge. +mergeParts :: Incompatibility Var -> Maybe (MergeKey, InstanceSet) +mergeParts i = case incompCause i of + Fact (CauseDependency p s g (q, depSet)) -> Just (MergeDep p q g depSet, s) + Fact (CauseDeclaresFlag p s f) -> Just (MergeDeclares p f, s) + Fact (CauseUnbuildable p s g why) -> Just (MergeUnbuildable p g why, s) + _ -> Nothing + +-- | The clause of a key over a depender set, rebuilt through the constructor of +-- its kind so that the cause stays a leaf cause with the unioned term +-- ('PubGrub.Store' says why that matters). +mergeBuild :: MergeKey -> InstanceSet -> Incompatibility Var +mergeBuild (MergeDep p q g depSet) s = fromDependency p s g q depSet +mergeBuild (MergeDeclares p f) s = declaresFlag p s f +-- Two unit clauses banning instances of the same package: ¬(p ∈ A) and +-- ¬(p ∈ B) is ¬(p ∈ A∪B), so the union claims nothing new. Slots touch, so for +-- runs of adjacent unbuildable releases the union is one contiguous range, which +-- is what references/pubgrub.md:476 asks to be stated. +mergeBuild (MergeUnbuildable p g why) s = unbuildable p s g why + +-- -------------------------------------------------------------------------- +-- The answer +-- -------------------------------------------------------------------------- + +-- | Fold the solver's answer into one entry per package: each decided flag +-- goes into the flag assignment of its owner, which must be a source release. +-- A flag whose owner is not in the answer, or not built from source, is dropped; +-- neither can happen, since a flag is only ever decided under its owner. +foldFlags :: Map Var Value -> Map PackageName Resolved +foldFlags decided = Map.foldrWithKey fold owners decided + where + owners = + Map.fromList + [ (p, resolved i) + | (PackageVar p, PackageValue i) <- Map.toList decided + ] + resolved (UsePreInstalled pip) = Installed pip + resolved (BuildSource v) = Built v (mkFlagAssignment []) + fold (FlagVar p f) (FlagValue b) = Map.adjust (withFlag f b) p + fold _ _ = id + withFlag f b (Built v fa) = Built v (insertFlagAssignment (flagName f) b fa) + withFlag _ _ r = r diff --git a/src/PubGrub/Cabal/Flatten.hs b/src/PubGrub/Cabal/Flatten.hs new file mode 100644 --- /dev/null +++ b/src/PubGrub/Cabal/Flatten.hs @@ -0,0 +1,850 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} + +-- | Extract a GenericPackageDescription's dependencies as a function of its +-- flag assignment, without Cabal's @finalizePD@ (which also does dependency +-- resolution and flag defaulting we don't want). +-- +-- The conditional dependency tree is flattened to 'GuardedDeps' — a list of +-- @(flag guard, deps)@ groups — with the fixed environment (operating system, +-- architecture, compiler) already resolved and only flag conditions left +-- symbolic. 'depsAt' then evaluates those guards at a concrete flag assignment. +-- +-- == What a /guard/ is +-- +-- A /guard/ is the flag condition attached to a group of dependencies: the +-- @if@ of a @.cabal@ file, after the parts that do not depend on flags have been +-- evaluated away. Given this library stanza, on a non-Windows platform: +-- +-- > library +-- > build-depends: base >=4.14, containers +-- > +-- > if flag(simd) +-- > build-depends: simd-utils ==0.3 +-- > else +-- > build-depends: fallback-impl >=1 +-- > +-- > if os(windows) && flag(fast) +-- > build-depends: win-fast-io +-- +-- 'componentDeps' yields these groups, whose first components are the guards: +-- +-- > (Lit True, [base >=4.14, containers]) +-- > (Var simd, [simd-utils ==0.3]) +-- > (CNot (Var simd), [fallback-impl >=1]) +-- +-- and a fourth, @(Lit False, [win-fast-io])@: the @os(windows)@ block keeps a +-- guard that no flag assignment satisfies, so it never contributes. +-- +-- Four properties, each relied on elsewhere: +-- +-- * /Flags only/. @envConfVar@ resolves operating system, architecture and +-- compiler to a concrete boolean and leaves only @PackageFlag@ symbolic, so a +-- guard is always a formula over flag /names/. +-- * /A formula, not a flag/. @flag(a) && !flag(b)@ is one guard mentioning two +-- flags. Do not picture one flag per guard. +-- * /Accumulated down the tree/. @flattenWith@ starts at @Lit True@ and +-- pushes conditions down: the @if@ branch gets @guard \`cAnd\` cond@, the +-- @else@ branch @guard \`cAnd\` cNot cond@. A dependency nested two levels deep +-- carries both conditions conjoined; nesting produces a longer formula, not +-- nested structure. +-- * /Per release, not per package/. A guard comes from one @.cabal@ file, so it +-- mentions only flags /that/ release declares, and evaluating it for that +-- release never meets an undeclared flag. +-- +-- Note @Lit True@ is a real guard, not the absence of one: every component has an +-- unconditional block and its guard is exactly @Lit True@. +-- +-- == One walk, two entry points +-- +-- Everything is read off the __pre-environment form__, t'StoredRelease': the +-- component trees as the @.cabal@ file wrote them, with the environment's +-- conditions unresolved and each node reduced to what is ever consulted. The +-- description-taking functions ('componentDeps', 'buildableCondition', …) go +-- through 'toStored' and the @Stored@ ones take the form directly, which is what a +-- derived index keeps; so the two cannot disagree, because they are one walk +-- rather than two kept in step. +-- +-- Terminology, since what the solver may be told turns on the difference: +-- +-- * a /flag/ is a declared name with a default; +-- * a /guard/ is a boolean formula over flag names; +-- * a /guarded dependency occurrence/ is one guard paired with /one/ +-- dependency, the unit an incompatibility may be built from; +-- * 'GuardedDeps' is the whole flat list for a release. +-- +-- The same package may appear under several guards (an unconditional @q >=1@ and +-- a guarded @q <3@). 'depsAt' intersects those into one range, which is right for +-- one release at one assignment; a fact for the solver is built from one guarded +-- occurrence, never from that intersection. +module PubGrub.Cabal.Flatten ( + GuardedDeps, + Stanzas (..), + noStanzas, + allStanzas, + componentDeps, + componentDepsAtDefaults, + buildableCondition, + PkgConfigPresent, + unbuildableAtDefaults, + depsAt, + flattenDeps, + defaultFlags, + expandGuard, + prettyMap, + parseCondition, + Guard, + + -- * The pre-environment form + -- + -- | What a @.cabal@ parse yields once everything the /environment/ decides is + -- still undecided: the conditional trees as they were written, with + -- 'ConfVar' conditions unresolved. This is the form a derived index stores, + -- because parsing is 106x the cost of flattening and only the flatten + -- depends on the machine (@envConfVar@ resolves @os@\/@arch@\/@impl@, and + -- 'buildableCondition' additionally resolves @pkgconfig-depends@). + StoredRelease (..), + LibNode (..), + Node (..), + Tree (..), + Branch (..), + toStored, + componentDepsAtDefaultsStored, + FlagModel (..), + componentDepsStored, + componentToolsStored, + unbuildableStored, + unbuildableAtDefaultsStored, + + -- * Build tools and setup dependencies + GuardedTools, + componentTools, + componentToolsAtDefaults, + toolsAt, + desugarBuildTool, + setupDeps, +) where + +import Control.Applicative (Alternative (..)) +import Data.Bool (bool) +import Data.Char (isAlphaNum, + toLower) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Merge.Strict as Map +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes, + fromMaybe, + mapMaybe, + maybeToList) +import Distribution.Compat.CharParsing (CharParsing (..), + between, munch1, + sepByNonEmpty, + spaces) +import qualified Distribution.Compat.CharParsing as P +import Distribution.Compiler (CompilerId (..), + CompilerInfo, + compilerInfoId) +import Distribution.PackageDescription.Configuration (addBuildableCondition) +import Distribution.Parsec (CabalParsing, + Parsec (..)) +import Distribution.System (Platform (..)) +import Distribution.Types.Benchmark (Benchmark (benchmarkBuildInfo)) +import Distribution.Types.BuildInfo (BuildInfo (..)) +import Distribution.Types.Condition (Condition (..), + cAnd, cNot, + simplifyCondition) +import Distribution.Types.CondTree (CondBranch (..), + CondTree (..)) +import Distribution.Types.ConfVar (ConfVar (..)) +import Distribution.Types.Dependency (Dependency, + depPkgName, + depVerRange) +import Distribution.Types.Executable (Executable (buildInfo)) +import Distribution.Types.ExeDependency (ExeDependency (..)) +import Distribution.Types.Flag (FlagAssignment, + FlagName, + PackageFlag (..), + lookupFlagAssignment, + mkFlagName, + unFlagName) +import Distribution.Types.ForeignLib (ForeignLib (foreignLibBuildInfo)) +import Distribution.Types.GenericPackageDescription (GenericPackageDescription (..)) +import Distribution.Types.LegacyExeDependency (LegacyExeDependency (..)) +import Distribution.Types.Library (Library (..)) +import Distribution.Types.PackageDescription (PackageDescription (..)) +import Distribution.Types.PackageId (PackageIdentifier (..)) +import Distribution.Types.PackageName (PackageName, + mkPackageName) +import Distribution.Types.PkgconfigDependency (PkgconfigDependency (..)) +import Distribution.Types.SetupBuildInfo (SetupBuildInfo (..)) +import Distribution.Types.TestSuite (TestSuite (testBuildInfo)) +import Distribution.Types.UnqualComponentName (UnqualComponentName, + mkUnqualComponentName) +import Distribution.Version (withinRange) +import GHC.Generics (Generic) +import PubGrub.Cabal (UnbuildableReason (..)) +import PubGrub.Cabal.VersionSet (VersionSet) +import qualified PubGrub.Cabal.VersionSet as VS + +-- | A condition over a package's flags alone, the environment resolved away. +type Guard = Condition FlagName + +-- | A package's dependencies as flag-guarded groups: each dependency list is +-- active exactly when its 'Condition' over flag names holds. The environment +-- (OS, arch, compiler) is already resolved away, so guards mention only flags. +type GuardedDeps = [(Guard, [Dependency])] + +-- | What this machine's @pkg-config@ answers for a @pkgconfig-depends@: whether a +-- module of that name is present in a version the range admits. +-- +-- A predicate rather than a database so that the caller decides where the answer +-- comes from — cabal's own @pkg-config@ database, a list in a test, a tool's own +-- reading of @pkg-config@ — and this module needs nothing but @Cabal-syntax@. +-- __No @pkg-config@ executable is @const False@__, not @const True@: that is +-- cabal's reading of the same situation (its solver rejects every +-- @pkgconfig-depends@ when there is no database), and a missing module still has +-- to be named in the proof. +type PkgConfigPresent = PkgconfigDependency -> Bool + +-- | Which optional stanzas a reduction reads beside the four components cabal +-- includes unconditionally (library, sub-libraries, foreign libraries, +-- executables): the test suites, the benchmarks, both or neither. +-- +-- In cabal's own vocabulary these are /optional stanzas/: a test +-- suite or benchmark is behind a stanza that a plain @cabal build@ never +-- enables, and a planner enables it __per package__ — @cabal test@ resolves the +-- test suites of the local packages and never those of their dependencies. So +-- the choice is made where a release is reduced, by whoever reduces it, and a +-- solve for a build plan passes 'noStanzas' for every release. What the stanzas +-- add is read the same way as the rest: flag-guarded, gated on their own +-- @buildable:@ (@gateOnBuildable@), their build tools alongside +-- ('componentTools'). A test suite's dependency on its own package's library +-- is an intra-package edge, resolved inside the package, so the provider rule +-- drops it, as it does for an executable, unless its range excludes the release. +data Stanzas = Stanzas + { withTests :: Bool + , withBenchmarks :: Bool + } + deriving (Eq, Show) + +-- | The four unconditional components only: a release as a dependency. +noStanzas :: Stanzas +noStanzas = Stanzas{withTests = False, withBenchmarks = False} + +-- | The test suites and the benchmarks too: a local package under @cabal test@ +-- and @cabal bench@. +allStanzas :: Stanzas +allStanzas = Stanzas{withTests = True, withBenchmarks = True} + +-- | Resolve the fixed environment: OS, arch and compiler conditions become +-- concrete @Right@ booleans. +-- +-- What becomes of a /flag/ condition is the caller's choice, and it is the only +-- difference between 'componentDeps' (@Left@, symbolic) and +-- 'componentDepsAtDefaults' (@Right@, resolved). +envConfVar + :: (FlagName -> Either FlagName Bool) + -> Platform + -> CompilerInfo + -> ConfVar + -> Either FlagName Bool +envConfVar flagEnv (Platform arch os) compiler = \case + OS o -> Right (o == os) + Arch a -> Right (a == arch) + Impl flavor range -> + let CompilerId f v = compilerInfoId compiler + in Right (f == flavor && withinRange v range) + PackageFlag f -> flagEnv f + +-- | Evaluate a flag-only condition. A flag not present in the assignment +-- defaults to 'False' (guards only mention declared flags, so a total +-- assignment always covers them). +evalCond :: FlagAssignment -> Condition FlagName -> Bool +evalCond flags = go + where + go (Var f) = fromMaybe False (lookupFlagAssignment f flags) + go (Lit b) = b + go (CNot c) = not (go c) + go (COr a b) = go a || go b + go (CAnd a b) = go a && go b + +-- -------------------------------------------------------------------------- +-- The conditional tree +-- -------------------------------------------------------------------------- + +-- | One component's conditional tree, in the shape the @.cabal@ file wrote it: +-- a node's own fields, then its @if@ blocks, each with an optional @else@. +-- +-- Cabal-syntax's own @CondTree@ with the node reduced to what this module ever +-- reads. It is ours rather than Cabal-syntax's for two reasons. It is what a +-- derived index stores, and a stored form keyed to another package's type +-- changes shape with that package — Cabal-syntax 3.18 dropped @CondTree@'s +-- constraints parameter, which is the one this module read. And it keeps the +-- node's dependencies where Cabal-syntax keeps them, on the @BuildInfo@: that +-- parameter was only ever a copy of @targetBuildDepends@ (the parser filled it +-- from there, and cabal's solver reads the field in 3.18 where it read the copy +-- before), so reading the field is the same answer on either side of the +-- change. @fromCondTree@ is the one place the Cabal-syntax version is +-- consulted. +data Tree a = Tree + { treeData :: a + , treeBranches :: [Branch a] + } + deriving (Eq, Show, Generic, Functor) + +-- | An @if@ block: its condition, the tree under it, and the @else@ tree if +-- there is one. The condition is over 'ConfVar', unresolved: resolving +-- @os@\/@arch@\/@impl@ is the walk's business (@flattenWith@), not the tree's. +data Branch a = Branch + { branchCondition :: Condition ConfVar + , branchIfTrue :: Tree a + , branchIfFalse :: Maybe (Tree a) + } + deriving (Eq, Show, Generic, Functor) + +#if MIN_VERSION_Cabal_syntax(3,18,0) +type CabalTree a = CondTree ConfVar a +#else +type CabalTree a = CondTree ConfVar [Dependency] a +#endif + +-- | Cabal-syntax's tree as ours, with each node reduced by @f@. The only +-- function in the package that depends on which Cabal-syntax it was built +-- against. +fromCondTree :: (a -> b) -> CabalTree a -> Tree b +#if MIN_VERSION_Cabal_syntax(3,18,0) +fromCondTree f (CondNode x branches) = Tree (f x) (map branch branches) +#else +fromCondTree f (CondNode x _constraints branches) = Tree (f x) (map branch branches) +#endif + where + branch (CondBranch cond ifTrue ifFalse) = + Branch cond (fromCondTree f ifTrue) (fmap (fromCondTree f) ifFalse) + +-- | Walk one component's conditional tree, pushing each branch condition (with +-- the environment resolved) down as an accumulated flag guard, and taking @at@ +-- from every node along the way. +-- +-- What is taken is a parameter because several different things are read off +-- the same tree in the same shape: the @build-depends@ ('componentDeps'), the +-- build tools ('componentTools'), and what decides whether the node can be built +-- here at all ('buildableCondition'). One walk, described once. +flattenWith + :: (ConfVar -> Either FlagName Bool) + -> (a -> b) + -> Tree a + -> [(Guard, b)] +flattenWith env at = go (Lit True) + where + go guard (Tree x branches) = + (guard, at x) : concatMap (goBranch guard) branches + goBranch guard (Branch cond ifTrue mIfFalse) = + let (cond', _free) = simplifyCondition cond env + whenTrue = go (guard `cAnd` cond') ifTrue + whenFalse = maybe [] (go (guard `cAnd` cNot cond')) mIfFalse + in whenTrue ++ whenFalse + +-- | Flatten the library, sub-library, foreign-library and executable conditional +-- dependency trees to flag-guarded groups, resolving OS\/arch\/compiler conditions +-- against the given platform and compiler. +-- +-- Those four are exactly the components cabal's solver includes unconditionally. +-- Test-suites and benchmarks are read only when the t'Stanzas' ask for them, as +-- they are there: cabal puts them behind a stanza that a plain @cabal build@ +-- never enables, so a solve for a build plan does not drag in a package's own +-- test dependencies, and a planner enables them per local package. +-- +-- __A component that is not buildable contributes nothing__, and the gate is +-- Cabal-syntax's own 'addBuildableCondition', the function cabal's solver pipes +-- every component through as well. It rewrites a tree to @if then +-- @, to the empty tree where @buildable:@ is statically @False@, and leaves +-- it alone where it is statically @True@; so the condition joins the guards +-- already being accumulated and costs nothing where nothing is conditional. +-- +-- Without it a dependency would be read out of a stanza that is never built. +-- @http2-5.4.4@'s @hpack-encode@ declares @aeson >=2@ and closes with +-- @if flag(devel) … else buildable: False@; with @devel@ off the stanza is not +-- built, and its @aeson >=2@ must not constrain a solve that includes @http2@. +-- +-- The /library's/ buildability is deliberately not gated here. It is a stronger +-- fact — an unbuildable library makes the whole release unusable, not merely +-- dependency-free — and 'unbuildableStored' already carries it to the solver +-- with the reason attached, which is what lets a proof name the missing +-- @pkg-config@ module. +componentDeps :: Stanzas -> Platform -> CompilerInfo -> GenericPackageDescription -> GuardedDeps +componentDeps stanzas platform compiler = depsWith Left stanzas platform compiler . toStored + +-- | 'componentDeps' with every flag resolved at its __declared default__: flags +-- are parsed and applied, but treated as manual, so none of them is a search +-- dimension. +-- +-- The result is still a 'GuardedDeps', and deliberately so — nothing downstream +-- changes shape. Every guard folds to a literal (@simplifyCondition@ has no free +-- variables left, and @cAnd@\/@cNot@ collapse literals), and 'expandGuard' already +-- maps those two literals to exactly what is wanted: +-- +-- * @Lit True@ becomes @[Map.empty]@: one disjunct with /no/ pins, so the +-- dependency is stated with no flag term; +-- * @Lit False@ becomes @[]@: no disjunct, so the dead branch is discarded rather +-- than carried. +-- +-- So no flag becomes a solver variable, and each release is planned under its +-- defaults. +-- +-- An /undeclared/ flag named by a condition resolves to 'False', matching the +-- convention @evalCond@ documents. It should not arise — a guard mentions only +-- flags its own release declares. +-- +-- This is what cabal's own solver does with a flag marked manual: it pins it to +-- the same 'flagDefault'. +componentDepsAtDefaults :: Stanzas -> Platform -> CompilerInfo -> GenericPackageDescription -> GuardedDeps +componentDepsAtDefaults stanzas platform compiler = componentDepsAtDefaultsStored stanzas platform compiler . toStored + +-- | The guarded dependencies of a stored release, with each flag resolved as +-- @flagEnv@ says. +depsWith + :: (FlagName -> Either FlagName Bool) + -> Stanzas + -> Platform + -> CompilerInfo + -> StoredRelease + -> GuardedDeps +depsWith flagEnv stanzas platform compiler sr = + concat [flattenWith env nodeDeps t | t <- componentTrees stanzas sr] + where + env = envConfVar flagEnv platform compiler + +-- | Cabal-syntax's 'addBuildableCondition', named for what it does here: put a +-- component's dependencies under the condition that the component is buildable. +-- Taking the function from Cabal-syntax rather than restating it is the same rule +-- the @pkg-config@ predicate follows — a paraphrase is a second implementation to +-- keep in step. +gateOnBuildable + :: Monoid a + => (a -> BuildInfo) + -> CabalTree a + -> CabalTree a +gateOnBuildable = addBuildableCondition + +-- | Evaluate the guards at a concrete flag assignment and merge the resulting +-- dependency ranges (intersecting duplicate constraints on the same package). +depsAt :: FlagAssignment -> GuardedDeps -> Map PackageName VersionSet +depsAt flags guarded = + Map.fromListWith + VS.intersectionVersionSet + [ (depPkgName d, VS.fromVersionRange (depVerRange d)) + | (guard, deps) <- guarded + , evalCond flags guard + , d <- deps + ] + +-- | Each declared flag mapped to its default value. +defaultFlags :: GenericPackageDescription -> Map FlagName Bool +defaultFlags gpd = Map.fromList [(flagName f, flagDefault f) | f <- genPackageFlags gpd] + +-- | Under what condition on its flags this release's __library__ can be built on +-- this machine. +-- +-- Two things make a node unusable, and both are read off its @BuildInfo@: +-- @buildable: False@, and a @pkgconfig-depends@ this machine cannot satisfy. A +-- node under guard @C@ that is unusable means the release requires @not C@, so the +-- answer is the conjunction of @not C@ over every unusable node — @Lit True@ when +-- there are none. +-- +-- == Why this is a condition and not a boolean +-- +-- @pkg-config@ is a /constant/ of the machine, like OS and arch: the solver does +-- not choose it, so it can be resolved once rather than searched. But what it +-- resolves to is not "buildable" or "not buildable" — it is a statement about +-- which /flag assignments/ remain, because @pkgconfig-depends@ lives inside +-- flag-guarded blocks: +-- +-- > if flag(pkg-config) +-- > pkgconfig-depends: zlib-any +-- +-- 'unbuildableAtDefaults' evaluates this at the declared defaults, keeping the +-- reasons. A search over flags does not evaluate it: 'unbuildableStored' keeps +-- each unusable node's guard, so only the flag values that reach the node are +-- ruled out. +-- +-- == Why the library only +-- +-- A dependency needs the library; an unbuildable executable does not make the +-- package unusable as a dependency. Note this is deliberately narrower than +-- 'componentDeps', which does collect executables' dependencies — that +-- over-approximates, and over-approximating /buildability/ would exclude releases +-- rather than merely constrain them. +-- +-- == No @pkg-config@ executable means @const False@ +-- +-- Not "assume satisfied". See 'PkgConfigPresent': that is cabal's reading of the +-- same situation, and a caller that builds the predicate from cabal's own +-- database answers exactly as cabal would. +buildableCondition + :: PkgConfigPresent + -> Platform + -> CompilerInfo + -> GenericPackageDescription + -> Condition FlagName +buildableCondition db platform compiler gpd = + foldr cAnd (Lit True) $ + [ cNot guard + | (guard, isBuildable, pcs) <- libraryNodes platform compiler (toStored gpd) + , not (null (unusable db isBuildable pcs)) + ] + +-- | Why the release's library cannot be built here at its declared defaults — +-- the question to ask while flags are treated as manual. Empty means it can. +-- +-- This is 'buildableCondition' evaluated at the defaults, with the reasons kept +-- instead of folded away: a node whose guard holds at the defaults contributes +-- whatever makes it unusable, in tree order. @null@ of the result is exactly the +-- condition's value at the defaults, since a node is unusable when and only when +-- it gives a reason. +unbuildableAtDefaults + :: PkgConfigPresent + -> Platform + -> CompilerInfo + -> GenericPackageDescription + -> [UnbuildableReason] +unbuildableAtDefaults db platform compiler = unbuildableAtDefaultsStored db platform compiler . toStored + +-- | The library's nodes with what decides their buildability: the guard, the +-- @buildable@ field, and the @pkgconfig-depends@. +libraryNodes + :: Platform + -> CompilerInfo + -> StoredRelease + -> [(Guard, Bool, [PkgconfigDependency])] +libraryNodes platform compiler sr = + [ (guard, lnBuildable ln, lnPkgConfig ln) + | tree <- maybeToList (srLibrary sr) + , (guard, ln) <- flattenWith env id tree + ] + where + env = envConfVar Left platform compiler + +-- | What makes one node unusable: @buildable: False@, and each @pkgconfig-depends@ +-- the machine's @pkg-config@ cannot satisfy. Empty when the node is usable. +-- +-- The reason names the module, which is what the reader has to install either +-- way, whether the machine lacks it or lacks @pkg-config@ itself. +unusable :: PkgConfigPresent -> Bool -> [PkgconfigDependency] -> [UnbuildableReason] +unusable present isBuildable pcs = + [NotBuildable | not isBuildable] + ++ [MissingPkgConfig d | d <- pcs, not (present d)] + +-- | Dependencies of a package version at a flag assignment, as a version-set +-- map. (Convenience: 'depsAt' over 'componentDeps'.) +flattenDeps :: Stanzas -> Platform -> CompilerInfo -> FlagAssignment -> GenericPackageDescription -> Map PackageName VersionSet +flattenDeps stanzas platform compiler flags gpd = + depsAt flags (componentDeps stanzas platform compiler gpd) + +-- | A guard in disjunctive normal form: a list of partial flag assignments +-- whose disjunction is the guard. A flag an assignment does not mention is +-- free, and the disjuncts may overlap. @[]@ means the guard never holds; +-- @[Map.empty]@ means it always holds. +expandGuard :: Condition FlagName -> [Map FlagName Bool] +expandGuard = go + where + go (Var f) = [Map.singleton f True] + go (Lit b) = [Map.empty | b] + go (COr a b) = go a ++ go b + go (CAnd a b) = catMaybes + [ Map.mergeA + Map.preserveMissing + Map.preserveMissing + (Map.zipWithAMatched (\_ a' b' -> if a' == b' then Just a' else Nothing)) + x y + | x <- go a + , y <- go b + ] + go (CNot (Var f)) = [Map.singleton f False] + go (CNot (Lit b)) = [Map.empty | not b] + go (CNot (CAnd a b)) = go (COr (CNot a) (CNot b)) + go (CNot (COr a b)) = go (CAnd (CNot a) (CNot b)) + go (CNot (CNot c)) = go c + +-- | A condition over flags in @.cabal@ syntax, such as @flag(a) && !flag(b)@. +parseCondition :: CabalParsing m => m (Condition FlagName) +parseCondition = condOr + where + condOr = foldl1 COr <$> sepByNonEmpty condAnd (oper "||") + condAnd = foldl1 CAnd <$> sepByNonEmpty cond (oper "&&") + cond = sp >> (flagCond <|> boolLiteral <|> inparens condOr <|> notCond) + inparens = between (P.char '(' >> sp) (sp >> P.char ')' >> sp) + notCond = CNot <$> (P.char '!' >> sp >> cond) + flagCond = Var <$> (string "flag" >> sp >> inparens flagIdent) + boolLiteral = Lit <$> parsec + flagIdent = mkFlagName . map toLower <$> munch1 isIdentChar + isIdentChar c = isAlphaNum c || c == '_' || c == '-' + oper s = sp >> string s >> sp + sp = spaces + +-- | The assignments of 'expandGuard' as text, such as @{+a -b}@. +prettyMap :: [Map FlagName Bool] -> String +prettyMap = unwords . map (\m -> "{" ++ unwords [ bool "-" "+" b ++ unFlagName f | (f, b) <- Map.toList m ] ++ "}") + +-- >>> import Distribution.Parsec (explicitEitherParsec) +-- >>> test s = either error (prettyMap . expandGuard) (explicitEitherParsec parseCondition s) +-- >>> test "flag(a) && !flag(b)" +-- "{+a -b}" +-- >>> test "True" +-- "{}" +-- >>> test "False" +-- "" +-- >>> test "flag(a) || flag(b)" +-- "{+a} {+b}" +-- >>> test "flag(a) && flag(b)" +-- "{+a +b}" +-- >>> test "flag(a) && !flag(b)" +-- "{+a -b}" +-- >>> test "!(flag(a) && flag(b))" +-- "{-a} {-b}" +-- >>> test "!(flag(a) || flag(b))" +-- "{-a -b}" + + +-- -------------------------------------------------------------------------- +-- Build tools and setup dependencies +-- -------------------------------------------------------------------------- + +-- | A release's build-tool dependencies as flag-guarded groups, the shape of +-- 'GuardedDeps': each t'ExeDependency' names the package, the executable and the +-- range, as @build-tool-depends@ writes it. +-- +-- __Not a dependency of the release in this solver's eyes__, and kept out of +-- 'GuardedDeps' on purpose. A build tool runs at build time and its dependencies +-- never reach the code it generates, so cabal solves it in a namespace of its +-- own, and a planner over this solver does the same with a solve of its own, +-- seeded from this list and preferring the main plan's choices +-- ('PubGrub.Cabal.Provider.Preference'). The main solve reads nothing here. +-- +-- What is in the list is what cabal's own solver keeps: @build-tool-depends@ as +-- written, plus the legacy @build-tools@ names cabal knows how to translate +-- ('desugarBuildTool'), minus a dependency on one of the release's own +-- executables, which is internal and no solver's business. +type GuardedTools = [(Guard, [ExeDependency])] + +-- | Cabal's @Distribution.Simple.BuildToolDepends.desugarBuildToolSimple@, +-- restated because that module is in @Cabal@ and this package is Cabal-syntax +-- only. A legacy @build-tools@ name is one of the release's own executables, or +-- one of eight tools known to be the executable of a package of the same name, or +-- nothing a solver can act on: a program found on the @PATH@ at configure time. +-- The eight are those of Cabal 3.16 and later, which dropped @greencard@. +desugarBuildTool :: PackageName -> [UnqualComponentName] -> LegacyExeDependency -> Maybe ExeDependency +desugarBuildTool self exes (LegacyExeDependency name range) + | tool `elem` exes = Just (ExeDependency self tool range) + | name `elem` allowlist = Just (ExeDependency (mkPackageName name) tool range) + | otherwise = Nothing + where + tool = mkUnqualComponentName name + allowlist = ["hscolour", "haddock", "happy", "alex", "hsc2hs", "c2hs", "cpphs", "hspec-discover"] + +-- | The build tools one node declares that are another package's. +toolsOf :: PackageName -> [UnqualComponentName] -> BuildInfo -> [ExeDependency] +toolsOf self exes bi = + [ d + | d@(ExeDependency p _ _) <- buildToolDepends bi ++ mapMaybe (desugarBuildTool self exes) (buildTools bi) + , p /= self + ] + +-- | The release's build tools, flag-guarded, read off the same component +-- trees as 'componentDeps' — the same t'Stanzas' choice — and gated on +-- buildability the same way. +componentTools :: Stanzas -> Platform -> CompilerInfo -> GenericPackageDescription -> GuardedTools +componentTools stanzas platform compiler = toolsWith Left stanzas platform compiler . toStored + +-- | 'componentTools' with every flag at its declared default. +componentToolsAtDefaults :: Stanzas -> Platform -> CompilerInfo -> GenericPackageDescription -> GuardedTools +componentToolsAtDefaults stanzas platform compiler = componentToolsStored FixedFlags stanzas platform compiler . toStored + +-- | The guarded build tools of a stored release, with each flag resolved as +-- @flagEnv@ says. +toolsWith + :: (FlagName -> Either FlagName Bool) + -> Stanzas + -> Platform + -> CompilerInfo + -> StoredRelease + -> GuardedTools +toolsWith flagEnv stanzas platform compiler sr = + concat [flattenWith env nodeTools t | t <- componentTrees stanzas sr] + where + env = envConfVar flagEnv platform compiler + +-- | The build tools in force at a flag assignment: 'depsAt' for 'GuardedTools', +-- without the merge, since a tool is named rather than ranged over. A dead +-- branch (a guard that folded to @Lit False@) is dropped here, as 'depsAt' and +-- 'expandGuard' drop it for dependencies. +toolsAt :: FlagAssignment -> GuardedTools -> [ExeDependency] +toolsAt flags guarded = [d | (guard, ds) <- guarded, evalCond flags guard, d <- ds] + +-- | The release's @setup-depends@: the dependencies of its @Setup.hs@, which is +-- never linked against the release's library and is solved in a namespace of its +-- own, like a build tool. Unconditional, as Cabal-syntax keeps it. Empty for a +-- @build-type@ that is not @Custom@ or @Hooks@, or that declares none. +setupDeps :: GenericPackageDescription -> [Dependency] +setupDeps gpd = maybe [] setupDepends (setupBuildInfo (packageDescription gpd)) + +ownName :: GenericPackageDescription -> PackageName +ownName = pkgName . package . packageDescription + +ownExecutables :: GenericPackageDescription -> [UnqualComponentName] +ownExecutables gpd = [n | (n, _) <- condExecutables gpd] + +-- -------------------------------------------------------------------------- +-- The pre-environment form +-- -------------------------------------------------------------------------- + +-- | The bits of a library node's @BuildInfo@ that are ever consulted: its +-- dependencies, what decides buildability, and the build tools. Nothing else is +-- kept. +data LibNode = LibNode + { lnDeps :: [Dependency] + , lnBuildable :: Bool + , lnPkgConfig :: [PkgconfigDependency] + , lnTools :: [ExeDependency] + } + deriving (Eq, Show, Generic) + +-- | What is kept of any other component's node: its dependencies and its build +-- tools. Buildability is already in the guards (@gateOnBuildable@). +data Node = Node + { nodeDeps :: [Dependency] + , nodeTools :: [ExeDependency] + } + deriving (Eq, Show, Generic) + +-- | One release, parsed and no further. Each t'Tree' is the @.cabal@ file's own, +-- so the resolvers over them are the existing walk rather than a paraphrase of it. +data StoredRelease = StoredRelease + { srFlags :: [(FlagName, Bool)] + , srManual :: [FlagName] + -- ^ the flags declared @manual: True@, which stay at their defaults even + -- when automatic flags are searched + , srLibrary :: Maybe (Tree LibNode) + , srOthers :: [Tree Node] + -- ^ the sub-libraries, foreign libraries and executables, each gated on its + -- own buildability + , srTests :: [Tree Node] + -- ^ the test suites, gated likewise; read only under 'withTests' + , srBenchmarks :: [Tree Node] + -- ^ the benchmarks, gated likewise; read only under 'withBenchmarks' + , srSetup :: [Dependency] + -- ^ 'setupDeps' + } + deriving (Eq, Show, Generic) + +-- | Reduce a parsed description to the form a derived index stores. +toStored :: GenericPackageDescription -> StoredRelease +toStored gpd = + StoredRelease + { srFlags = [(flagName f, flagDefault f) | f <- genPackageFlags gpd] + , srManual = [flagName f | f <- genPackageFlags gpd, flagManual f] + , srLibrary = fromCondTree libNode <$> condLibrary gpd + , srOthers = + [other libBuildInfo t | (_, t) <- condSubLibraries gpd] + ++ [other foreignLibBuildInfo t | (_, t) <- condForeignLibs gpd] + ++ [other buildInfo t | (_, t) <- condExecutables gpd] + , srTests = [other testBuildInfo t | (_, t) <- condTestSuites gpd] + , srBenchmarks = [other benchmarkBuildInfo t | (_, t) <- condBenchmarks gpd] + , srSetup = setupDeps gpd + } + where + tools = toolsOf (ownName gpd) (ownExecutables gpd) + libNode lib = + let bi = libBuildInfo lib + in LibNode + { lnDeps = targetBuildDepends bi + , lnBuildable = buildable bi + , lnPkgConfig = pkgconfigDepends bi + , lnTools = tools bi + } + other bi = fromCondTree (node . bi) . gateOnBuildable bi + node bi = Node{nodeDeps = targetBuildDepends bi, nodeTools = tools bi} + +-- | The component trees a reduction reads, as one shape: the library, then +-- the sub-libraries, foreign libraries and executables, then the optional +-- stanzas asked for, tests before benchmarks. +componentTrees :: Stanzas -> StoredRelease -> [Tree Node] +componentTrees stanzas sr = + [fmap asNode t | t <- maybeToList (srLibrary sr)] + ++ srOthers sr + ++ (if withTests stanzas then srTests sr else []) + ++ (if withBenchmarks stanzas then srBenchmarks sr else []) + where + asNode ln = Node{nodeDeps = lnDeps ln, nodeTools = lnTools ln} + +-- | 'componentDepsAtDefaults' over a stored release. +componentDepsAtDefaultsStored :: Stanzas -> Platform -> CompilerInfo -> StoredRelease -> GuardedDeps +componentDepsAtDefaultsStored = componentDepsStored FixedFlags + +-- | Which flags the solver searches. +data FlagModel + = FixedFlags + -- ^ every flag at its declared default ('componentDepsAtDefaultsStored') + | FlagPackages + -- ^ each automatic flag is a solver variable of its own; manual flags + -- stay at their defaults + deriving (Eq, Show) + +-- | What a flag resolves to under a model. Under 'FixedFlags' every flag is its +-- default. Under 'FlagPackages' a manual flag is its default and only an +-- automatic flag stays symbolic, so a guard reaching the provider names +-- automatic flags only. A flag the release does not declare is 'False' under +-- either, the convention @evalCond@ documents. +storedFlagEnv :: FlagModel -> StoredRelease -> FlagName -> Either FlagName Bool +storedFlagEnv model sr f + | model == FlagPackages, Map.member f defaults, f `notElem` srManual sr = Left f + | otherwise = Right (Map.findWithDefault False f defaults) + where + defaults = Map.fromList (srFlags sr) + +-- | The guarded dependencies of a stored release under a flag model. +componentDepsStored :: FlagModel -> Stanzas -> Platform -> CompilerInfo -> StoredRelease -> GuardedDeps +componentDepsStored model stanzas platform compiler sr = + depsWith (storedFlagEnv model sr) stanzas platform compiler sr + +-- | The guarded build tools of a stored release under a flag model +-- ('componentTools'). +componentToolsStored :: FlagModel -> Stanzas -> Platform -> CompilerInfo -> StoredRelease -> GuardedTools +componentToolsStored model stanzas platform compiler sr = + toolsWith (storedFlagEnv model sr) stanzas platform compiler sr + +-- | Why, and under which flags, a stored release's library cannot be built +-- here: one entry per unusable library node, with its guard resolved under the +-- flag model and its reasons in tree order. A node under a dead branch is +-- dropped. +-- +-- Under 'FixedFlags' every guard folds to a literal, so each entry's guard is +-- @Lit True@ and the whole is the verdict 'unbuildableAtDefaults' gives. Under +-- 'FlagPackages' an entry whose guard names an automatic flag is a verdict +-- about the flag values that reach the node, and the provider states it as a +-- guarded unit clause over the release ('PubGrub.Cabal.unbuildable') rather +-- than ruling the release out. +unbuildableStored + :: FlagModel + -> PkgConfigPresent + -> Platform + -> CompilerInfo + -> StoredRelease + -> [(Guard, NonEmpty UnbuildableReason)] +unbuildableStored model db platform compiler sr = + [ (guard, why) + | tree <- maybeToList (srLibrary sr) + , (guard, ln) <- flattenWith env id tree + , guard /= Lit False + , Just why <- [NE.nonEmpty (unusable db (lnBuildable ln) (lnPkgConfig ln))] + ] + where + env = envConfVar (storedFlagEnv model sr) platform compiler + +-- | 'unbuildableAtDefaults' over a stored release: 'unbuildableStored' under +-- 'FixedFlags', where every guard left is @Lit True@, flattened to its reasons. +unbuildableAtDefaultsStored + :: PkgConfigPresent -> Platform -> CompilerInfo -> StoredRelease -> [UnbuildableReason] +unbuildableAtDefaultsStored db platform compiler sr = + concat [NE.toList why | (_, why) <- unbuildableStored FixedFlags db platform compiler sr] diff --git a/src/PubGrub/Cabal/Installed.hs b/src/PubGrub/Cabal/Installed.hs new file mode 100644 --- /dev/null +++ b/src/PubGrub/Cabal/Installed.hs @@ -0,0 +1,172 @@ +-- | The installed (boot) package world, from a compiler's global package db. +-- +-- Indexes @[InstalledPkg]@ for what the provider needs of it: all installed +-- units of a package name, which become the 'UsePreInstalled' instances it may +-- offer ('installedInstancesOf'), and the unit graph, which says what choosing +-- one of them commits to ('closureEdges'). +module PubGrub.Cabal.Installed + ( InstalledPkg (..) + , InstalledDb(..) + , mkInstalledDb + , installedInstancesOf + , toPreInstalled + , InstalledEdge(..) + , closureEdges + , nonReinstallablePackages + , isNonReinstallable + ) where + + +import Data.Function (on) +import Data.List (nubBy) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Distribution.Types.PackageName (PackageName, mkPackageName) +import Distribution.Types.UnitId (UnitId) +import Distribution.Version (Version) +import PubGrub.Cabal.InstanceSet (Instance (..)) +import PubGrub.Cabal.PreInstalled (PreInstalledPackage (..)) +import PubGrub.Cabal.Version (fromCabalVersion) + +-- | One installed unit, reduced to what the solver models: its id, name, version +-- and direct dependencies. The compiler's own 'Version' type, since it is the +-- db's spelling; 'toPreInstalled' converts. +data InstalledPkg = InstalledPkg + { ipUnitId :: UnitId + , ipName :: PackageName + , ipVersion :: Version + , ipDepends :: [UnitId] + } + deriving (Eq, Show) + +-- | The installed units, indexed by unit id and by package name. +data InstalledDb = InstalledDb + { idbById :: Map UnitId InstalledPkg + , idbByName :: Map PackageName [InstalledPkg] + } + +-- | Index a list of units. A unit id listed more than once keeps its last +-- entry, in both indexes, so that the two always describe the same units. +mkInstalledDb :: [InstalledPkg] -> InstalledDb +mkInstalledDb pkgs = + InstalledDb + { idbById = byId + , idbByName = Map.fromListWith (++) [(ipName p, [p]) | p <- lastOfEach] + } + where + byId = Map.fromList [(ipUnitId p, p) | p <- pkgs] + -- In input order, so that the by-name lists keep the order they had. + lastOfEach = reverse (go Set.empty (reverse pkgs)) + go _ [] = [] + go seen (p : ps) + | Set.member (ipUnitId p) seen = go seen ps + | otherwise = p : go (Set.insert (ipUnitId p) seen) ps + +-- | The unit as the solver's value, in the solver's version type. +toPreInstalled :: InstalledPkg -> PreInstalledPackage +toPreInstalled p = + PreInstalledPackage + { pipUnitId = ipUnitId p + , pipVersion = fromCabalVersion (ipVersion p) + , pipDependencies = ipDepends p + } + +-- | Every installed unit of a package, as a 'UsePreInstalled' instance. +installedInstancesOf :: InstalledDb -> PackageName -> [Instance] +installedInstancesOf db p = + [UsePreInstalled (toPreInstalled u) | u <- Map.findWithDefault [] p (idbByName db)] + +-- -------------------------------------------------------------------------- +-- The unit graph +-- -------------------------------------------------------------------------- + +-- | One dependency edge between installed units. Both ends carry the package +-- name that names them as solver variables, since that is what an +-- incompatibility is keyed by. +data InstalledEdge = InstalledEdge + { ieFrom :: (PackageName, PreInstalledPackage) + , ieTo :: (PackageName, PreInstalledPackage) + } + deriving (Eq, Show) + +-- | Every dependency edge in the reflexive-transitive closure of a unit. +-- +-- An installed unit is a compiled artifact linked against exactly these units, +-- transitively: none of it is a search question. Emitting the whole edge set +-- when the unit is chosen lets unit propagation chain through the closure in a +-- single fixpoint, instead of learning one hop per decision. +-- +-- Each edge names its /own/ depender, not the unit the walk started from, so +-- every edge is a genuine direct dependency and reports about it stay true. +-- +-- Deterministic: depth-first in the order @ipDepends@ lists them, each unit +-- expanded once. The visited set keeps the walk finite on a cycle (GHC's db is +-- a DAG; this is defensive). An edge between two units of one package is +-- dropped, a unit depending on itself included: an incompatibility whose two +-- terms name the same package collapses to a single bogus term, which bans the +-- unit just chosen. The solver has one variable per package name, so a unit +-- of a package's sublibrary is not modelled as an instance of its own. +-- +-- A 'UnitId' absent from the db contributes no edge. That is vacuous for a db +-- read whole from the global package db, whose units depend only on each other, +-- and is where dependencies would go missing silently if a db were assembled from +-- several package dbs. +closureEdges :: InstalledDb -> UnitId -> [InstalledEdge] +closureEdges db root = go (Set.singleton root) (lookupUnit root) + where + go :: Set UnitId -> [InstalledPkg] -> [InstalledEdge] + go _ [] = [] + go seen (u : queued) = + let deps = nubBy ((==) `on` ipUnitId) (concatMap lookupUnit (ipDepends u)) + (seen', fresh) = foldl' enqueue (seen, []) deps + in [ InstalledEdge (named u) (named d) + | d <- deps + , ipName d /= ipName u + ] + ++ go seen' (reverse fresh ++ queued) + + enqueue (seen, acc) d + | Set.member (ipUnitId d) seen = (seen, acc) + | otherwise = (Set.insert (ipUnitId d) seen, d : acc) + + lookupUnit uid = maybe [] pure (Map.lookup uid (idbById db)) + named u = (ipName u, toPreInstalled u) + +-- | Packages that may only ever come from the installed db, never be built from a +-- Hackage release. +-- +-- Not a preference — an impossibility. These are tied to the compiler that produced +-- them: they override their unit id, or define wired-in declarations, or have no +-- buildable source distribution (cabal's own reasons). Planning to build one is +-- planning something that cannot happen. +-- +-- Cabal's own list, verbatim, so a plan made here never builds a package cabal +-- would refuse to build. The provider reads it through 'isNonReinstallable'. +-- +-- Deliberately a list of names rather than a derivation. How cabal decides +-- reinstallability is itself in flux, so anything cleverer would be tracking a moving +-- target; a snapshot that is obviously a snapshot is easier to check and to update. +-- Note @rts@ is /not/ on cabal's list even though it is equally unbuildable — kept +-- faithful rather than corrected, so that a plan made here and one made by +-- cabal agree on what may be built. +nonReinstallablePackages :: Set PackageName +nonReinstallablePackages = + Set.fromList + (map + mkPackageName + [ "base" + , "ghc-bignum" + , "ghc-internal" + , "ghc-prim" + , "ghc" + , "integer-gmp" + , "integer-simple" + , "template-haskell" + ]) + +-- | Is the package on the list of those that can only come from the compiler's +-- installed set? +isNonReinstallable :: PackageName -> Bool +isNonReinstallable = (`Set.member` nonReinstallablePackages) diff --git a/src/PubGrub/Cabal/InstanceSet.hs b/src/PubGrub/Cabal/InstanceSet.hs new file mode 100644 --- /dev/null +++ b/src/PubGrub/Cabal/InstanceSet.hs @@ -0,0 +1,124 @@ +-- | A package's instances, and sets of them. +-- +-- An instance is one concrete way of having a package: a specific pre-installed +-- unit, or a source release. Flags are not part of an instance: an automatic +-- flag is a solver variable of its own ('PubGrub.Cabal.FlagVar'), decided +-- beside the version, and a manual flag is fixed before the solver sees the +-- release. +-- +-- A set of instances has two halves, represented differently because they +-- differ in kind. The installed half is /extensional/: the installed database is +-- small and fully known, so it is a plain 'Set' of units. The source half is +-- /intensional/: a dependency's declared range admits versions the index may not +-- even have, so it is kept as one 'VersionSet', a range over versions rather +-- than a list of them, and never enumerated. Both halves are canonical, so the +-- set has a lawful 'Eq' and 'Ord', every operation is exact, and 'isEmpty' +-- answers both ways. +module PubGrub.Cabal.InstanceSet + ( HasVersion (..) + , Instance (..) + , InstanceSet (..) + , emptyInstanceSet + , sourceInstances + , singletonInstance + , memberInstance + , isEveryVersion + ) where + +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Text as T +import PubGrub.Cabal.PreInstalled (PreInstalledPackage (..)) +import PubGrub.Cabal.Pretty () +import PubGrub.Cabal.Version (Version) +import PubGrub.Cabal.VersionSet (VersionSet) +import qualified PubGrub.Cabal.VersionSet as VersionSet +import PubGrub.Pretty (Pretty (..)) +import PubGrub.SetOps (SetOps (..)) + +-- | A pre-installed unit carries a version, and so does an 'Instance' — this is +-- what lets the 'PubGrub.Provider.Provider' turn a @.cabal@ dependency's +-- 'VersionSet' into the corresponding set of instances. +class HasVersion a where + version :: a -> Version + +instance HasVersion PreInstalledPackage where + version = pipVersion + +-- | One concrete way of having a package. It /identifies/ that way and does not +-- describe it: it carries no dependencies, which come from the provider that +-- owns the index the identifier points into. +data Instance + = UsePreInstalled PreInstalledPackage + | BuildSource Version + deriving (Eq, Ord, Show) + +instance HasVersion Instance where + version (UsePreInstalled pip) = version pip + version (BuildSource v) = v + +instance Pretty Instance where + pretty (UsePreInstalled pip) = T.pack "installed:" <> pretty (pipUnitId pip) + pretty (BuildSource v) = pretty v + +-- | A set of 'Instance's of one package. +data InstanceSet = InstanceSet + { isInstalled :: Set PreInstalledPackage + -- ^ the pre-installed units in the set, extensionally + , isSource :: VersionSet + -- ^ the source releases in the set, as a range + } + deriving (Eq, Ord, Show) + +-- | Under union. +instance Semigroup InstanceSet where + (<>) = union + +instance SetOps InstanceSet where + empty = emptyInstanceSet + union a b = InstanceSet (isInstalled a `Set.union` isInstalled b) (isSource a `union` isSource b) + intersect a b = InstanceSet (isInstalled a `Set.intersection` isInstalled b) (isSource a `intersect` isSource b) + difference a b = InstanceSet (isInstalled a `Set.difference` isInstalled b) (isSource a `difference` isSource b) + isEmpty a = Set.null (isInstalled a) && isEmpty (isSource a) + isSubsetOf a b = isInstalled a `Set.isSubsetOf` isInstalled b && isSource a `isSubsetOf` isSource b + isDisjoint a b = isInstalled a `Set.disjoint` isInstalled b && isSource a `isDisjoint` isSource b + +-- | The empty instance set. @Negative emptyInstanceSet@ is the always-true +-- term ⊤; @Positive emptyInstanceSet@ is the never-true term ⊥. +emptyInstanceSet :: InstanceSet +emptyInstanceSet = InstanceSet Set.empty VersionSet.emptyVersionSet + +-- | The source releases in a range, and no installed unit. +sourceInstances :: VersionSet -> InstanceSet +sourceInstances = InstanceSet Set.empty + +-- | The set containing exactly one instance — the shape of a decision. +singletonInstance :: Instance -> InstanceSet +singletonInstance (UsePreInstalled pip) = InstanceSet (Set.singleton pip) VersionSet.emptyVersionSet +singletonInstance (BuildSource v) = sourceInstances (VersionSet.singletonVersionSet v) + +-- | Is the instance in the set? +memberInstance :: Instance -> InstanceSet -> Bool +memberInstance (UsePreInstalled pip) s = Set.member pip (isInstalled s) +memberInstance (BuildSource v) s = VersionSet.contains (isSource s) v + +-- | Does the set admit every source release of its package? True of an +-- unconstrained target's request and of a depender that spans the whole +-- version list. The report writes such a set as \"every version of foo\" +-- rather than \"foo any\". +isEveryVersion :: InstanceSet -> Bool +isEveryVersion s = isSource s == VersionSet.fullVersionSet + +instance Pretty InstanceSet where + pretty s = T.intercalate (T.pack " or ") (installed <> source) + where + -- An installed unit whose version the range admits is one of the range's + -- versions, and naming it separately tells a reader nothing. The unit id + -- is never shown: it is a hash, and the version is what a reader can act + -- on. + installed = + [ pretty (pipVersion pip) <> T.pack " (installed)" + | pip <- Set.toList (isInstalled s) + , not (VersionSet.contains (isSource s) (pipVersion pip)) + ] + source = [pretty (isSource s) | not (isEmpty (isSource s))] diff --git a/src/PubGrub/Cabal/PreInstalled.hs b/src/PubGrub/Cabal/PreInstalled.hs new file mode 100644 --- /dev/null +++ b/src/PubGrub/Cabal/PreInstalled.hs @@ -0,0 +1,17 @@ +-- | The solver's view of a unit that is already in the environment. +module PubGrub.Cabal.PreInstalled where + +import Distribution.Types.UnitId (UnitId) +import PubGrub.Cabal.Version (Version) + +-- | A package already present in the environment: a unit ID, a version, and +-- dependencies on other pre-installed units. The 'UnitId' distinguishes +-- different builds of the same package — even two builds of the same version +-- are distinct instances, since they may depend on different units. +data PreInstalledPackage + = PreInstalledPackage + { pipUnitId :: UnitId + , pipVersion :: Version + , pipDependencies :: [UnitId] + } + deriving (Eq, Ord, Show) diff --git a/src/PubGrub/Cabal/Pretty.hs b/src/PubGrub/Cabal/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/PubGrub/Cabal/Pretty.hs @@ -0,0 +1,23 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | 'Pretty' for the Cabal-syntax types a proof names. The class is the core's +-- and the types are Cabal's, so these are orphans by necessity; this module is +-- imported, for its instances, by the modules that define the cabal domain, so +-- they are in scope wherever the domain is. +module PubGrub.Cabal.Pretty () where + +import qualified Data.Text as T +import Distribution.Pretty (prettyShow) +import Distribution.Types.Flag (FlagName, unFlagName) +import Distribution.Types.PackageName (PackageName) +import Distribution.Types.UnitId (UnitId) +import PubGrub.Pretty (Pretty (..)) + +instance Pretty PackageName where + pretty = T.pack . prettyShow + +instance Pretty FlagName where + pretty = T.pack . unFlagName + +instance Pretty UnitId where + pretty = T.pack . prettyShow diff --git a/src/PubGrub/Cabal/Provider.hs b/src/PubGrub/Cabal/Provider.hs new file mode 100644 --- /dev/null +++ b/src/PubGrub/Cabal/Provider.hs @@ -0,0 +1,767 @@ +-- | The cabal provider rule: how a package's instances are enumerated and what +-- committing to one entails, stated as incompatibilities. +-- +-- A package's instances are its installed units ('UsePreInstalled', from the +-- compiler's package database) together with its source releases (lazily, +-- through a t'ReleaseSource'). After a caller's 'Preference', the choice is +-- __strict prefer-installed__: if the offered set admits an installed unit, +-- commit to the newest such unit and pin its whole transitive closure to the +-- exact units it was built against; otherwise pick the newest source release +-- that can be built here and state its dependencies, each widened to the +-- installed units and source releases its range admits. +-- +-- 'mkExpand' takes its world as arguments, an installed database and a +-- t'ReleaseSource', so the same rule runs over an in-memory world as over +-- Hackage. Nothing here reads an index or a package database, and nothing here +-- needs more of the cabal ecosystem than @Cabal-syntax@: opening the index and +-- the compiler's world, and reading a release out of them, is the caller's +-- business. +module PubGrub.Cabal.Provider + ( -- * The rule + mkExpand + , Preference + , noPreference + , widenTo + , constrainTo + + -- * What it is given + , ReleaseSource (..) + , Release (..) + , releaseOf + , releaseOfStored + , ParseError (..) + + -- * Slots + , Slot + , withSlots + , slotRange + , spanSlot + , slotInstances + ) where + +import Colog.Core (LogAction, (<&)) +import Control.Exception (SomeException) +import Data.List (find, sortOn) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes, + fromMaybe, + listToMaybe) +import Data.Ord (Down (..)) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import Distribution.Compiler (CompilerInfo) +import Distribution.Parsec.Error (PError) +import Distribution.Pretty (prettyShow) +import Distribution.System (Platform) +import Distribution.Types.Condition (Condition (..)) +import Distribution.Types.Dependency (Dependency, + depPkgName, + depVerRange) +import Distribution.Types.Flag (FlagName) +import Distribution.Types.GenericPackageDescription (GenericPackageDescription) +import Distribution.Types.PackageName (PackageName) +import qualified Distribution.Types.Version as Cabal +import PubGrub.Cabal (Flag (..), + UnbuildableReason, + Var (..), + constraint, + declaresFlag, + fromDependency, + onlyInstalled, + unbuildable) +import PubGrub.Cabal.Flatten (FlagModel (..), + Guard, + GuardedDeps, + GuardedTools, + PkgConfigPresent, + Stanzas, + StoredRelease (..), + componentDepsStored, + componentToolsStored, + expandGuard, + toStored, + unbuildableStored) +import PubGrub.Cabal.Installed (InstalledDb (..), + InstalledEdge (..), + closureEdges, + installedInstancesOf, + isNonReinstallable, + toPreInstalled) +import PubGrub.Cabal.InstanceSet (HasVersion (..), + Instance (..), + InstanceSet (..), + memberInstance, + singletonInstance, + sourceInstances) +import PubGrub.Cabal.PreInstalled (PreInstalledPackage (..)) +import PubGrub.Cabal.Value (Value (..), + ValueSet (..), + instanceSet, + memberBool) +import PubGrub.Cabal.Version (Version) +import PubGrub.Cabal.VersionSet (VersionSet, + contains) +import qualified PubGrub.Cabal.VersionSet as VersionSet +import PubGrub.Incompatibility (Incompatibility) +import PubGrub.Pretty (Pretty (pretty)) + +-- | A @.cabal@ file that could not be read: Cabal-syntax's own errors, with the +-- @cabal-version@ it managed to read, or whatever the source threw on the way to +-- the bytes. +-- +-- 'mkExpand' warns and skips a release that answers with one; the release is then +-- outside the universe the solve runs over. +data ParseError + = ParseError (Maybe Cabal.Version) (NonEmpty PError) + | ParseException SomeException + deriving Show + +-- | One source release, reduced to what the rule reads: its automatic flags, its +-- guarded dependencies and what it owes to other namespaces. +data Release = Release + { relAutomatic :: [Flag] + -- ^ the automatic flags, each a solver variable of its own. Empty under + -- 'FixedFlags', where every flag is treated as manual. + , relGuarded :: GuardedDeps + -- ^ the dependencies as flag-guarded groups; a guard mentions automatic + -- flags only, everything else having been resolved + , relUnbuildable :: [(Guard, NonEmpty UnbuildableReason)] + -- ^ why, and under which flags, this release's library cannot be built + -- here: @buildable@ and @pkgconfig-depends@ resolved against the machine, + -- one entry per unusable library node with its guard + -- (@PubGrub.Cabal.Flatten.unbuildableStored@). Empty means it can be built + -- under every assignment. An entry whose guard holds however the flags + -- fall, such as @Lit True@, rules the release out; any other rules out the + -- flag values that reach it, and the rule states it as a guarded unit + -- clause when it offers the release. + , relTools :: GuardedTools + -- ^ the build tools, flag-guarded. The rule does not read them: a planner + -- solves the tools in a namespace of their own, from this list + -- ('PubGrub.Cabal.Flatten.GuardedTools'). + , relSetup :: [Dependency] + -- ^ the @setup-depends@, likewise ('PubGrub.Cabal.Flatten.setupDeps') + } + +-- | The reduction of a parsed description to what the rule reads: the one +-- route from a @.cabal@ file to a t'Release', for any tool that holds the +-- descriptions itself and builds a t'ReleaseSource' out of them. +-- +-- The machine is an argument and never read here: the platform and compiler +-- resolve the @os@\/@arch@\/@impl@ conditions, and the @pkg-config@ predicate +-- decides buildability. The flag model decides which flags stay symbolic: +-- under 'FixedFlags' every flag is its declared default and 'relAutomatic' is +-- empty; under 'FlagPackages' each automatic flag is a solver variable and the +-- guards name it. The t'Stanzas' decide whether the release's test suites and +-- benchmarks count — 'PubGrub.Cabal.Flatten.noStanzas' for a dependency, and a +-- planner's choice for a local package. A caller that keeps releases in their +-- pre-environment form goes through 'releaseOfStored' instead, which is the +-- same function over that form. +releaseOf + :: FlagModel + -> Stanzas + -> Platform + -> CompilerInfo + -> PkgConfigPresent + -> GenericPackageDescription + -> Release +releaseOf model stanzas platform compiler present = + releaseOfStored model stanzas platform compiler present . toStored + +-- | 'releaseOf' over the pre-environment form a derived index keeps +-- ('PubGrub.Cabal.Flatten.StoredRelease'). Everything a t'Release' holds is +-- independent of the flag assignment, so it is derived once per release and +-- reused for every assignment tried against it. +releaseOfStored + :: FlagModel + -> Stanzas + -> Platform + -> CompilerInfo + -> PkgConfigPresent + -> StoredRelease + -> Release +releaseOfStored model stanzas platform compiler present sr = + Release + { relAutomatic = case model of + FixedFlags -> [] + FlagPackages -> [Flag f d | (f, d) <- srFlags sr, f `notElem` srManual sr] + , relGuarded = componentDepsStored model stanzas platform compiler sr + , relUnbuildable = unbuildableStored model present platform compiler sr + , relTools = componentToolsStored model stanzas platform compiler sr + , relSetup = srSetup sr + } + +-- | What a solve prefers, when the offered set admits it: for a package, a +-- version and an assignment of its automatic flags. It is tried before the +-- rule's own order (installed first, then newest). A preference chooses a value +-- and is never an incompatibility, so it cannot make a solve fail. +-- +-- The main solve passes 'noPreference'. A solve for a build tool's or a +-- @Setup.hs@'s namespace passes the main plan's choices, so that where the two +-- can agree on a version and its flags they do, and one build serves both; where +-- the tool needs another version it gets it, without touching the main plan. A +-- flag the preference does not name is offered at its declared default. +type Preference = PackageName -> Maybe (Version, Map FlagName Bool) + +-- | Prefers nothing, so every choice falls to installed, then newest. +noPreference :: Preference +noPreference = const Nothing + + +-- | Where a package's /source releases/ come from: which versions exist, and how +-- to read one. These are the only two questions 'mkExpand' asks about the +-- source side; how a @.cabal@ file is found and reduced to a t'Release' is the +-- caller's business. +-- +-- Installed units are deliberately /not/ here. They are not releases: they have +-- no flags to assign and no @.cabal@ to read, and they come from the compiler +-- rather than an index. 'mkExpand' takes them as a separate argument. +data ReleaseSource m = ReleaseSource + { rsVersionsOf :: PackageName -> Set Version + -- ^ every version of this package the source has. A 'Set', so that "ordered" + -- and "no duplicates" are properties of the answer rather than promises each + -- caller has to keep — 'withSlots' asks which release comes /next/, and gets a + -- silently wrong answer from an unordered list. + , rsReadRelease :: PackageName -> Version -> m (Either ParseError Release) + -- ^ the reduced form of one release. Only ever called for versions + -- 'rsVersionsOf' reported. + } + +-- | The provider's @expand@: the whole candidate-selection and emission rule, over +-- an installed world and a source world. +-- +-- The constraint is 'Monad' plus a text 'LogAction' for its one warning (an +-- unparseable release), and __not__ @MonadIO@: reading a release runs in +-- whatever @m@ the t'ReleaseSource' was built in, so an in-memory world can +-- drive the rule purely, and a tool with its own logging hands over an action +-- rather than adopting a monad. +-- +-- Three kinds of question arrive: +-- +-- * __a flag__ ('FlagVar'): answered from the variable alone. The preferred +-- value, or else the declared default carried in the flag's identity +-- ('PubGrub.Cabal.Flag'), is offered first where the set admits it, +-- and the other value otherwise. No clause is stated: the clause that made +-- the flag a goal, and the guarded dependencies that consult it, went out +-- with its owner. +-- * __a package__ ('PackageVar') with a 'Preference' the set admits: that +-- source release, if the source has it and it can be built here. +-- * __a package__ otherwise: the newest installed unit the set admits, with +-- the unit's whole transitive closure pinned to the exact units it was built +-- against; failing that, the newest source release the set admits that can +-- be built here, with its dependencies, each under the flags it is guarded +-- by, and one 'declaresFlag' clause per automatic flag it declares. +-- +-- Releases that cannot be built here are stated as 'unbuildable' facts on the +-- way past, and those facts are returned even when no value is offered. So is a +-- release whose dependency on its own package excludes it. +mkExpand + :: forall m + . Monad m + => LogAction m Text + -> Preference + -> InstalledDb + -> ReleaseSource m + -> Var + -> ValueSet + -> m (Maybe Value, [Incompatibility Var]) +mkExpand logA preference installedDb source = expand' + where + expand' :: Var -> ValueSet -> m (Maybe Value, [Incompatibility Var]) + expand' (FlagVar p (Flag f dflt)) set = + let first = fromMaybe dflt (preference p >>= Map.lookup f . snd) + in pure (listToMaybe [FlagValue b | b <- [first, not first], memberBool b (vsFlags set)], []) + expand' (PackageVar pn) set = expandPackage pn (vsInstances set) + + -- The preferred release first, when there is one, the offered set admits it + -- and the index has it ('Preference'). It goes through the same scan as the + -- rule, over a list of one, so a preferred release that cannot be built here + -- states why and falls through to the rule with its facts. A non-reinstallable + -- package has no source release to prefer. + expandPackage :: PackageName -> InstanceSet -> m (Maybe Value, [Incompatibility Var]) + expandPackage pn range = + case preference pn of + Just (v, _) + | not (isNonReinstallable pn) + , BuildSource v `memberInstance` range + , Just slot <- lookup v (withSlots (rsVersionsOf source pn)) -> do + (chosen, stated) <- scan pn range [] [(v, slot)] + case chosen of + Just _ -> pure (chosen, stated) + Nothing -> fmap (stated ++) <$> expandByRule pn range + _ -> expandByRule pn range + + -- An 'InstanceSet' is a symbolic description (a version range plus the + -- installed units in it), not a container: membership is decidable but it + -- cannot be enumerated. So enumerate the package's own instances — cheaply, + -- from the installed db and the index's version map, without parsing any + -- @.cabal@ — and keep those the offered set admits. + expandByRule :: PackageName -> InstanceSet -> m (Maybe Value, [Incompatibility Var]) + expandByRule pn range = do + let installedHere = [toPreInstalled u | u <- Map.findWithDefault [] pn (idbByName installedDb)] + admissible = sortOn (Down . version) (filter (`Set.member` isInstalled range) installedHere) + case listToMaybe admissible of + Just chosen -> do + incs <- consequencesOfUsePreInstalled chosen + pure (Just (PackageValue (UsePreInstalled chosen)), onlyInstalledFact pn ++ incs) + -- No admissible installed unit. For most packages that means falling + -- through to source releases; for a non-reinstallable one there is + -- nothing at all, because no release of it can be built against this + -- compiler ('nonReinstallablePackages'). Without this case the solver + -- would plan to build @base@ from Hackage, which cabal rejects. + -- + -- The answer is 'Nothing', with the only-installed fact beside it, as + -- the scan's facts ride out below: incompatibilities are + -- context-independent, so one need not be about a decided instance. + -- Without the fact the solver learns only that the range is empty, + -- and the proof reads "no version for base in >=4.5 && <4.7" when + -- the reason is that the compiler provides base. The fact replaces a + -- clause rather than adding one: the solver's @banRest@ subtracts + -- what the provider stated, and the fact covers every source + -- instance, so the @noValues@ clause it would have added is empty. + -- + -- Stating a boot fact changes the search, not only the wording; see + -- 'onlyInstalledFact' for what stating all of them up front cost. + Nothing + | isNonReinstallable pn -> pure (Nothing, onlyInstalledFact pn) + | otherwise -> scan pn range [] (withSlots (rsVersionsOf source pn)) + + -- Releases newest first. Each release is read __before the range is + -- tested__, including releases the range does not admit, so the first + -- scan of a package states the unbuildable fact of every release it has + -- and the store merges those into one clause over the whole run. Testing + -- the range first saves almost no reads, since a later scan's + -- out-of-range reads are memo hits, and the solver then learns an + -- unbuildable fact one slot at a time and the proof names it once per + -- slot (measured, docs/DESIGN.md §5). + -- + -- @stated@ accumulates the facts about releases the scan rejects on the + -- way past. They ride out with whichever release it settles on, and with + -- the @Nothing@ of an exhausted list, which is why 'expand' returns its + -- clauses outside the 'Maybe': a range holding nothing but unbuildable + -- releases is the commonest way a real Hackage package fails to resolve, + -- and without these facts the report says "no version for hpqtypes in + -- >=1.13" where cabal says "pkg-config package libpq-any, not found in + -- the pkg-config database". + scan :: PackageName -> InstanceSet -> [Incompatibility Var] -> [(Version, Slot)] -> m (Maybe Value, [Incompatibility Var]) + scan _ _ stated [] = pure (Nothing, reverse stated) + scan pn range stated ((v, slot):rest) = do + result <- rsReadRelease source pn v + case result of + -- A .cabal that fails to parse: warn and skip. The + -- release is then outside the universe the solve runs + -- over, which is why the warning has to be visible. + Left err -> do + logA + <& T.pack + ( "warning: ignoring " + ++ prettyShow pn + ++ "-" + ++ T.unpack (pretty v) + ++ " (unparseable .cabal: " + ++ show err + ++ ")" + ) + scan pn range stated rest + -- A release whose library cannot be built here under any + -- assignment is not a candidate: its @pkgconfig-depends@ + -- are unsatisfiable on this machine, or it declares + -- @buildable: False@. Not warned about, because unlike an + -- unparseable @.cabal@ this is an ordinary fact about the + -- release, and cabal applies the same rule from the same + -- pkg-config db. + -- + -- It is /stated/ rather than skipped + -- (references/pubgrub.md:475): without the clause the + -- report reads "no version for p in range" when the + -- versions exist and cannot be built here. With it, the + -- proof line names the reason, the module @pkg-config@ + -- could not find, as cabal's own message does. + -- + -- The clause is over the release's whole slot, and it is + -- the /unconditional/ verdict: the reasons of every node + -- whose guard holds under every assignment. A node unusable + -- only under some flag values does not rule the release + -- out; it rides out with the release below, as a guarded + -- unit clause over the flags that reach it. + Right release | Just why <- NE.nonEmpty (unconditionallyUnbuildable release) -> + scan pn range (unbuildableFact pn slot why : stated) rest + -- A release whose dependency on its own package excludes it under + -- any assignment cannot be chosen either, and goes the same way. + Right release | excluded@(_ : _) <- selfExclusions pn v slot release -> + scan pn range (excluded ++ stated) rest + Right release + | not (BuildSource v `memberInstance` range) -> scan pn range stated rest + | otherwise -> do + -- The release is the instance. What rides out with + -- it is one 'declaresFlag' clause per automatic flag, + -- which makes each flag a goal of its own, and one + -- dependency clause per guarded occurrence and + -- disjunct of its guard, each naming the flags it + -- holds under. A dependency on the package itself is + -- dropped, unless it excludes the release under some + -- flags (see 'excludesItself'). + let flags = relAutomatic release + declared = [declaresFlag pn (slotInstances slot) f | f <- flags] + -- A library node unusable under some flag values: + -- the release with those values is banned, one + -- clause per disjunct of the guard, as for a + -- dependency. The release itself is still + -- offered, and propagation turns the clause into + -- the other value of the one open flag. + unbuildableUnder = + catMaybes + [ guardedUnbuildable pn slot flags pins why + | (guard, why) <- relUnbuildable release + , pins <- expandGuard guard + , not (Map.null pins) + ] + incs <- + sequence + [ guardedInc pn v slot flags guard pins dep + | (guard, deps) <- relGuarded release + , pins <- expandGuard guard + , dep <- deps + , depPkgName dep /= pn || excludesItself pn v dep + ] + pure (Just (PackageValue (BuildSource v)), reverse stated ++ declared ++ unbuildableUnder ++ catMaybes incs) + + -- For a non-reinstallable package, the standing fact that it can __only__ + -- be an installed unit: no source release of it may be selected, whatever + -- the range. Stated with the decision that commits to one of its installed + -- units, and with the 'Nothing' for a range that admits none. Without it, + -- every range of @base@ that admits only source releases costs a decision, + -- a provider call answering 'Nothing' and a @noValues@ clause naming that + -- one range. cabal states the same rule as a constraint up front + -- (@PackagePropertyInstalled@ on each non-reinstallable package). + -- + -- Stated on first use rather than up front for all eight packages, which + -- is where cabal puts it: up front shortened @lens '<4'@'s proof to two + -- lines but cost @aeson '<2'@ 41% more allocation and 466 more decisions, + -- because the extra level-0 derivations change which satisfier conflict + -- resolution picks. That is search-path luck rather than a principle. + onlyInstalledFact pn + | isNonReinstallable pn = [onlyInstalled pn (installedVersionsOf pn) anySourceRelease] + | otherwise = [] + + -- Newest first, one entry per version: two units of one version are one + -- version to the reader. + installedVersionsOf pn = + Set.toDescList + (Set.fromList [pipVersion (toPreInstalled u) | u <- Map.findWithDefault [] pn (idbByName installedDb)]) + + -- The fact that a release cannot be built in this environment: a unit + -- clause banning every instance of its version __slot__ + -- (references/pubgrub.md:475). Adjacent slots touch, so when 'PubGrub.Store' + -- merges a run of these the union has no hole between the releases and + -- reads as the range the spec asks for. The store merges only facts that + -- give the same reasons, so a release missing @libpq@ and one declaring + -- @buildable: False@ stay two facts, each with its own sentence. + unbuildableFact pn slot why = unbuildable pn (slotInstances slot) Map.empty why + + -- The reasons a release cannot be built under /any/ assignment: those of + -- every entry whose guard has a disjunct with no pins, which is to say + -- holds however the flags fall. In tree order, as 'unbuildableStored' + -- gives them. + unconditionallyUnbuildable release = + concat + [ NE.toList why + | (guard, why) <- relUnbuildable release + , Map.empty `elem` expandGuard guard + ] + + -- The ban on a release under one disjunct of a node's guard, over the + -- release's slot. The pins are looked up among the release's automatic + -- flags as 'guardedInc' looks its own up, and a pin naming a flag the + -- release does not declare drops the clause rather than widening it. + guardedUnbuildable pn slot flags pins why = + (\g -> unbuildable pn (slotInstances slot) (Map.fromList g) why) + <$> traverse (asFlagOf flags) (Map.toList pins) + + -- Every source instance of a package: any version. + anySourceRelease = sourceInstances VersionSet.fullVersionSet + + -- Committing to an installed unit fixes its whole transitive closure, so + -- hand the solver every edge of that closure at once. Each edge names its + -- own depender, so each is a genuine direct dependency: propagation chains + -- through the closure in one fixpoint (rather than learning one hop per + -- decision), and a report about any edge stays true. + -- + -- 'closureEdges' emits no edge between two units of one package, for the + -- reason 'excludesItself' gives. + consequencesOfUsePreInstalled pip = + pure + [ fromDependency + fromName + (singletonInstance (UsePreInstalled fromPip)) + Map.empty + toName + (singletonInstance (UsePreInstalled toPip)) + | InstalledEdge (fromName, fromPip) (toName, toPip) <- + closureEdges installedDb (pipUnitId pip) + ] + + -- One guarded dependency occurrence of the decided release, under one + -- disjunct of its guard, as an incompatibility over a range of depender + -- releases: the release's __slot__ ('withSlots'), or a wider span. + -- + -- references/pubgrub.md:456 asks for identical dependencies of adjacent + -- versions of the depender to be /one/ incompatibility, "with an inclusive + -- lower bound of the first version that has the dependency, and an + -- exclusive upper bound of the first [version] that doesn't". Two mechanisms + -- deliver it, and both run. 'spanningOccurrenceWith', below, reads the + -- decided release's neighbours and widens the range while the occurrence + -- is identical. 'PubGrub.Store' separately unions the depender terms of two + -- facts that agree about the dependee and the guard, as they arrive, and + -- slots make that union free: adjacent slots /touch/, so it is one + -- contiguous interval rather than two with a hole between. + -- + -- The walk is affordable because a neighbour read is a decode from the + -- derived index rather than a parse (0.073 ms against 2.007 ms). It costs + -- @pandoc@ 22.6 → 33.1 MB of residency and under 1% of allocation; + -- docs/DESIGN.md §5 has the trade, and the ways to walk less if + -- read-dominated problems ever matter more. + -- + -- The guard's pins name flags; each is looked up among the release's + -- automatic flags to recover its declaration. A pin naming a flag the + -- release does not declare as automatic cannot occur, since manual and + -- undeclared flags are resolved before a guard reaches here. If it did, + -- the disjunct is dropped rather than stated with a widened antecedent, + -- which would be the unsound direction. + guardedInc pn v slot flags guard pins dep = + case traverse (asFlagOf flags) (Map.toList pins) of + Nothing -> pure Nothing + Just g -> do + dependers <- spanningOccurrenceWith (sameFlags guard flags) pn v slot guard dep + pure . Just $ + fromDependency + pn + (slotInstances dependers) + (Map.fromList g) + (depPkgName dep) + (declaredRange dep) + + -- Whether a dependency is on the release's own package, with a range that + -- excludes the release. Such a dependency is the only kind of @p@ on @p@ that + -- is stated. @lens 1.7@ declares a dependency on @lens ==1.7@ because one of + -- its executables is built against its own library: an /intra-package/ edge, + -- resolved inside the package, with nothing to solve for. + -- + -- The range still says something about the release. @acme-zero 0.0.2@ + -- declares @acme-zero ==0@, so no plan can honour it. Cabal's validator + -- checks the range whichever component declares it (@Validate.merge@), and + -- 'fromDependency' intersects the two terms into a ban on just the releases + -- outside it. Nothing is stated when the range admits the release, because + -- that clause would ban nothing. + -- + -- That no goal and no edge are added is cabal's rule too. Its solver's + -- @extendOpen@ (@Distribution.Solver.Modular.Builder@) adds neither when + -- @qpn == qpn'@, /except/ for a setup dependency, where it adds a + -- reverse-dependency edge so that the cycle makes the solver pick a + -- different instance for the setup script; and @isInternal@ + -- (@Distribution.Solver.Modular.IndexConversion@) drops a + -- @build-tool-depends@ on the package's own executable. Neither exception + -- arises here, because this rule states no setup or build-tool + -- dependencies: they ride in 'Release' for a planner to solve in a + -- namespace of their own. Qualified goals would not subsume the rule + -- either: a library dependency inherits its depender's qualifier + -- (@qualifyDeps@'s @inheritedQ@), so an executable's dependency on its own + -- library stays a self-dependency under any qualifier scheme. + excludesItself pn v dep = + depPkgName dep == pn && not (BuildSource v `memberInstance` declaredRange dep) + + -- The bans on a release from its own dependencies that hold under every + -- assignment. One under a flag is an ordinary guarded fact ('guardedInc'): the + -- release is still offered, and propagation flips the flag. + selfExclusions pn v slot release = + [ fromDependency pn (slotInstances slot) Map.empty pn (declaredRange dep) + | (guard, deps) <- relGuarded release + , Map.empty `elem` expandGuard guard + , dep <- deps + , excludesItself pn v dep + ] + + declaredRange dep = widen (depPkgName dep) (VersionSet.fromVersionRange (depVerRange dep)) + + -- A pin by flag name, as its declaration among the release's automatic flags. + asFlagOf flags (name, b) = (\f -> (f, b)) <$> find ((== name) . flagName) flags + + -- A neighbour spanned under a guard must declare the same automatic flags with + -- the same defaults: the flag variables are named by both, so a neighbour that + -- changed a default has different variables and must not be spanned. An + -- unconditional occurrence does not care. + sameFlags (Lit True) _ _ = True + sameFlags _ flags neighbour = relAutomatic neighbour == flags + + -- The range to name a release's neighbours by: walk out from @v@ in both + -- directions while each neighbour carries this same occurrence, then take + -- the half-open range from the lowest such release up to the first release + -- above the highest. This is references/pubgrub.md:456 done where the spec + -- asks for it, at generation time, rather than left to 'PubGrub.Store' to + -- rebuild one expanded release at a time. + -- + -- "The same occurrence" is compared per /dependency/, not per group: a + -- neighbour qualifies when any of its guarded groups has this guard and + -- contains this exact 'Dependency'. Comparing whole groups would refuse to + -- merge two releases that differ in something unrelated. + -- + -- Requiring the guard to be __identical__ keeps this sound on the flag + -- axis: every release in the span declares the flags the guard mentions, + -- since one that did not could not have produced that guard; and @admit@ + -- requires the same defaults as well ('sameFlags'). + -- + -- Each neighbour tried costs a release read, so the walk is only as cheap + -- as the 'ReleaseSource' makes a read. As a parse (2.0 ms and ~7.7 MB each) + -- it took @pandoc@, a problem with a single conflict, from 167 reads to + -- 2834 and from 22.9 MB of residency to 81.0 MB (docs/DESIGN.md §5). + spanningOccurrenceWith admit pn v slot guard dep = do + lo <- walk Set.lookupLT v + hi <- walk Set.lookupGT v + pure $ case (lo, hi) of + -- Nothing on either side carried it: the release's own slot. + (l, h) | l == v && h == v -> slot + (l, h) -> spanSlot (slotRange releases l (Set.lookupGT h releases)) + where + releases = rsVersionsOf source pn + + -- The furthest release in one direction still carrying the occurrence. + walk step from = case step from releases of + Nothing -> pure from + Just w -> do + result <- rsReadRelease source pn w + case result of + -- An unparseable neighbour stops the walk rather than being + -- stepped over: we cannot claim a fact about a release we cannot + -- read, and widening across it would do exactly that. + Right neighbour | carries neighbour, admit neighbour -> walk step w + _ -> pure from + + -- A linear search of every group's list. A map from package name to + -- occurrences was measured against it: search identical, mutator time + -- 0% to −12%, allocation +3–5% on every problem, so it was not kept + -- (docs/DESIGN.md §5). The cost-centre profile's 13–16% for + -- @Eq Dependency@ here is mostly the profiler's own overhead. + carries neighbour = + any (\(g, ds) -> g == guard && dep `elem` ds) (relGuarded neighbour) + + widen = widenTo installedDb + +-- | Widen a version range into an instance set: a dependency's declared range, or +-- a target's. +-- +-- The installed side is a set of units, because the compiler's package +-- database is small and fully known. The source side is the declared range +-- itself rather than one entry per in-range version, so its size does not +-- grow with the number of releases on Hackage, and the range survives into the +-- incompatibility: a conflict report can say @>=1.0 && <2@ instead of +-- enumerating versions. +-- +-- This admits versions the index does not have. That is harmless: the set +-- algebra never needs the universe of instances, and 'mkExpand' is the only +-- place the index is consulted, so an unsatisfiable dependency surfaces as +-- 'Nothing' from the provider rather than as an empty widening. +widenTo :: InstalledDb -> PackageName -> VersionSet -> InstanceSet +widenTo installedDb d vs = + InstanceSet + { isInstalled = + Set.fromList + [ pip + | UsePreInstalled pip <- installedInstancesOf installedDb d + , contains vs (version pip) + ] + , isSource = vs + } + +-- | A constraint seed over a package: if @p@ is in the plan, it is one of +-- @allowed@. The complement the clause bans is computed here because only this +-- side knows the package's universe: every installed unit of @p@ the compiler +-- has, and every source version. +-- +-- Two callers, two shapes of @allowed@: a range from @--constraint@ or a +-- @constraints:@ stanza is widened with 'widenTo', so an installed unit in the +-- range stays admissible; a lock entry held at its version is +-- @'sourceInstances' (singleton v)@, which bans the installed units too, since +-- the lock recorded a source package. +constrainTo :: InstalledDb -> PackageName -> InstanceSet -> Incompatibility Var +constrainTo installedDb p allowed = + constraint (PackageVar p) (instanceSet allowed) (instanceSet forbidden) + where + forbidden = + InstanceSet + { isInstalled = + Set.fromList [pip | UsePreInstalled pip <- installedInstancesOf installedDb p] + `Set.difference` isInstalled allowed + , isSource = VersionSet.complementVersionSet (isSource allowed) + } + +-- | Pair each release with its __version slot__: the half-open range reaching from +-- it up to the next release that exists, and unbounded for the newest. Newest +-- first, which is the order candidates are tried in. +-- +-- Slots let a depender term be a range rather than a point at no cost in +-- @.cabal@ reads. A slot contains exactly one existing release, so a term over +-- @slot(v)@ denotes the same instances as one over @{v}@ among anything that can +-- be offered: the claim is about @v@ alone, and nothing is asserted about a +-- release that was not read. What the slot adds is that adjacent slots /touch/, +-- so 'PubGrub.Cabal.VersionSet.unionVersionSet' coalesces them and a difference +-- never leaves an empty hole between releases behind. +-- +-- The bound is the next release in the __index__, not the next /usable/ one: a +-- skipped release (unparseable, say) still has dependencies of its own, so +-- widening across it would assert this release's dependencies of it. +-- +-- It takes a 'Set' rather than a list because \"the next release that exists\" +-- is a question about the whole ordered collection, and a list would make its +-- order an unchecked precondition. +withSlots :: Set Version -> [(Version, Slot)] +withSlots releases = + [ (v, Slot (slotRange releases v (Set.lookupGT v releases))) + | v <- Set.toDescList releases + ] + +-- | The range from release @lo@ up to, and not including, the next release @hi@, +-- in the given set of releases. The package's __first__ release has no lower +-- bound at all, as the PubGrub algorithm omits the lower bound of a dependency +-- the first published version already has. Nothing is published below it, so +-- the two ranges hold the same releases; what differs is the complement. +-- Banning @>=0.1 && <2.4@ leaves @<0.1@ for the solver to discover empty and to +-- print as @no version for lens in <0.1@; banning @<2.4@ leaves nothing, and +-- the proof reads @lens <2.4@. +slotRange :: Set Version -> Version -> Maybe Version -> VersionSet +slotRange releases lo hi + | Set.lookupMin releases == Just lo = VersionSet.belowVersionSet hi + | otherwise = VersionSet.halfOpenVersionSet lo hi + +-- | One release's slot, as a type of its own. +-- +-- The distinction it carries is invisible at the level of ranges. The PubGrub +-- algorithm asks for identical dependencies of adjacent versions to be one +-- incompatibility over the run, not one per version: a depender term over a +-- __single version__ is the per-version form it rules out, and a depender term +-- over a __slot__ is what lets adjacent ones join into the run. Both are +-- intervals, so only a type stops one being passed where the other belongs. +-- +-- The constructor is not exported, and only 'withSlots' and 'spanSlot' apply +-- it; 'slotInstances' is the only way back out. +newtype Slot = Slot VersionSet + +-- | A slot spanning a __run of adjacent releases__ that all carry the same +-- dependency occurrence: the one incompatibility over the run that the PubGrub +-- algorithm asks for. +-- +-- It is a t'Slot' for the same reason one release's slot is: the invariant the +-- type protects is that a depender term is never a single version, and a span +-- satisfies that more strongly. The caller establishes the run, by reading +-- every release in it; within this module, 'mkExpand' does so when it widens a +-- dependency's depender range. +spanSlot :: VersionSet -> Slot +spanSlot = Slot + +-- | Every source instance of a slot: the depender term of a dependency fact, and +-- the term an unbuildable fact bans. +slotInstances :: Slot -> InstanceSet +slotInstances (Slot vs) = sourceInstances vs diff --git a/src/PubGrub/Cabal/Report.hs b/src/PubGrub/Cabal/Report.hs new file mode 100644 --- /dev/null +++ b/src/PubGrub/Cabal/Report.hs @@ -0,0 +1,301 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | The cabal domain's proofs: the standard PubGrub sentences in cabal's range +-- syntax, over the walker in "PubGrub.Report". +-- +-- 'cabalFormatter' is the domain's half of that contract: the words +-- ("PubGrub.Cabal.Report.Wording"), a pass over the tree before the walk +-- ('collapseNoInstances'), and the rules that say a step in fewer lines than +-- the PubGrub algorithm's cases would. Three of those are this package's rather +-- than the algorithm's — @samePairRun@, @wideningRun@ and 'collapseNoInstances' — +-- and each carries its soundness argument where it is defined. The two clause +-- rules the algorithm names as special cases, @chainOfTwo@ and @sharedDepender@, +-- are here too rather than in the core, because what a dependency is the core +-- does not know. +-- +-- The headline above the proof is "PubGrub.Cabal.Report.Headline"'s, and the +-- wrapping and colour the driver puts over both are +-- "PubGrub.Cabal.Report.Layout"'s. +module PubGrub.Cabal.Report + ( cabalFormatter + , reportConflict + , reportHeadline + , collapseNoInstances + -- * Re-exported from "PubGrub.Cabal.Report.Layout" + , wrapProof + , styleProof + , rangeToken + ) where + +import Control.Monad (guard) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Distribution.Types.PackageName (PackageName) +import PubGrub.Cabal (CabalFact (..), Var (..)) +import PubGrub.Cabal.InstanceSet (InstanceSet) +import PubGrub.Cabal.Report.Headline (headline) +import PubGrub.Cabal.Report.Layout (rangeToken, styleProof, + wrapProof) +import PubGrub.Cabal.Report.Rule +import PubGrub.Cabal.Report.Wording (bareP, dep, namedP, + summaryTerms, wording) +import PubGrub.Cabal.Value (ValueSet (..)) +import PubGrub.Incompatibility (Cause (..), + Incompatibility (..), + priorCauseTerms) +import PubGrub.Report (Formatter (..), Line (..)) +import qualified PubGrub.Report as Report +import PubGrub.SetOps (isSubsetOf) +import PubGrub.Term (Term (..)) + +-- | The cabal domain's words and rules. The two run rules go before the +-- algorithm's every-other-step skip because they collapse what the skip would +-- print two facts at a time. +cabalFormatter :: Formatter Var +cabalFormatter = + wording + { prepare = collapseNoInstances + , lineRules = [wideningRun, samePairRun] + , clauseRules = joins + } + +-- | Render an incompatibility and its derivation as a human-readable proof. +reportConflict :: Incompatibility Var -> Text +reportConflict = Report.reportConflict cabalFormatter + +-- | One or two lines to put above the proof: see "PubGrub.Cabal.Report.Headline". +reportHeadline :: Incompatibility Var -> Text +reportHeadline = headline . collapseNoInstances + +-- -------------------------------------------------------------------------- +-- The line rules +-- -------------------------------------------------------------------------- + +-- | __Rule 3, the same-pair run.__ Before the ordinary every-other-step skip, +-- look for a run of steps that all say the same kind of thing: this range of +-- @p@ depends on @q@, and so does the next range, and the next. That is one +-- fact about @p@ as a whole, and printing it a range at a time spends a line on +-- every adjacent pair in the history of @p@'s bound on @q@. +-- +-- It is /not/ the PubGrub algorithm's collapsing of adjacent versions, which +-- merges facts with an __identical__ dependee range. Here the dependee ranges +-- differ — that is why the solver had to derive its way along them — and what +-- is printed is their union. +-- +-- Stating the union of the facts is sound on its own — each says @p ∈ Sᵢ@ +-- requires @q ∈ Rᵢ@, so @p ∈ ⋃S@ requires @q ∈ ⋃R@ — but a line may not claim +-- to justify more of @p@ than the step it is attached to concluded, and the +-- last two guards are what stop it: the conclusion really is \"p requires q\", +-- and the collapsed depender range is one it covers. +samePairRun :: Rule (Incompatibility Var) (Line Var) +samePairRun step = do + (d, e) <- chainStep step + (p, s, q, r) <- asDependency e + let (rest, more) = runWhile (dependencyOn p q) d + guard (not (null more)) + ss <- unions (s : map fst more) + rs <- unions (r : map snd more) + sInc <- concludesRequires p q step + guard (ss `isSubsetOf` sInc) + pure (Line (dep p ss q rs) (Just rest)) + where + -- A fact about this @(depender, dependee)@ pair: its two ranges. + dependencyOn p q e = do + (p', s, q', r) <- asDependency e + guard (p' == p && q' == q) + pure (s, r) + +-- | Is this step's conclusion of the shape \"p requires q\"? If so, the range of +-- @p@ it speaks for. Anything else and a collapsed sentence would be attached +-- to a claim it does not support. +concludesRequires :: PackageName -> PackageName -> Rule (Incompatibility Var) InstanceSet +concludesRequires p q step = case Map.toList (incompTerms step) of + [(a, Positive s), (b, Negative _)] | (a, b) == (PackageVar p, PackageVar q) -> Just (vsInstances s) + [(b, Negative _), (a, Positive s)] | (a, b) == (PackageVar p, PackageVar q) -> Just (vsInstances s) + _ -> Nothing + +-- | __Rule 4, the widening run.__ Rule 3 needs every fact in the run to name +-- the same dependee, and needs the step's conclusion to be the two-term \"p +-- requires q\". Neither holds on a problem with an /unconstrained/ target: +-- refuting one takes a walk along the target's whole version history, and +-- consecutive releases rarely fail over the same dependee. Such a walk folds in +-- one dependency of the target per line — on @base@, then @deepseq@, then +-- @template-haskell@ — while every other term stands still; another kind strikes +-- a dependee's slots off one at a time. +-- +-- So collect the run by __depender alone__ and state it once. Each fact says +-- @p ∈ Sᵢ@ requires @qᵢ ∈ Rᵢ@, so their union says @p ∈ ⋃S@ requires +-- @q₁ ∈ ⋃R₁@ or … or @qₙ ∈ ⋃Rₙ@: if @p@ is in the union it is in some @Sᵢ@, and +-- that fact's own dependee is one of the disjuncts. Nothing else about @p@ is +-- claimed, which is why 'mergeFacts' refuses a run where some package is a +-- depender in one fact and a dependee in another — the argument is about one +-- depender and holds for nothing else. +-- +-- Three facts at least. Two of them fit one line as they are, where the +-- ordinary skip already puts them, and naming both says strictly more than +-- naming their union — so the union has to buy a line to be worth taking. Rule +-- 3 still has the two-fact case where the dependee agrees. +-- +-- __The guard is the operation, not a description of it.__ A line that stands +-- for a run has to arrive where the run arrived, and the only way to know that +-- is to go there: 'PubGrub.Incompatibility.priorCauseTerms' — the term algebra +-- 'PubGrub.Incompatibility.priorCause' itself runs, pivoting on the depender — +-- is applied once to the merged fact, and the collapse is taken only if the +-- result is term for term the conclusion this line is attached to. So the rule +-- needs no subset side-condition of its own, and it needs no case analysis over +-- what the run did: whether the depender __accumulated__ (@aeson@ climbing from +-- @\<0.8.0.1@ to @\<2.2.5.0@) or was __eliminated__ (@directory@ losing one slot +-- per fact until nothing was left), one step over the union lands where @n@ +-- steps over the members landed, or the collapse does not happen. +wideningRun :: Rule (Incompatibility Var) (Line Var) +wideningRun step = do + (d, e) <- chainStep step + (p, _, _, _) <- asDependency e + let (rest, more) = runWhile (dependencyOf p) d + guard (length more >= 2) + merged <- mergeFacts (e : more) + guard (sameTerms (priorCauseTerms (PackageVar p) (incompTerms rest) merged) (incompTerms step)) + pure (Line (runFact p merged) (Just rest)) + where + -- A fact with this depender, whatever it depends on. + dependencyOf p e = do + (p', _, _, _) <- asDependency e + guard (p' == p) + pure e + + -- The merged fact, as its sentence. With one dependee it is the shape rule + -- 3 already prints, word for word, so a run that both rules could take + -- reads the same either way; with several it is a requirement with + -- alternatives, and \"requires\" rather than \"depends on\" because a union + -- of declared dependencies is something the solver worked out, not + -- something an author wrote (references/pubgrub.md:1005). + runFact p terms = case Map.toList (Map.delete (PackageVar p) terms) of + [(PackageVar q, Negative r)] + | Just (Positive sp) <- Map.lookup (PackageVar p) terms -> dep p (vsInstances sp) q (vsInstances r) + _ -> summaryTerms terms + +-- -------------------------------------------------------------------------- +-- The clause rules: two external facts as one premise +-- -------------------------------------------------------------------------- + +-- | Two external facts as one premise. Each fusion is guarded so that it cannot +-- say more than the facts do. +joins :: [Rule (Incompatibility Var, Incompatibility Var) Text] +joins = + [ twoRequests + , symmetric dependsOnNothing + , symmetric requestsNothing + , symmetric chainOfTwo + , sharedDepender + ] + +-- | Two seeds close a proof together: \"baz >=1 && <2 and foo >=1 && <2 are +-- requested\", the standard \"depends on both\" sentence without a depender in +-- front of it. +twoRequests :: Rule (Incompatibility Var, Incompatibility Var) Text +twoRequests (c1, c2) = do + (p1, r1) <- asRequest c1 + (p2, r2) <- asRequest c2 + pure (bareP p1 r1 <> " and " <> bareP p2 r2 <> " are requested") + +-- | A dependency whose dependee range is one the solver has already found +-- empty. Naming both facts prints that range /twice/ in one sentence, and on a +-- real proof it is not short: haddock 2.29.1's base bound is seven windows, and +-- it would appear in full at both ends of the same line. +-- +-- Saying it once is sound only when the dependency's whole range is inside the +-- empty one, which is what the 'isSubsetOf' checks. Where it is only partly +-- inside, the two facts stay separate — absorbing that case means widening the +-- term rather than dropping a clause, which is 'collapseNoInstances' proper and +-- not a rendering change. +dependsOnNothing :: Rule (Incompatibility Var, Incompatibility Var) Text +dependsOnNothing (fact, hole) = do + (q', empty) <- asHole hole + (p, s, q, r) <- asDependency fact + guard (q == q' && r `isSubsetOf` empty) + pure (dep p s q r <> ", which has no versions") + +-- | A request whose whole range is empty reads the same way. +requestsNothing :: Rule (Incompatibility Var, Incompatibility Var) Text +requestsNothing (fact, hole) = do + (p', empty) <- asHole hole + (p, r) <- asRequest fact + guard (p == p' && r `isSubsetOf` empty) + pure (bareP p r <> " is requested, which has no versions") + +-- | A __chain__ — the first fact's dependee is the second's depender — reads +-- \"a depends on b which depends on c\". That is only true if every instance the +-- first fact leaves open for the middle package is one the second fact speaks +-- about, hence the 'isSubsetOf'. +chainOfTwo :: Rule (Incompatibility Var, Incompatibility Var) Text +chainOfTwo (c1, c2) = do + (p1, s1, q1, r1) <- asDependency c1 + (p2, s2, q2, r2) <- asDependency c2 + guard (q1 == p2 && r1 `isSubsetOf` s2) + pure (dep p1 s1 q1 r1 <> " which depends on " <> bareP q2 r2) + +-- | __One depender, two dependees__ reads \"a depends on both b and c\", for +-- which the two facts must be about the same instances of @a@. +sharedDepender :: Rule (Incompatibility Var, Incompatibility Var) Text +sharedDepender (c1, c2) = do + (p1, s1, q1, r1) <- asDependency c1 + (p2, s2, q2, r2) <- asDependency c2 + guard (p1 == p2 && s1 == s2) + pure (namedP p1 s1 <> " depends on both " <> bareP q1 r1 <> " and " <> bareP q2 r2) + +-- -------------------------------------------------------------------------- +-- Rule 5: the pre-pass +-- -------------------------------------------------------------------------- + +-- | Absorb \"no version for @p@ in @r@\" facts into the sibling they were resolved +-- against, and drop the step. +-- +-- Intensional ranges are why these exist at all: a dependency's declared range is +-- put into a term verbatim, so the solver has to /separately/ learn that the range's +-- holes hold no releases, and each such discovery is a leaf of the derivation. They +-- are honest facts and they are noise. +-- +-- __Why this is sound, and why it is not even a weakening.__ Resolving a unit clause +-- @{p ∈ r}@ against a dependency fact on the pivot @p@ unions the two terms about +-- @p@ and keeps the other side unchanged, so the step's own conclusion /already is/ +-- that dependency with @p@'s term adjusted. The pass therefore does not recompute +-- anything: it keeps the derived node's terms exactly and re-labels them as the leaf +-- they are equivalent to. Nothing in the proof gets wider or narrower; a step that +-- said nothing new stops being a step. The argument is the PubGrub algorithm's +-- own — a fact about a version that does not exist constrains nothing. +-- +-- Two cases are deliberately left alone: +-- +-- * __both causes are holes.__ There is no dependency to absorb into, and two empty +-- ranges do not make a sentence. +-- * __the dependee's whole range is empty.__ Then the union over the pivot is ⊤, the +-- dependee entry drops out of the resolvent, and rebuilding would produce a +-- dependency fact whose dependee range is /gone/ — the proof would say \"haddock +-- >=2.29.1 is forbidden\" and never mention @base@. @dependsOnNothing@ renders +-- that case as \"depends on … , which has no versions\", which keeps the range, +-- so the guard here is that the node must still carry a term for both packages. +collapseNoInstances :: Incompatibility Var -> Incompatibility Var +collapseNoInstances inc = case incompCause inc of + Derived c1 c2 -> + let c1' = collapseNoInstances c1 + c2' = collapseNoInstances c2 + node = Incompatibility (incompTerms inc) (Derived c1' c2') + in fromMaybe node (symmetric (absorb node) (c1', c2')) + _ -> inc + where + -- @hole@ is a range known empty, @other@ the dependency fact it was resolved + -- against. Answers with the node re-labelled as that dependency, over the + -- node's own terms. + absorb node (hole, other) = do + (p, _) <- asHole hole + (p1, q) <- dependencyPackages other + guard (p == p1 || p == q) + guard (Map.size (incompTerms node) == 2) + s1 <- vsInstances <$> (positive =<< Map.lookup (PackageVar p1) (incompTerms node)) + r2 <- vsInstances <$> (negative =<< Map.lookup (PackageVar q) (incompTerms node)) + pure (Incompatibility (incompTerms node) (Fact (CauseDependency p1 s1 Map.empty (q, r2)))) + + dependencyPackages c = case incompCause c of + Fact (CauseDependency p1 _ g (q, _)) | p1 /= q, Map.null g -> Just (p1, q) + _ -> Nothing diff --git a/src/PubGrub/Cabal/Report/Headline.hs b/src/PubGrub/Cabal/Report/Headline.hs new file mode 100644 --- /dev/null +++ b/src/PubGrub/Cabal/Report/Headline.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | The lines above the proof: what was asked for, the facts about this +-- machine the proof rests on, and the package the search gave up on. +-- +-- The proof is read bottom-up — its first line is the deepest fact and the +-- request appears only on the last — so a reader of the matterhorn proof meets +-- @hashable@ before learning that @base@ is the wall. The headline says both +-- first, in the proof's own words: the request is the seeds the proof rests on +-- ('CauseRequest'), and the walls are its world-fact leaves +-- ('CauseOnlyInstalled', 'CauseUnbuildable'), verbatim. It claims nothing the +-- proof does not: every named fact is a premise of the derivation below it. +-- +-- > No solution for matterhorn ==90000.1.1: base is pinned to 4.21.0.0 (installed). +-- +-- It is not a proof sentence and opens with no connective, so a count of a +-- proof's sentences by connective leaves it out — the same footing as cabal's own +-- \"Could not resolve dependencies:\" line above its own message. +-- +-- == The second line +-- +-- A second sentence names the package the search gave up on: \"lsp-types +-- >=2.0.0.0 needs regex, and no version of regex is compatible with ghcide +-- >=2.15.0.0, lsp-types >=2.0.0.0 and regex-tdfa >=1.3.1.0 together.\" It is a +-- derived step read out, not a summary written over the proof, and two rules +-- produce it, tried in turn. A guard that does not hold means no line, never a +-- wrong one. +module PubGrub.Cabal.Report.Headline + ( headline + ) where + +import Control.Monad (guard) +import Data.List (nub) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import Distribution.Types.PackageName (PackageName) +import PubGrub.Cabal (CabalFact (..), Var (..)) +import PubGrub.Cabal.InstanceSet (InstanceSet) +import PubGrub.Cabal.Report.Rule +import PubGrub.Cabal.Report.Wording (bare, bareP, leaf, listing, + namedP) +import PubGrub.Cabal.Value (ValueSet (..)) +import PubGrub.Cabal.Version (Version) +import PubGrub.Incompatibility (Cause (..), + Incompatibility (..)) +import PubGrub.Pretty (Pretty (..)) +import PubGrub.SetOps (SetOps (intersect, union), + isSubsetOf) +import PubGrub.Term (Term (..), unionTerm) + +-- | The headline of a proof whose holes have been absorbed +-- ('PubGrub.Cabal.Report.collapseNoInstances'). +headline :: Incompatibility Var -> Text +headline root = T.concat ["No solution", forWhat, walls, ".", culprit] + where + forWhat = case requests of + [] -> "" + rs -> " for " <> T.intercalate " and " rs + walls = case nub [leaf c | c <- externals root, isWorld c] of + [] -> "" + ws -> ": " <> T.intercalate "; " ws + -- What was asked for, as the proof itself names it. A seed the proof + -- never reaches is not the one that failed. + requests = nub [bareP p r | (p, r) <- seedRanges root] + isWorld c = case incompCause c of + Fact CauseOnlyInstalled{} -> True + Fact CauseUnbuildable{} -> True + _ -> False + culprit = case firstOf [wallStory, pivotStory] root of + Nothing -> "" + Just s -> "\n" <> s <> "." + +-- -------------------------------------------------------------------------- +-- What the proof rests on +-- -------------------------------------------------------------------------- + +-- | The seeds the proof rests on, with their ranges, in proof order. +seedRanges :: Incompatibility Var -> [(PackageName, InstanceSet)] +seedRanges root = [(p, r) | c <- externals root, Just (p, r) <- [asRequest c]] + +seeds :: Incompatibility Var -> [PackageName] +seeds = nub . map fst . seedRanges + +-- | The pinned packages the proof rests on, with their installed versions. +pinnedWalls :: Incompatibility Var -> [(PackageName, [Version])] +pinnedWalls root = nub [(p, vs) | c <- externals root, Fact (CauseOnlyInstalled p vs@(_ : _)) <- [incompCause c]] + +-- | A pinned package as \"base 4.21.0.0 (installed)\": the installed version is +-- what a reader can act on, and a step's own term for the wall may be its +-- whole source side, which would print as the bare name. +wallText :: Incompatibility Var -> PackageName -> Text +wallText root p = case lookup p (pinnedWalls root) of + Just vs -> pretty p <> " " <> T.intercalate " or " (map pretty vs) <> " (installed)" + Nothing -> pretty p + +-- | The packages the headline already names as walls, pinned or unbuildable. +walled :: Incompatibility Var -> [PackageName] +walled root = nub (concat [wallPackage c | c <- externals root]) + where + wallPackage c = case incompCause c of + Fact (CauseOnlyInstalled p _) -> [p] + Fact (CauseUnbuildable p _ _ _) -> [p] + _ -> [] + +-- -------------------------------------------------------------------------- +-- The wall story +-- -------------------------------------------------------------------------- + +-- | Where the proof rests on a pinned package, the reader wants three things +-- joined: who wants @x@, the window their bounds leave for it, and that nothing +-- in that window builds against the installed version. The proof has each, +-- apart: the window is spread over the dependency leaves, and the refutation is +-- a derived step of the shape \"x in W is incompatible with base 4.21.0.0 +-- (installed)\" — one positive term on @x@ and the rest positive terms on wall +-- packages — or \"x in W is forbidden\" with the wall among its premises. That +-- step is the wall doing its work ('wallStep'), and it is chosen nearest the +-- root. +-- +-- The window is what the seeds force ('inPlay'): @x@ must sit in the +-- intersection of the in-play leaves' ranges for it. The line is only printed +-- when that window lies inside the union of the ranges the wall steps refute, +-- so \"no x there builds\" is exactly what those steps say. +wallStory :: Rule (Incompatibility Var) Text +wallStory root = do + let steps = everywhere (wallStep root) root + (x, wallTexts) <- nearestRoot [(depth, (x, ws)) | (depth, (x, _, ws)) <- steps] + refuted <- unions [w | (_, (x', w, _)) <- steps, x' == x] + let wanting = Map.toList (Map.fromListWith meet [(d, (s, r)) | (d, s, q, r) <- inPlay root, q == x]) + meet (s1, r1) (s2, r2) = (s1 `union` s2, r1 `intersect` r2) + window <- case [r | (_, (_, r)) <- wanting] of + [] -> Nothing + (r : rs) -> Just (foldr intersect r rs) + guard (window `isSubsetOf` refuted) + let who = listing [namedP d s | (d, (s, _)) <- wanting] + leaves = case wanting of + [_] -> " needs " + _ -> " leave only " + pure (who <> leaves <> bareP x window <> ", and no " <> pretty x <> " there builds on " <> listing wallTexts) + +-- | A derived step of the wall shape: the package refuted, the range refuted, +-- and the walls it was refuted against, as text. A seed is never the package: +-- the headline has said it already, and the proof's last line says it again. +wallStep :: Incompatibility Var -> Rule (Incompatibility Var) (PackageName, InstanceSet, [Text]) +wallStep root n = do + guard (isDerived n) + let ps = [(p, s) | (PackageVar p, Positive (ValueSet s _)) <- Map.toList (incompTerms n)] + guard (length ps == Map.size (incompTerms n)) + (x, w) <- case [(p, s) | (p, s) <- ps, p `notElem` pinnedPackages] of + [one] -> Just one + _ -> Nothing + guard (x `notElem` seeds root) + let against = [wallText root p | (p, _) <- ps, p `elem` pinnedPackages] + pinned = nub [wallText root p | c <- externals n, Fact (CauseOnlyInstalled p (_ : _)) <- [incompCause c]] + guard (not (null against) || not (null pinned)) + pure (x, w, if null against then pinned else against) + where + pinnedPackages = map fst (pinnedWalls root) + +-- | The dependency leaves the seeds force, as (depender, its range, dependee, +-- its range). A leaf is in play when its depender's range covers a seed's, or +-- covers the dependee range of a leaf already in play; the chain from the +-- request is then forced. A fixed point. +inPlay :: Incompatibility Var -> [(PackageName, InstanceSet, PackageName, InstanceSet)] +inPlay root = grow [l | l@(d, s, _, _) <- allDeps, or [r `isSubsetOf` s | (p, r) <- seedRanges root, p == d]] + where + allDeps = [l | c <- externals root, Just l <- [asDependency c]] + grow have = + let more = [l | l@(d, s, _, _) <- allDeps, not (l `elemBy` have), or [r `isSubsetOf` s | (_, _, q, r) <- have, q == d]] + in if null more then have else grow (have ++ more) + elemBy l have = l `elem` have + +-- -------------------------------------------------------------------------- +-- The pivot story +-- -------------------------------------------------------------------------- + +-- | For a proof with no wall to name: the package the search gave up on, read +-- off the step that dropped it. +-- +-- A step resolves on one package, the pivot, and either keeps a narrowed term +-- for it or drops it when its two terms union to ⊤. The step that drops @p@ is +-- the proof's own statement that, with the step's remaining terms all in force, +-- no version of @p@ is left — so the terms are named, and the \"together\" is the +-- conjunction the incompatibility is. +-- +-- Which package. Every pivot is dropped somewhere, and most of them are dropped +-- at the one step that refutes their whole range in one go. The one worth a +-- sentence is the package whose range had to be cut in pieces and refuted a +-- piece at a time: a step below narrowed its term before a step above dropped +-- it ('droppedStep'). Of those, the one dropped nearest the root is the last +-- thing the solver had to give up on. +pivotStory :: Rule (Incompatibility Var) Text +pivotStory root = do + (p, node) <- nearestRoot (everywhere (droppedStep root) root) + pure (gaveUpOn p node) + +-- | A step that dropped a package a step below had narrowed. A seed is never +-- the package, nor is one the headline already names as a wall: it is pinned +-- or unbuildable, and the wall says so in fewer words. +droppedStep :: Incompatibility Var -> Rule (Incompatibility Var) (PackageName, Incompatibility Var) +droppedStep root n = do + (a, b) <- derivedFrom n + v <- dropped n a b + p <- case v of + PackageVar p -> Just p + FlagVar{} -> Nothing + guard (p `notElem` seeds root) + guard (p `notElem` walled root) + guard (narrowedBelow v a || narrowedBelow v b) + pure (p, n) + +-- | The pivot of a step that dropped it: the one package both causes name and +-- the step does not. Every other package the causes share survives the step, +-- intersected, so at most one is missing. +dropped :: Incompatibility Var -> Incompatibility Var -> Incompatibility Var -> Maybe Var +dropped n a b = + case [p | p <- Map.keys (Map.intersectionWith const (incompTerms a) (incompTerms b)), Map.notMember p (incompTerms n)] of + [p] -> Just p + _ -> Nothing + +-- | Does some step in this subtree narrow @p@: resolve on it and keep it? The +-- step's term for @p@ is then the union of its causes' two terms and differs +-- from both; a package the causes merely share is intersected instead, and a +-- pivot whose union equals one side learnt nothing. +narrowedBelow :: Var -> Incompatibility Var -> Bool +narrowedBelow p n = case derivedFrom n of + Just (a, b) -> narrowedAt p n a b || narrowedBelow p a || narrowedBelow p b + Nothing -> False + +narrowedAt :: Var -> Incompatibility Var -> Incompatibility Var -> Incompatibility Var -> Bool +narrowedAt p n a b + | Just ta <- Map.lookup p (incompTerms a) + , Just tb <- Map.lookup p (incompTerms b) + , Just t <- Map.lookup p (incompTerms n) = + sameTerm t (unionTerm ta tb) && not (sameTerm t ta) && not (sameTerm t tb) + | otherwise = False + +-- | The sentence. The step's positive terms are what has to be present +-- together; a negative term is a way out — \"unless q <2\" — since +-- ¬(A ∧ B ∧ q ∉ R) is A ∧ B → q ∈ R. The dependers come first, as \"lsp-types +-- >=2.0.0.0 needs regex\", so no pronoun has to reach back for @p@. When the +-- only things present are the dependers themselves, \"needs regex, and … +-- compatible with lsp-types\" would say the same thing twice, and the shape is +-- \"no version of p suits d\", where \"suits\" carries the dependency. +gaveUpOn :: PackageName -> Incompatibility Var -> Text +gaveUpOn p node + | not (null positives) + , all ((`elem` dependers) . fst) positives = + "No version of " <> pretty p <> " suits " <> listing (map (uncurry bare) positives) <> escape + | null leaves = + "No version of " <> pretty p <> " is compatible with " <> present <> escape + | otherwise = + needs <> ", and no version of " <> pretty p <> " is compatible with " <> present <> escape + where + positives = [(q, r) | (q, Positive r) <- Map.toList (incompTerms node)] + negatives = [bare q r | (q, Negative r) <- Map.toList (incompTerms node)] + present = case positives of + [] -> "anything" + [x] -> uncurry bare x + xs -> listing (map (uncurry bare) xs) <> " together" + escape = case negatives of + [] -> "" + ns -> " unless " <> T.intercalate " or " ns + -- The dependency leaves under the step whose dependee is @p@, one entry per + -- depender with its ranges unioned: each leaf says @d ∈ Sᵢ@ depends on @p@, + -- so @d ∈ ⋃S@ does. + leaves = + Map.toList + (Map.fromListWith union [(d, s) | c <- externals node, Fact (CauseDependency d s g (q, _)) <- [incompCause c], Map.null g, q == p, d /= p]) + dependers = map (PackageVar . fst) leaves + needs = case leaves of + [(d, s)] -> namedP d s <> " needs " <> pretty p + ds -> listing [namedP d s | (d, s) <- ds] <> (if length ds == 2 then " both need " else " all need ") <> pretty p diff --git a/src/PubGrub/Cabal/Report/Layout.hs b/src/PubGrub/Cabal/Report/Layout.hs new file mode 100644 --- /dev/null +++ b/src/PubGrub/Cabal/Report/Layout.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Two layers a caller can put over a rendered proof: wrapping to the +-- terminal's width, and colour. Neither changes a word. 'PubGrub.Report' itself +-- does neither, so its output stays plain text, one sentence per line, for a +-- tool that compares proofs or counts their sentences. +module PubGrub.Cabal.Report.Layout + ( wrapProof + , styleProof + , rangeToken + ) where + +import Data.Char (isDigit) +import Data.Text (Text) +import qualified Data.Text as T + +-- | Wrap every line of a rendered proof (or headline) at @width@ columns, with a +-- four-space hanging indent on continuation lines, and never inside a range. +-- +-- A proof sentence is a mixture of prose and ranges, and a range broken across +-- lines — @>=0.10.8.1 &&@ at one end and @<0.10.9.0 ||@ at the other — is the +-- worst place a terminal can wrap it. So a range is an atom here: a token that +-- opens with a comparison, @&&@, @||@, @(installed)@ or a bare version sticks to +-- the token before it, and a break falls only between atoms. An atom too long for +-- a line of its own is broken before a @||@, the one seam a range has, and an atom +-- with no seam overflows rather than break inside. +-- +-- 'PubGrub.Report.reportConflict' does not wrap: its output is one sentence per +-- line, so a reader can count sentences by the connective that opens a line. A +-- continuation line starts with the indent and opens with no connective. +wrapProof :: Int -> Text -> Text +wrapProof width = T.intercalate "\n" . concatMap (wrapLine width) . T.lines + +wrapLine :: Int -> Text -> [Text] +wrapLine width line + | T.length line <= width = [line] + | otherwise = zipWith (<>) ("" : repeat indent) (build True [] (atoms (T.words line))) + where + indent = T.replicate 4 " " + room first = if first then width else width - T.length indent + + -- Greedy: an atom that fits joins the line, one that does not starts the next, + -- and one that fits no line is split at a seam. + build _ cur [] = [T.unwords cur | not (null cur)] + build first cur (a : as) + | T.length (T.unwords (cur ++ [a])) <= room first = build first (cur ++ [a]) as + | not (null cur) = T.unwords cur : build False [] (a : as) + | otherwise = case splitSeam (room first) a of + (h, Just rest) -> h : build False [] (rest : as) + (h, Nothing) -> h : build False [] as + + -- The longest prefix of the atom's @||@-separated pieces that fits, and what is + -- left; the whole atom when it has no seam that helps. + splitSeam n a = case T.splitOn " || " a of + pieces@(_ : _ : _) -> + let prefixes = [(k, T.intercalate " || " (take k pieces)) | k <- [length pieces, length pieces - 1 .. 1]] + in case [(k, t) | (k, t) <- prefixes, T.length t <= n] of + (k, t) : _ | k < length pieces -> (t, Just ("|| " <> T.intercalate " || " (drop k pieces))) + _ -> (a, Nothing) + _ -> (a, Nothing) + + -- A preposition joins what is before it to its object: "depends on + -- bytestring >=0.10.4 && <0.11" and "pinned to 4.21.0.0 (installed)" are one + -- atom each, so neither "depends" nor "on" is left at the end of a line. + atoms [] = [] + atoms (t : ts) = let (stuck, rest) = span rangeToken ts in go (t : stuck) rest + go cur [] = [T.unwords cur] + go cur (t : ts) + | t `elem` ["on", "of", "to", "with"], (u : us) <- ts = + let (stuck, rest) = span rangeToken us in go (cur ++ t : u : stuck) rest + | otherwise = let (stuck, rest) = span rangeToken ts in T.unwords cur : go (t : stuck) rest + +-- | A token of a rendered sentence that belongs to a range rather than to the +-- prose: a comparison, @&&@, @||@, @(installed)@, or a bare version (possibly +-- ending the sentence: @4.21.0.0@ or @4.21.0.0.@). 'wrapProof' keeps such a token +-- on the line of the token before it; 'styleProof' dims it. +rangeToken :: Text -> Bool +rangeToken u = + any (`T.isPrefixOf` u) [">=", ">", "<", "==", "^>=", "&&", "||", "(installed)"] + || isVersion u + where + isVersion t = let v = T.dropWhileEnd (== '.') t in not (T.null v) && T.all (\c -> isDigit c || c == '.') v + +-- | Colour a wrapped proof for a terminal: ranges dim, so the package names stand +-- out by contrast and a reader can skim the names and skip the bounds; the +-- connective that opens a sentence bold, so the sentences can be told apart from +-- their continuation lines; and the conclusion — the \"So,\" line — and the +-- headline bold throughout. Nothing is coloured that is not already there: +-- stripping the escapes gives the input back. +-- +-- Whether to apply it is the caller's decision, not this module's; the usual +-- test is a terminal, with @NO_COLOR@ unset and @TERM@ not @dumb@. Off a +-- terminal a proof should stay plain text. +styleProof :: Text -> Text +styleProof = T.intercalate "\n" . go False . T.lines + where + -- @wholeBold@: the line before was a headline or the conclusion, so a + -- continuation of it is bold throughout as well. + go _ [] = [] + go wholeBold (l : ls) + | T.null l = l : go False ls + | " " `T.isPrefixOf` l = (if wholeBold then bold l else tokens 0 l) : go wholeBold ls + | "No solution" `T.isPrefixOf` l || "So, because" `T.isPrefixOf` l = bold l : go True ls + | otherwise = tokens (openerOf (T.words l)) l : go False ls + + tokens opener l = + let (lead, body) = T.span (== ' ') l + (op, rest) = splitAt opener (T.words body) + in lead <> T.unwords (map bold op ++ dimRuns rest) + + -- A run of range tokens is one dimmed span. + dimRuns [] = [] + dimRuns ws = case span rangeToken ws of + ([], w : rest) -> w : dimRuns rest + (run, rest) -> dim (T.unwords run) : dimRuns rest + + -- How many leading tokens make up the connective: "Because", "And because", + -- and either with a line number, "1. Because"; a continuation line has none. + openerOf ws = case ws of + (n : "And" : "because" : _) | isNumber n -> 3 + (n : "Because" : _) | isNumber n -> 2 + ("And" : "because" : _) -> 2 + ("Because" : _) -> 1 + _ -> 0 + isNumber n = case T.unsnoc n of + Just (ds, '.') -> not (T.null ds) && T.all isDigit ds + _ -> False + bold t = "\ESC[1m" <> t <> "\ESC[0m" + dim t = "\ESC[2m" <> t <> "\ESC[0m" diff --git a/src/PubGrub/Cabal/Report/Rule.hs b/src/PubGrub/Cabal/Report/Rule.hs new file mode 100644 --- /dev/null +++ b/src/PubGrub/Cabal/Report/Rule.hs @@ -0,0 +1,146 @@ +-- | The little language the reporting rules are written in. +-- +-- A rule is a partial function: handed a piece of the derivation tree, it +-- either fires with what it makes of that piece or declines. It is written as a +-- @do@ block in 'Maybe', in which every line does one of three things: +-- +-- * __reads a view__ of the tree — 'chainStep', 'asDependency', 'runWhile' — +-- and declines if the tree is not that shape; +-- * __states a guard__ that keeps the sentence sound — @guard@ over +-- 'PubGrub.SetOps.isSubsetOf', 'sameTerms' — and declines if it fails; +-- * __says the sentence__, on its last line. +-- +-- A table of rules is tried in order by 'firstOf' and the first to fire wins, so +-- the order of a table is part of its meaning and is written down where the +-- table is. A rule over a pair of facts that does not care which is which is +-- wrapped in 'symmetric'. +-- +-- Nothing here renders text. The views are read-only and the guards are +-- predicates, so a rule cannot change what the proof claims, only how it is +-- said; the soundness argument of each rule is made where the rule is written, +-- and this module supplies the vocabulary the argument is made in. +module PubGrub.Cabal.Report.Rule + ( -- * Re-exported from "PubGrub.Derivation" + Rule + , firstOf + , symmetric + , isDerived + , derivedFrom + , bothExternal + , bothDerived + , chainStep + , externals + , everywhere + , nearestRoot + , runWhile + -- * Views of an external fact + , asRequest + , asHole + , asDependency + -- * Views of terms + , positive + , negative + , unions + , sameTerm + , sameTerms + , mergeFacts + ) where + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Distribution.Types.PackageName (PackageName) +import PubGrub.Cabal (CabalFact (..), Var (..)) +import PubGrub.Cabal.InstanceSet (InstanceSet) +import PubGrub.Cabal.Value (ValueSet (..)) +import PubGrub.Derivation +import PubGrub.Incompatibility (Incompatibility (..)) +import PubGrub.SetOps (SetOps (union)) +import PubGrub.Term (Term (..)) + +-- -------------------------------------------------------------------------- +-- Views of an external fact +-- -------------------------------------------------------------------------- + +-- | A seed: the package and the range it was requested in. +asRequest :: Rule (Incompatibility Var) (PackageName, InstanceSet) +asRequest c = case asSeed c of + Just (CauseRequest p s) -> Just (p, s) + _ -> Nothing + +-- | A hole: a range the solver found to hold no releases. +asHole :: Rule (Incompatibility Var) (PackageName, InstanceSet) +asHole c = case asNoValues c of + Just (PackageVar p, s) -> Just (p, vsInstances s) + _ -> Nothing + +-- | An /unconditional/ dependency fact whose dependee term survived, as +-- @(depender, its range, dependee, its range)@. A fact under a flag guard is not +-- this view: every rule built on it reads the fact as "p in S depends on q in +-- R", which a guarded fact does not say, and such facts are rendered from their +-- cause instead. 'PubGrub.Cabal.fromDependency' drops the dependee +-- term when the dependency is unsatisfiable, and then there is no \"depends on\" +-- left to render: the clause is a bare ban on the depender and reads as one. +asDependency :: Rule (Incompatibility Var) (PackageName, InstanceSet, PackageName, InstanceSet) +asDependency c = case asFact c of + Just (CauseDependency p s g (q, r)) + | q /= p, Map.null g, Map.member (PackageVar q) (incompTerms c) -> Just (p, s, q, r) + _ -> Nothing + +-- -------------------------------------------------------------------------- +-- Views of terms +-- -------------------------------------------------------------------------- + +-- | The set of a positive term; nothing for a negative one. +positive :: Term a -> Maybe a +positive (Positive s) = Just s +positive _ = Nothing + +-- | The set of a negative term; nothing for a positive one. +negative :: Term a -> Maybe a +negative (Negative s) = Just s +negative _ = Nothing + +-- | The union of every set in the list, joined from the right in the order +-- given; nothing for an empty list. +unions :: [InstanceSet] -> Maybe InstanceSet +unions [] = Nothing +unions (s : ss) = Just (go s ss) + where + go x [] = x + go x (y : ys) = x `union` go y ys + +-- | Two terms of the same polarity over the same set. 'InstanceSet' is +-- canonical, so equality is the semantic test. +sameTerm :: Term ValueSet -> Term ValueSet -> Bool +sameTerm = (==) + +-- | Two term maps naming the same packages, term for term the same. +sameTerms :: Map Var (Term ValueSet) -> Map Var (Term ValueSet) -> Bool +sameTerms = (==) + +-- | The facts of a run as one term map: every set unioned, polarity kept. A +-- package that is a depender in one fact and a dependee in another has no +-- merged term, and refusing to merge those is what keeps the union argument of +-- the widening rule honest — it holds for a run with /one/ depender and nothing +-- else. +mergeFacts :: [Incompatibility Var] -> Maybe (Map Var (Term ValueSet)) +mergeFacts = foldr step (Just Map.empty) + where + step f acc = acc >>= combineWith sameWay (incompTerms f) + sameWay (Positive x) (Positive y) = Just (Positive (x `union` y)) + sameWay (Negative x) (Negative y) = Just (Negative (x `union` y)) + sameWay _ _ = Nothing + +-- | Combine two term maps package by package, keeping the terms only one of +-- them names and failing the whole map where @f@ fails on a shared one. +combineWith + :: (Term ValueSet -> Term ValueSet -> Maybe (Term ValueSet)) + -> Map Var (Term ValueSet) + -> Map Var (Term ValueSet) + -> Maybe (Map Var (Term ValueSet)) +combineWith f a b = sequenceA (Map.unionWith comb (Just <$> a) (Just <$> b)) + where + comb mx my = do + x <- mx + y <- my + f x y diff --git a/src/PubGrub/Cabal/Report/Wording.hs b/src/PubGrub/Cabal/Report/Wording.hs new file mode 100644 --- /dev/null +++ b/src/PubGrub/Cabal/Report/Wording.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | The sentences a proof is made of: the standard PubGrub forms, in cabal's +-- range syntax. +-- +-- The PubGrub algorithm leaves the wording to the implementation and names a +-- few special cases; these sentences follow its own examples. The sentences +-- are meant to be the same, not the same bytes: ranges print in Cabal syntax +-- (@>=1.0.0 && <2@), and a declared range prints as its author spelled it +-- (@^>=1.0.0@, see 'PubGrub.VersionSet.declared'). +-- +-- Every function here answers a fragment with no connective in front of it and +-- no period after it, because the rules that use them put a fragment after a +-- \"Because\" of their own and the walker ends every line as a sentence. A +-- fragment must therefore never open with \"because\" or \"and\"; that is why an +-- unbuildable release \"needs pkg-config package libpq\" rather than \"cannot be +-- built because …\". +module PubGrub.Cabal.Report.Wording + ( -- * The words, as the walker takes them + wording + -- * A variable with its set + , named + , bare + -- * A package with its range + , namedP + , bareP + -- * Facts + , dep + , guardedDep + , fact + , hole + , leaf + -- * Conclusions + , summary + , summaryTerms + -- * Re-exported from "PubGrub.Report" + , listing + , anyOf + ) where + +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import Distribution.Pretty (prettyShow) +import Distribution.Types.PackageName (PackageName) +import PubGrub.Cabal (CabalFact (..), Flag, Guard, + UnbuildableReason (..), + Var (..)) +import PubGrub.Cabal.InstanceSet (InstanceSet, isEveryVersion) +import PubGrub.Cabal.Value (BoolSet (..), ValueSet (..)) +import PubGrub.Incompatibility (Incompatibility (..)) +import PubGrub.Pretty (Pretty (..)) +import PubGrub.Report (Formatter (..), anyOf, listing, + summaryWith) +import qualified PubGrub.Report as Report +import PubGrub.Term (Term) + +-- | The cabal domain's words, with no rules and no pass: the half of a +-- t'Formatter' that this module owns. "PubGrub.Cabal.Report" adds the rest. +wording :: Formatter Var +wording = + Formatter + { sayFact = fact + , sayNoValues = hole + , sayTerms = summaryTerms + , prepare = id + , lineRules = [] + , clauseRules = [] + } + +-- | A variable with the set it is constrained to, as words. A package set +-- admitting every version reads \"every version of foo\" where the sentence +-- calls for it — as the subject of \"depends on\" or \"requires\" — and the bare +-- name where it does not: \"foo is forbidden\", not \"every version of foo is +-- forbidden\", and \"depends on bar\" rather than \"depends on every version of +-- bar\". A flag reads as its owner with a sign: @foo +fast@, @foo -fast@, or +-- @foo flag fast@ when both values are in. +named :: Var -> ValueSet -> Text +named (PackageVar p) s = namedP p (vsInstances s) +named v s = bare v s + +-- | 'named' where the sentence does not call for \"every version of\": a package +-- set admitting every version reads as the bare name. +bare :: Var -> ValueSet -> Text +bare (PackageVar p) s = bareP p (vsInstances s) +bare (FlagVar p f) s = pretty p <> " " <> flagText f (vsFlags s) + +-- | 'named' for a package and its set of instances. +namedP :: PackageName -> InstanceSet -> Text +namedP p s + | isEveryVersion s = "every version of " <> pretty p + | otherwise = pretty p <> " " <> pretty s + +-- | 'bare' for a package and its set of instances. +bareP :: PackageName -> InstanceSet -> Text +bareP p s + | isEveryVersion s = pretty p + | otherwise = pretty p <> " " <> pretty s + +-- | What a set of a flag's values says: @+fast@, @-fast@, or the flag by name +-- when both values are in. +flagText :: Flag -> BoolSet -> Text +flagText f bs = case (allowsTrue bs, allowsFalse bs) of + (True, False) -> "+" <> pretty f + (False, True) -> "-" <> pretty f + (True, True) -> "flag " <> pretty f + (False, False) -> "no value of " <> pretty f + +-- | A guard as its flags with their required values: @+fast -tidy@. +guardText :: Guard -> Text +guardText g = T.unwords [(if b then "+" else "-") <> pretty f | (f, b) <- Map.toList g] + +-- | A dependency fact. The depender's range is kept so distinct derivation +-- steps stay distinct (\"assoc ==1.0.2 depends on …\" vs \"assoc >=1.0.2 && <1.1 +-- depends on …\"). +dep :: PackageName -> InstanceSet -> PackageName -> InstanceSet -> Text +dep p1 r1 p2 r2 = namedP p1 r1 <> " depends on " <> bareP p2 r2 + +-- | A dependency fact under a flag guard: \"foo >=1 && <2 with +fast depends on +-- bar\". With an empty guard it is 'dep'. +guardedDep :: PackageName -> InstanceSet -> Guard -> PackageName -> InstanceSet -> Text +guardedDep p1 r1 g p2 r2 + | Map.null g = dep p1 r1 p2 r2 + | otherwise = namedP p1 r1 <> " with " <> guardText g <> " depends on " <> bareP p2 r2 + +-- | An external fact at a leaf of the proof, or what a derived node's terms +-- conclude. A fact is rendered from its cause rather than from its terms so +-- that it explains itself: an empty range reads as unsatisfiable rather than +-- as a conflict with anything else; a compiler-provided package names the +-- version it is pinned to, since the bound that failed is only legible against +-- that version and nothing else in the proof states it; and a release that +-- cannot be built here says so, and why, rather than looking absent. +leaf :: Incompatibility Var -> Text +leaf = Report.leaf wording + +-- | What a fact says. The clause it is the cause of rides along for the one +-- case whose sentence depends on it. +fact :: CabalFact -> Incompatibility Var -> Text +fact f c = case f of + CauseRequest p s -> bareP p s <> " is requested" + CauseConstraint (PackageVar p) s -> pretty p <> " is constrained to " <> pretty (vsInstances s) + CauseConstraint (FlagVar p f') s -> pretty p <> " is constrained to " <> flagText f' (vsFlags s) + CauseOnlyInstalled p [] -> pretty p <> " is not installed and cannot be built from source" + CauseOnlyInstalled p vs -> + pretty p <> " is pinned to " <> T.intercalate " or " (map pretty vs) <> " (installed)" + CauseUnbuildable p s g why + | Map.null g -> namedP p s <> " " <> reasons why + | otherwise -> namedP p s <> " with " <> guardText g <> " " <> reasons why + CauseDeclaresFlag p s f' -> namedP p s <> " declares flag " <> pretty f' + -- 'PubGrub.Cabal.fromDependency' drops the dependee's term when the + -- dependency is unsatisfiable, and then there is no \"depends on\" left: the + -- clause is a bare ban on the depender and reads as one. + CauseDependency p s g (q, r) + | Map.member (PackageVar q) (incompTerms c) -> guardedDep p s g q r + | otherwise -> summary c + +-- | The solver's own leaf: a range the solver found to hold no releases. +hole :: Var -> ValueSet -> Text +hole v s = "no version for " <> pretty v <> " in " <> pretty s + +-- | Why a release cannot be built, as the predicate of its sentence: \"needs +-- pkg-config package libpq, which is not found\", and \"is marked buildable: +-- False\". The two are joined with \"and\" when both hold, and several modules +-- share one \"needs\". +-- +-- The module is spelled as Cabal-syntax prints the @pkgconfig-depends@ field: +-- @libpq@ unbounded, @zlib >=1.2@ with its range. Cabal's own message reads +-- \"pkg-config package libpq-any, not found in the pkg-config database\"; the +-- @-any@ is its spelling of the empty range, and is not copied. +reasons :: NonEmpty UnbuildableReason -> Text +reasons why = + T.intercalate " and " $ + ["is marked buildable: False" | NotBuildable `elem` why] ++ needs + where + needs = case [T.pack (prettyShow d) | MissingPkgConfig d <- NE.toList why] of + [] -> [] + [m] -> ["needs pkg-config package " <> m <> ", which is not found"] + ms -> ["needs pkg-config packages " <> listing ms <> ", which are not found"] + +-- | What an incompatibility says: the standard sentences +-- ('PubGrub.Report.summaryWith') over cabal's names. +summary :: Incompatibility Var -> Text +summary c = summaryTerms (incompTerms c) + +-- | 'summary' over the terms alone. +summaryTerms :: Map Var (Term ValueSet) -> Text +summaryTerms = summaryWith named bare diff --git a/src/PubGrub/Cabal/Value.hs b/src/PubGrub/Cabal/Value.hs new file mode 100644 --- /dev/null +++ b/src/PubGrub/Cabal/Value.hs @@ -0,0 +1,169 @@ +-- | The values a 'PubGrub.Cabal.Var' takes, and sets of them. +-- +-- A package variable takes an 'Instance'; a flag variable takes a 'Bool'. A +-- value is therefore a sum, 'Value'. A /set/ of values is not: the subsets of +-- @A + B@ are the pairs of a subset of @A@ and a subset of @B@, so t'ValueSet' +-- is the product of an 'InstanceSet' and a t'BoolSet'. Every set operation is +-- componentwise and total, with no case for sets \"of different kinds\" — a +-- package variable's set simply has an empty flag component, and a flag +-- variable's set an empty instance component. 'InstanceSet' is the same shape +-- one level down: the installed units and the source range are the two halves +-- of a set over @PreInstalled + Version@. +module PubGrub.Cabal.Value + ( -- * Values + Value (..) + , valueInstance + -- * Sets of values + , BoolSet (..) + , boolSet + , bothValues + , neitherValue + , memberBool + , ValueSet (..) + , emptyValueSet + , instanceSet + , flagSet + , singletonValue + , memberValue + -- * A plan + , Resolved (..) + , resolvedInstance + ) where + +import qualified Data.Text as T +import Distribution.Types.Flag (FlagAssignment, showFlagAssignment) +import PubGrub.Cabal.InstanceSet (Instance (..), InstanceSet, + emptyInstanceSet, memberInstance, + singletonInstance) +import PubGrub.Cabal.PreInstalled (PreInstalledPackage) +import PubGrub.Cabal.Version (Version) +import PubGrub.Pretty (Pretty (..)) +import PubGrub.SetOps (SetOps (..)) + +-- -------------------------------------------------------------------------- +-- Values +-- -------------------------------------------------------------------------- + +-- | What a variable takes: an instance for a package, a Boolean for a flag. +data Value + = PackageValue Instance + | FlagValue Bool + deriving (Eq, Ord, Show) + +-- | The instance a package's value holds; nothing for a flag's. +valueInstance :: Value -> Maybe Instance +valueInstance (PackageValue i) = Just i +valueInstance (FlagValue _) = Nothing + +instance Pretty Value where + pretty (PackageValue i) = pretty i + pretty (FlagValue True) = T.pack "on" + pretty (FlagValue False) = T.pack "off" + +-- -------------------------------------------------------------------------- +-- Sets +-- -------------------------------------------------------------------------- + +-- | A subset of @{False, True}@. +data BoolSet = BoolSet + { allowsFalse :: Bool + , allowsTrue :: Bool + } + deriving (Eq, Ord, Show) + +instance SetOps BoolSet where + empty = neitherValue + union (BoolSet f t) (BoolSet f' t') = BoolSet (f || f') (t || t') + intersect (BoolSet f t) (BoolSet f' t') = BoolSet (f && f') (t && t') + difference (BoolSet f t) (BoolSet f' t') = BoolSet (f && not f') (t && not t') + isEmpty (BoolSet f t) = not f && not t + isSubsetOf (BoolSet f t) (BoolSet f' t') = (f' || not f) && (t' || not t) + isDisjoint (BoolSet f t) (BoolSet f' t') = not (f && f') && not (t && t') + +-- | The set holding exactly one of a flag's values. +boolSet :: Bool -> BoolSet +boolSet True = BoolSet False True +boolSet False = BoolSet True False + +-- | The sets holding both of a flag's values, and neither. +bothValues, neitherValue :: BoolSet +bothValues = BoolSet True True +neitherValue = BoolSet False False + +-- | Is the flag's value in the set? +memberBool :: Bool -> BoolSet -> Bool +memberBool True = allowsTrue +memberBool False = allowsFalse + +instance Pretty BoolSet where + pretty (BoolSet True True) = T.pack "on or off" + pretty (BoolSet False True) = T.pack "on" + pretty (BoolSet True False) = T.pack "off" + pretty (BoolSet False False) = T.pack "neither" + +-- | A set of values: some instances and some Booleans. Both components are +-- canonical, so the set has a lawful 'Eq' and 'Ord' and an exact 'isEmpty'. +data ValueSet = ValueSet + { vsInstances :: InstanceSet + , vsFlags :: BoolSet + } + deriving (Eq, Ord, Show) + +instance SetOps ValueSet where + empty = emptyValueSet + union (ValueSet a b) (ValueSet a' b') = ValueSet (a `union` a') (b `union` b') + intersect (ValueSet a b) (ValueSet a' b') = ValueSet (a `intersect` a') (b `intersect` b') + difference (ValueSet a b) (ValueSet a' b') = ValueSet (a `difference` a') (b `difference` b') + isEmpty (ValueSet a b) = isEmpty a && isEmpty b + isSubsetOf (ValueSet a b) (ValueSet a' b') = a `isSubsetOf` a' && b `isSubsetOf` b' + isDisjoint (ValueSet a b) (ValueSet a' b') = a `isDisjoint` a' && b `isDisjoint` b' + +-- | No values. @Negative emptyValueSet@ is the always-true term ⊤ for any +-- variable; @Positive emptyValueSet@ is the never-true term ⊥. +emptyValueSet :: ValueSet +emptyValueSet = ValueSet emptyInstanceSet neitherValue + +-- | These instances, and no Boolean: the set a term about a package ranges +-- over. +instanceSet :: InstanceSet -> ValueSet +instanceSet s = ValueSet s neitherValue + +-- | These Booleans, and no instance: the set a term about a flag ranges over. +flagSet :: BoolSet -> ValueSet +flagSet = ValueSet emptyInstanceSet + +-- | The set holding exactly one value — the shape of a decision. +singletonValue :: Value -> ValueSet +singletonValue (PackageValue i) = instanceSet (singletonInstance i) +singletonValue (FlagValue b) = flagSet (boolSet b) + +-- | Is the value in the set? +memberValue :: Value -> ValueSet -> Bool +memberValue (PackageValue i) s = memberInstance i (vsInstances s) +memberValue (FlagValue b) s = memberBool b (vsFlags s) + +-- | The components that hold anything; in practice one, since a set is only +-- ever about one variable. +instance Pretty ValueSet where + pretty (ValueSet is bs) = + T.intercalate (T.pack " or ") ([pretty is | not (isEmpty is)] ++ [pretty bs | not (isEmpty bs)]) + +-- -------------------------------------------------------------------------- +-- A plan +-- -------------------------------------------------------------------------- + +-- | One package of a plan, as a reader sees it: the solver's decisions on a +-- source release and on each of its flags, folded into one entry. +data Resolved + = Installed PreInstalledPackage + | Built Version FlagAssignment + deriving (Eq, Show) + +-- | The instance a plan's entry decided on, without its flags. +resolvedInstance :: Resolved -> Instance +resolvedInstance (Installed pip) = UsePreInstalled pip +resolvedInstance (Built v _) = BuildSource v + +instance Pretty Resolved where + pretty (Installed pip) = pretty (UsePreInstalled pip) + pretty (Built v fa) = pretty v <> T.pack (showFlagAssignment fa) diff --git a/src/PubGrub/Cabal/Version.hs b/src/PubGrub/Cabal/Version.hs new file mode 100644 --- /dev/null +++ b/src/PubGrub/Cabal/Version.hs @@ -0,0 +1,23 @@ +-- | The solver's version type, with the conversions to and from Cabal's. +-- +-- "PubGrub.Version" is re-exported whole, so the cabal side imports this module +-- in its place. The conversions are exact in both directions, because the +-- spelling survives: a version converted in and back out is the Cabal version +-- it came from, trailing zeros included, so it still names its release's +-- @.cabal@. +module PubGrub.Cabal.Version + ( module PubGrub.Version + , fromCabalVersion + , toCabalVersion + ) where + +import qualified Distribution.Types.Version as Cabal +import PubGrub.Version + +-- | A Cabal version as the solver's. +fromCabalVersion :: Cabal.Version -> Version +fromCabalVersion = mkVersion . Cabal.versionNumbers + +-- | The Cabal version a solver's version came from. +toCabalVersion :: Version -> Cabal.Version +toCabalVersion = Cabal.mkVersion . versionNumbers diff --git a/src/PubGrub/Cabal/VersionSet.hs b/src/PubGrub/Cabal/VersionSet.hs new file mode 100644 --- /dev/null +++ b/src/PubGrub/Cabal/VersionSet.hs @@ -0,0 +1,69 @@ +-- | Version sets, with the conversions to and from Cabal's 'VersionRange'. +-- +-- "PubGrub.VersionSet" is re-exported whole, so the cabal side imports this +-- module in its place. Cabal's syntax stops here: 'fromVersionRange' folds a +-- declared range into a set and tags it with the author's spelling, and +-- 'toVersionRange' reads a set back out for Cabal's own tools. +module PubGrub.Cabal.VersionSet + ( module PubGrub.VersionSet + , fromVersionRange + , toVersionRange + ) where + +import qualified Data.Text as T +import Distribution.Pretty (prettyShow) +import Distribution.Types.VersionRange (VersionRange, anyVersion, + earlierVersion, + foldVersionRange, + intersectVersionRanges, + laterVersion, noVersion, + orEarlierVersion, + orLaterVersion, thisVersion, + unionVersionRanges) +import PubGrub.Cabal.Version (fromCabalVersion, + toCabalVersion, version0) +import PubGrub.VersionSet + +-- | Build a canonical 'VersionSet' from any 'VersionRange', remembering the +-- range's spelling as the set's 'declared' tag: a range that arrives here was +-- written by someone, and that spelling is what a report should quote back. +-- +-- Cabal's 'foldVersionRange' does the desugaring — @^>=v@ into its major +-- window, @>=v@ into @==v || >v@ — and the set is then assembled with the +-- core's operations, so every comparison between bounds is made in __our__ +-- order. Two consecutive @^>=@ windows therefore touch and coalesce here. +fromVersionRange :: VersionRange -> VersionSet +fromVersionRange r = + declare (T.pack (prettyShow r)) (foldVersionRange fullVersionSet this later earlier unionVersionSet intersectionVersionSet r) + where + this = singletonVersionSet . fromCabalVersion + later = aboveVersionSet . fromCabalVersion + earlier = belowVersionSet . Just . fromCabalVersion + +-- | The canonical intervals as a 'VersionRange': @>=a && =v && =v@ +-- survives. Cabal prints this range exactly as 'renderVersionSet' spells the +-- set. +toVersionRange :: VersionSet -> VersionRange +toVersionRange vs = case map interval (intervals vs) of + [] -> noVersion + r : rs -> foldr1 unionVersionRanges (r : rs) + where + interval (Cut v Before, Cut w After) | v == w = thisVersion (toCabalVersion v) + interval (lo, hi) = case (lower lo, upper hi) of + (Nothing, Nothing) -> anyVersion + (Just l, Nothing) -> l + (Nothing, Just u) -> u + (Just l, Just u) -> intersectVersionRanges l u + + lower (Cut v Before) + | v == version0 = Nothing + | otherwise = Just (orLaterVersion (toCabalVersion v)) + lower (Cut v After) = Just (laterVersion (toCabalVersion v)) + lower Unbounded = Nothing -- unreachable: an interval never starts unbounded + + upper Unbounded = Nothing + upper (Cut w Before) = Just (earlierVersion (toCabalVersion w)) + upper (Cut w After) = Just (orEarlierVersion (toCabalVersion w)) diff --git a/test/ConstraintSpec.hs b/test/ConstraintSpec.hs new file mode 100644 --- /dev/null +++ b/test/ConstraintSpec.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | The other seed: a __constraint__, \"if this package is chosen, it is in this +-- range\" ('PubGrub.Cabal.constraint'), built over a toy world the way the +-- bridge builds one ('PubGrub.Cabal.Provider.constrainTo'). +-- +-- A request forces a package into the plan; a constraint only bounds it. The +-- four facts pinned down here are the ones a planner relies on: a constraint +-- steers a choice, a constraint on a package nobody needs is vacuous, a +-- constraint the requests cannot live with is a terminal failure that the proof +-- names, and the conflict set of that failure is the path to it. +module ConstraintSpec (tests) where + +import Data.List (maximumBy) +import qualified Data.Map.Strict as Map +import Data.Ord (comparing) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import Distribution.Types.PackageName (PackageName, mkPackageName) +import qualified Distribution.Version as Cabal +import PubGrub.Cabal (Var (..), fromDependency, + request) +import PubGrub.Cabal.Installed (InstalledDb, mkInstalledDb) +import PubGrub.Cabal.InstanceSet (HasVersion (version), + Instance (..), InstanceSet, + emptyInstanceSet, + memberInstance, + singletonInstance, + sourceInstances) +import PubGrub.Cabal.Provider (constrainTo) +import PubGrub.Cabal.Report (reportConflict) +import PubGrub.Cabal.Value (Value (..), ValueSet (..)) +import PubGrub.Cabal.Version (mkVersion) +import PubGrub.Cabal.VersionSet (fromVersionRange) +import PubGrub.Derivation (conflictSet) +import PubGrub.Incompatibility (Incompatibility) +import PubGrub.Provider (Provider (..)) +import PubGrub.SetOps (union) +import PubGrub.Solver (SolveError (..), solve) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, + testCase, (@?=)) + +-- -------------------------------------------------------------------------- +-- A toy world: root needs foo; foo has two releases; bar has one nobody needs +-- -------------------------------------------------------------------------- + +root, foo, bar :: PackageName +root = mkPackageName "root" +foo = mkPackageName "foo" +bar = mkPackageName "bar" + +inst :: [Int] -> Instance +inst = BuildSource . mkVersion + +rootI, foo1, foo2, bar1 :: Instance +rootI = inst [0] +foo1 = inst [1] +foo2 = inst [2] +bar1 = inst [1] + +setOf :: [Instance] -> InstanceSet +setOf = foldr (union . singletonInstance) emptyInstanceSet + +-- | The provider: newest instance the range admits, dependencies from a table. +-- @rootNeeds@ is what @root@ asks of @foo@, so the two worlds below differ in +-- one entry. +provider :: [Instance] -> Provider Var Maybe +provider rootNeeds = Provider expand' + where + expand' (PackageVar p) set = + case filter (`memberInstance` vsInstances set) (instancesOf p) of + [] -> pure (Nothing, []) + candidates -> + let chosen = maximumBy (comparing version) candidates + in pure + ( Just (PackageValue chosen) + , [fromDependency p (singletonInstance chosen) Map.empty d (setOf ds) | (d, ds) <- deps p chosen] + ) + expand' _ _ = pure (Nothing, []) + + instancesOf p + | p == root = [rootI] + | p == foo = [foo1, foo2] + | p == bar = [bar1] + | otherwise = [] + + deps p i + | p == root && i == rootI = [(foo, rootNeeds)] + | otherwise = [] + +-- | No compiler in this world: every package is source. +noInstalled :: InstalledDb +noInstalled = mkInstalledDb [] + +-- | @p@ must be in the range if chosen, in cabal's syntax. +constrained :: PackageName -> Cabal.VersionRange -> Incompatibility Var +constrained p r = constrainTo noInstalled p (sourceInstances (fromVersionRange r)) + +-- | Solve for @root@ with the given constraints. +run :: [Instance] -> [Incompatibility Var] -> Either (SolveError Var) (Map.Map Var Value) +run rootNeeds constraints = + case solve mempty (provider rootNeeds) (request root (singletonInstance rootI) : constraints) of + Nothing -> Left (NoSatisfier (PackageVar root) (request root (singletonInstance rootI))) + Just r -> r + +-- | 'run' with a failure rendered, so a plan can be compared with '@?='. +planOf :: [Instance] -> [Incompatibility Var] -> Either Text (Map.Map Var Value) +planOf rootNeeds = either (Left . proofOf) Right . run rootNeeds + +proofOf :: SolveError Var -> Text +proofOf (NoSolution i) = reportConflict i +proofOf (NoSatisfier p _) = T.pack ("internal error: no satisfier for " <> show p) +proofOf _ = T.pack "internal error" + +plan :: [(PackageName, Instance)] -> Map.Map Var Value +plan entries = Map.fromList [(PackageVar p, PackageValue i) | (p, i) <- entries] + +-- -------------------------------------------------------------------------- +-- Tests +-- -------------------------------------------------------------------------- + +tests :: TestTree +tests = + testGroup + "PubGrub.Cabal.constraint" + [ testCase "a constraint steers the choice to an older release" $ + planOf [foo1, foo2] [constrained foo (Cabal.earlierVersion (Cabal.mkVersion [2]))] + @?= Right (plan [(root, rootI), (foo, foo1)]) + , testCase "without it the newest release wins" $ + planOf [foo1, foo2] [] + @?= Right (plan [(root, rootI), (foo, foo2)]) + , testCase "a constraint on a package nothing needs is vacuous" $ + planOf [foo1, foo2] [constrained bar (Cabal.thisVersion (Cabal.mkVersion [99]))] + @?= Right (plan [(root, rootI), (foo, foo2)]) + , testCase "a constraint the request cannot live with is terminal, and the proof says so" $ + case run [foo2] [constrained foo (Cabal.earlierVersion (Cabal.mkVersion [2]))] of + Right _ -> assertFailure "expected no solution" + Left err -> do + let proof = proofOf err + assertBool ("proof names the constraint:\n" <> T.unpack proof) ("foo is constrained to <2" `T.isInfixOf` proof) + assertBool ("proof names the request:\n" <> T.unpack proof) ("root ==0 is requested" `T.isInfixOf` proof) + , testCase "the conflict set is the path to the failure" $ + case run [foo2] [constrained foo (Cabal.earlierVersion (Cabal.mkVersion [2]))] of + Left (NoSolution i) -> conflictSet i @?= Set.fromList [PackageVar root, PackageVar foo] + Left err -> assertFailure (T.unpack (proofOf err)) + Right _ -> assertFailure "expected no solution" + ] diff --git a/test/FlagSolveSpec.hs b/test/FlagSolveSpec.hs new file mode 100644 --- /dev/null +++ b/test/FlagSolveSpec.hs @@ -0,0 +1,818 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | End-to-end solver tests in which /flags/ are the interesting axis, plus +-- the provider-rule tests that need the same harness. +-- +-- 'SolverSpec' and 'PaperSpec' build worlds without flags, so the search over +-- flag values never runs there. What this module adds is the loop that closes +-- over the flag variables: a release's automatic flags become goals of their +-- own ('PubGrub.Incompatibility.declaresFlag'), its guarded dependencies name +-- them, and the solver learns \"not this value\" and the provider offers the +-- other. +-- +-- These tests run the __real__ provider. 'PubGrub.Cabal.Provider.mkExpand' is the whole +-- rule — candidate enumeration, flag emission, incompatibility emission — and it +-- takes its world as arguments, so 'worldProviderUnder' feeds it an in-memory +-- index instead of Hackage. Nothing about the rule is restated here: a +-- paraphrase of the rule can only ever test the paraphrase. +-- +-- What the worlds supply is the /data/: which packages and versions exist, +-- which flags each declares, and its dependencies as flag-guarded groups (the toy +-- analogue of @PubGrub.Cabal.Flatten.GuardedDeps@). A package absent from the world +-- has no versions at all, which is how these tests write an unsatisfiable +-- dependency. +module FlagSolveSpec (tests) where + +import Control.Exception (toException) +import Control.Monad.IO.Class (liftIO) +import Data.Either (fromLeft, isLeft) +import Data.IORef (IORef, modifyIORef', newIORef, + readIORef) +import qualified Data.List.NonEmpty as NE +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import Distribution.Types.Condition (Condition (..)) +import Distribution.Types.Dependency (Dependency, mainLibSet, + mkDependency) +import Distribution.Types.Flag (FlagName, mkFlagAssignment, + mkFlagName) +import Distribution.Types.PackageName (PackageName, mkPackageName) +import Distribution.Types.UnitId (mkUnitId) +import Distribution.Types.Version (mkVersion) +import Distribution.Version (anyVersion, thisVersion) +import PubGrub.Cabal (CabalFact (..), Flag (..), + UnbuildableReason (..), + Var (..), flagConstraint, + foldFlags, request) +import PubGrub.Cabal.Flatten (FlagModel (..)) +import PubGrub.Cabal.Installed (InstalledPkg (..), + mkInstalledDb) +import PubGrub.Cabal.InstanceSet (Instance (..), + InstanceSet (..), + singletonInstance, + sourceInstances) +import PubGrub.Cabal.PreInstalled (PreInstalledPackage (..)) +import PubGrub.Cabal.Provider (ParseError (..)) +import qualified PubGrub.Cabal.Provider as BP +import PubGrub.Cabal.Report (reportConflict) +import PubGrub.Cabal.Value (Resolved (..), Value (..), + instanceSet) +import PubGrub.Cabal.Version (Version) +import qualified PubGrub.Cabal.Version as V +import qualified PubGrub.Cabal.VersionSet as VersionSet +import PubGrub.Incompatibility (Cause (..), + Incompatibility (..)) +import PubGrub.Provider (Provider (Provider, expand)) +import PubGrub.Solver (SolveError (..), solve) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, + testCase, (@?=)) + +-- -------------------------------------------------------------------------- +-- A toy world with flags +-- -------------------------------------------------------------------------- + +-- | One source release: a version, and its dependencies as /flag-guarded groups/ +-- — the toy stand-in for @PubGrub.Cabal.Flatten.GuardedDeps@, which is what a +-- @.cabal@ file's conditional tree flattens to. +data Release = Release + { relVersion :: Version + , relGuarded :: [(Condition FlagName, [Dependency])] + } + +-- | A package: the flags it declares (with their defaults) and its releases. +-- Every release of a package shares the declared flags, as in a @.cabal@ file. +data Pkg = Pkg + { pkgFlags :: [(FlagName, Bool)] + , pkgReleases :: [Release] + } + +-- | The whole universe. A package /absent/ from the world has no versions at +-- all, which is how these tests write an unsatisfiable dependency: the provider +-- returns 'Nothing' and the solver mints a "no instances" incompatibility, +-- the same shape a missing Hackage package produces. +type World = [(PackageName, Pkg)] + +-- | The provider for a world under a flag model: the /real/ 'BP.mkExpand', +-- driven from an in-memory index built out of the world. Under 'FlagPackages' +-- every declared flag is automatic and a variable; under 'FixedFlags' the +-- guards are resolved at the declared defaults before the provider sees them, +-- which is what 'PubGrub.Cabal.Flatten.componentDepsStored' does to a real +-- release. +worldProviderUnder :: FlagModel -> UnbuildableHere -> World -> Provider Var TestM +worldProviderUnder = worldProviderUnderWith BP.noPreference + +-- | 'worldProviderUnder' with flag search and a 'BP.Preference'. +worldProviderUnderPreferring :: BP.Preference -> UnbuildableHere -> World -> Provider Var TestM +worldProviderUnderPreferring preference = worldProviderUnderWith preference FlagPackages + +-- | Which releases cannot be built here, and under which flag condition: +-- @Lit True@ for a release that cannot be built at all, as the toy analogue of +-- @PubGrub.Cabal.Flatten.unbuildableStored@. +type UnbuildableHere = [((PackageName, Version), Condition FlagName)] + +worldProviderUnderWith :: BP.Preference -> FlagModel -> UnbuildableHere -> World -> Provider Var TestM +worldProviderUnderWith preference model unbuildableHere world = + Provider (BP.mkExpand mempty preference (mkInstalledDb []) source) + where + source = + BP.ReleaseSource + { BP.rsVersionsOf = \p -> + maybe Set.empty (Set.fromList . map relVersion . pkgReleases) (lookup p world) + , BP.rsReadRelease = \p v -> pure (readRelease p v) + } + + releases :: Map (PackageName, Version) BP.Release + releases = + Map.fromList + [ ( (p, relVersion r) + , BP.Release + { BP.relAutomatic = case model of + FixedFlags -> [] + FlagPackages -> [Flag f d | (f, d) <- pkgFlags pk] + , BP.relGuarded = case model of + FixedFlags -> [(Lit True, deps) | (g, deps) <- relGuarded r, atDefaults (pkgFlags pk) g] + FlagPackages -> relGuarded r + , BP.relUnbuildable = [(g, NE.singleton NotBuildable) | ((p', v'), g) <- unbuildableHere, (p', v') == (p, relVersion r)] + , BP.relTools = [] + , BP.relSetup = [] + } + ) + | (p, pk) <- world + , r <- pkgReleases pk + ] + + readRelease p v = + maybe (Left (missing p v)) Right (Map.lookup (p, v) releases) + + missing p v = + ParseException (toException (userError ("not in world: " <> show (p, v)))) + +-- | A guard at the declared defaults; an undeclared flag is 'False', as in +-- 'PubGrub.Cabal.Flatten'. +atDefaults :: [(FlagName, Bool)] -> Condition FlagName -> Bool +atDefaults defaults = go + where + go (Var f) = fromMaybe False (lookup f defaults) + go (Lit b) = b + go (CNot c) = not (go c) + go (COr a b) = go a || go b + go (CAnd a b) = go a && go b + +worldProvider :: World -> Provider Var TestM +worldProvider = worldProviderUnder FlagPackages [] + +-- -------------------------------------------------------------------------- +-- The monad the tests solve in +-- -------------------------------------------------------------------------- + +-- The solver and the provider rule take their log actions as arguments, so plain +-- 'IO' with both silenced ('mempty') is the whole harness. +type TestM = IO + +runTestM :: TestM a -> IO a +runTestM = id + +-- -------------------------------------------------------------------------- +-- Running a world +-- -------------------------------------------------------------------------- + +root :: PackageName +root = pkg "root" + +rootInstance :: Instance +rootInstance = BuildSource v1 + +-- | Run the solver and fold its flag decisions into their owners, so an answer +-- reads as a plan. A failure is kept as its rendered proof. +runSolve :: Provider Var TestM -> IO (Either Text (Map PackageName Resolved)) +runSolve = runSolveWith [] + +-- | The same with further seeds after the request: constraints, in these tests. +runSolveWith :: [Incompatibility Var] -> Provider Var TestM -> IO (Either Text (Map PackageName Resolved)) +runSolveWith seeds provider = + either (Left . renderFailure) (Right . foldFlags) + <$> runTestM (solve mempty provider (request root (singletonInstance rootInstance) : seeds)) + +renderFailure :: SolveError Var -> Text +renderFailure (NoSolution i) = reportConflict i +renderFailure (NoSatisfier p _) = + T.pack ("internal error: no satisfier for " <> show p) +renderFailure _ = T.pack "internal error" + +solveWorld :: World -> IO (Either Text (Map PackageName Resolved)) +solveWorld = runSolve . worldProvider + +solveWorldUnder :: FlagModel -> World -> IO (Either Text (Map PackageName Resolved)) +solveWorldUnder model = runSolve . worldProviderUnder model [] + +solveWorldWith :: [(PackageName, Version)] -> World -> IO (Either Text (Map PackageName Resolved)) +solveWorldWith unbuildableHere = runSolve . worldProviderUnder FlagPackages [(pv, Lit True) | pv <- unbuildableHere] + +-- | Wrap a provider so that every @expand@ of a /package/ records it. The +-- solver asks exactly once per decision, so the tally counts decision attempts: +-- a package asked twice was reconsidered after a conflict. Flags are not +-- counted; they are decided with their owner and are not what these counts +-- measure. +countingProvider :: IORef [PackageName] -> Provider Var TestM -> Provider Var TestM +countingProvider ref provider = Provider $ \v range -> do + case v of + PackageVar p -> liftIO (modifyIORef' ref (p :)) + FlagVar{} -> pure () + expand provider v range + +solveCounting :: World -> IO (Either Text (Map PackageName Resolved), Map PackageName Int) +solveCounting world = do + ref <- newIORef [] + result <- runSolve (countingProvider ref (worldProvider world)) + asked <- readIORef ref + pure (result, Map.fromListWith (+) [(p, 1 :: Int) | p <- asked]) + +-- -------------------------------------------------------------------------- +-- Notation +-- -------------------------------------------------------------------------- + +pkg :: String -> PackageName +pkg = mkPackageName + +flg :: String -> FlagName +flg = mkFlagName + +v1, v2 :: Version +v1 = V.mkVersion [1, 0, 0] +v2 = V.mkVersion [2, 0, 0] + +dep :: PackageName -> Dependency +dep p = mkDependency p anyVersion mainLibSet + +type Group = (Condition FlagName, [Dependency]) + +always :: [PackageName] -> Group +always deps = (Lit True, map dep deps) + +whenOn, whenOff :: FlagName -> [PackageName] -> Group +whenOn f deps = (Var f, map dep deps) +whenOff f deps = (CNot (Var f), map dep deps) + +leaf :: Pkg +leaf = Pkg [] [Release v1 []] + +plain :: [PackageName] -> Pkg +plain deps = Pkg [] [Release v1 [always deps]] + +-- | The expected plan, written as @(package, version, flags)@ triples. +solutionOf :: [(PackageName, Version, [(FlagName, Bool)])] -> Map PackageName Resolved +solutionOf entries = + Map.fromList [(p, Built v (mkFlagAssignment fs)) | (p, v, fs) <- entries] + +-- -------------------------------------------------------------------------- +-- Tests +-- -------------------------------------------------------------------------- + +tests :: TestTree +tests = + testGroup + "Flags (end to end)" + [ defaultsUsed + , flagFlip + , fixedFlagsDoNotFlip + , heldFlag + , preferenceTests + , twoFlags + , unsatOverFlags + , unusedFlag + , irrelevantFlagRetried + , irrelevantFlagsDoNotCompound + , newestKeptFlagFlipped + , bootPackageStatesItself + , unbuildableStatesItself + , unbuildableUnderFlag + , selfDependency + ] + +-- | 1. The declared default is offered first, so a world that solves at the +-- defaults solves with them: @speedy@ is in the plan and @slow@ and @neat@ +-- are not. +defaultsUsed :: TestTree +defaultsUsed = + testCase "declared defaults are used when they solve" $ do + let fast = flg "fast" + tidy = flg "tidy" + world = + [ (pkg "root", plain [pkg "foo", pkg "bar"]) + , (pkg "foo", Pkg [(fast, True)] [Release v1 [whenOn fast [pkg "speedy"], whenOff fast [pkg "slow"]]]) + , (pkg "bar", Pkg [(tidy, False)] [Release v1 [whenOn tidy [pkg "neat"]]]) + , (pkg "speedy", leaf) + , (pkg "slow", leaf) + , (pkg "neat", leaf) + ] + result <- solveWorld world + result + @?= Right + ( solutionOf + [ (pkg "root", v1, []) + , (pkg "foo", v1, [(fast, True)]) + , (pkg "bar", v1, [(tidy, False)]) + , (pkg "speedy", v1, []) + ] + ) + +-- | 2. The central case. @foo@ has exactly one version, so the version axis +-- offers the solver nothing: the only way out is to flip @fast@. Under the +-- default (@True@) @foo@ needs @speedy@, which does not exist; under @False@ it +-- needs @slow@, which does. +-- +-- What has to happen: the guarded fact @{foo 1.0.0, foo:fast on, not speedy}@ +-- becomes a conflict once @speedy@ is found empty, conflict resolution learns +-- @foo 1.0.0 with +fast is forbidden@, and the provider is asked about the flag +-- again with only @off@ admitted. +flagFlip :: TestTree +flagFlip = + testCase "a flag flips when its default branch cannot be satisfied" $ do + let fast = flg "fast" + world = + [ (pkg "root", plain [pkg "foo"]) + , (pkg "foo", Pkg [(fast, True)] [Release v1 [whenOn fast [pkg "speedy"], whenOff fast [pkg "slow"]]]) + , (pkg "slow", leaf) + ] + result <- solveWorld world + result + @?= Right + ( solutionOf + [ (pkg "root", v1, []) + , (pkg "foo", v1, [(fast, False)]) + , (pkg "slow", v1, []) + ] + ) + +-- | 2b. The same world under 'FixedFlags' has no flip to make: every flag is at +-- its default, @speedy@ is required, and the world is unsatisfiable. This is +-- the knob the baseline comparison runs with by default. +fixedFlagsDoNotFlip :: TestTree +fixedFlagsDoNotFlip = + testCase "under fixed flags the default branch is the only branch" $ do + let fast = flg "fast" + world = + [ (pkg "root", plain [pkg "foo"]) + , (pkg "foo", Pkg [(fast, True)] [Release v1 [whenOn fast [pkg "speedy"], whenOff fast [pkg "slow"]]]) + , (pkg "slow", leaf) + ] + result <- solveWorldUnder FixedFlags world + assertBool "expected no solution under fixed flags" (isLeft result) + +-- | 3. Two flags, four total assignments, one viable: @a@ pulls in a package +-- that does not exist, and so does @b@, so only @-a -b@ survives. +twoFlags :: TestTree +twoFlags = + testCase "two flags: the solver finds the one viable assignment" $ do + let a = flg "a" + b = flg "b" + world = + [ (pkg "root", plain [pkg "foo"]) + , (pkg "foo", Pkg [(a, True), (b, True)] [Release v1 [whenOn a [pkg "nope"], whenOn b [pkg "nope-either"], whenOff a [pkg "x"], whenOff b [pkg "y"]]]) + , (pkg "x", leaf) + , (pkg "y", leaf) + ] + result <- solveWorld world + result + @?= Right + ( solutionOf + [ (pkg "root", v1, []) + , (pkg "foo", v1, [(a, False), (b, False)]) + , (pkg "x", v1, []) + , (pkg "y", v1, []) + ] + ) + +-- | 4. Both values of the flag lead to a missing package. The proof must name +-- both branches, with the flag's sign, so a reader can see each was tried. +unsatOverFlags :: TestTree +unsatOverFlags = + testCase "unsat over every value of a flag, and the proof names both" $ do + let fast = flg "fast" + world = + [ (pkg "root", plain [pkg "foo"]) + , (pkg "foo", Pkg [(fast, True)] [Release v1 [whenOn fast [pkg "speedy"], whenOff fast [pkg "slow"]]]) + ] + result <- solveWorld world + assertBool "expected no solution" (isLeft result) + let report = fromLeft T.empty result + assertBool ("report should mention +fast; got:\n" <> T.unpack report) (T.pack "+fast" `T.isInfixOf` report) + assertBool ("report should mention -fast; got:\n" <> T.unpack report) (T.pack "-fast" `T.isInfixOf` report) + +-- | 5. A declared flag that no dependency guard mentions stays at its default, +-- and costs no package decision: with no conflict anywhere, the provider is +-- asked about each package exactly once. +unusedFlag :: TestTree +unusedFlag = + testCase "a flag no dependency mentions stays at its default" $ do + let unused = flg "unused" + world = + [ (pkg "root", plain [pkg "foo"]) + , (pkg "foo", Pkg [(unused, True)] [Release v1 [always [pkg "bar"]]]) + , (pkg "bar", leaf) + ] + (result, asks) <- solveCounting world + result + @?= Right + ( solutionOf + [ (pkg "root", v1, []) + , (pkg "foo", v1, [(unused, True)]) + , (pkg "bar", v1, []) + ] + ) + asks @?= Map.fromList [(pkg "root", 1), (pkg "foo", 1), (pkg "bar", 1)] + +-- | 5b. The guard against a @2^k@ regression. @foo 2.0.0@ is unusable for a +-- reason that has nothing to do with @unused@ (it needs a package that does not +-- exist), and @foo 1.0.0@ is fine. The dependency is unconditional, so its +-- clause names no flag and the ban conflict resolution learns is on the +-- /version/, for every value of @unused@ at once: @foo@ is expanded twice, the +-- dead version then the good one. +irrelevantFlagRetried :: TestTree +irrelevantFlagRetried = + testCase "an irrelevant flag does not multiply a version-level retry" $ do + let unused = flg "unused" + world = + [ (pkg "root", plain [pkg "foo"]) + , (pkg "foo", Pkg [(unused, True)] [Release v2 [always [pkg "gone"]], Release v1 [always [pkg "here"]]]) + , (pkg "here", leaf) + ] + (result, asks) <- solveCounting world + result + @?= Right + ( solutionOf + [ (pkg "root", v1, []) + , (pkg "foo", v1, [(unused, True)]) + , (pkg "here", v1, []) + ] + ) + Map.lookup (pkg "foo") asks @?= Just 2 + +-- | 5c. The same with a /second/ irrelevant flag, which is what would turn the +-- cost into an exponent. The count is the same as with one flag, and the same +-- as with none. +irrelevantFlagsDoNotCompound :: TestTree +irrelevantFlagsDoNotCompound = + testCase "two irrelevant flags cost no more than none" $ do + let u1 = flg "u1" + u2 = flg "u2" + world = + [ (pkg "root", plain [pkg "foo"]) + , (pkg "foo", Pkg [(u1, True), (u2, True)] [Release v2 [always [pkg "gone"]], Release v1 [always [pkg "here"]]]) + , (pkg "here", leaf) + ] + (result, asks) <- solveCounting world + result + @?= Right + ( solutionOf + [ (pkg "root", v1, []) + , (pkg "foo", v1, [(u1, True), (u2, True)]) + , (pkg "here", v1, []) + ] + ) + Map.lookup (pkg "foo") asks @?= Just 2 + +-- | 6. A flag is decided under its release, so a conflict on the default value +-- flips the flag rather than retreating to an older release that would need no +-- flip: the newest release is kept, with @-fast@. +newestKeptFlagFlipped :: TestTree +newestKeptFlagFlipped = + testCase "the newest release is kept and its flag flipped, rather than downgrading" $ do + let fast = flg "fast" + world = + [ (pkg "root", plain [pkg "foo"]) + , (pkg "foo", Pkg [(fast, True)] [Release v2 [whenOn fast [pkg "speedy"], whenOff fast [pkg "slow"]], Release v1 [always [pkg "slow"]]]) + , (pkg "slow", leaf) + ] + result <- solveWorld world + result + @?= Right + ( solutionOf + [ (pkg "root", v1, []) + , (pkg "foo", v2, [(fast, False)]) + , (pkg "slow", v1, []) + ] + ) + +-- | 7. Not about flags, but about the same provider rule and needing the same +-- harness: committing to an installed unit of a __non-reinstallable__ package also +-- states, once, that the package cannot be built from source. +-- +-- The fixture is called @base@ because the rule keys on +-- 'PubGrub.Cabal.Installed.nonReinstallablePackages', a fixed list of the compiler's own +-- packages; @ordinary@ is the control. +bootPackageStatesItself :: TestTree +bootPackageStatesItself = + testGroup + "non-reinstallable packages" + [ testCase "deciding one also states that it cannot be built from source" $ do + incs <- runTestM (expandInstalled "base") + case [p | Fact (CauseOnlyInstalled p _) <- map incompCause incs] of + [p] -> p @?= mkPackageName "base" + ps -> assertFailure ("expected one such fact, got " ++ show (length ps)) + , testCase "an ordinary installed package states no such thing" $ do + incs <- runTestM (expandInstalled "ordinary") + [() | Fact (CauseOnlyInstalled _ _) <- map incompCause incs] @?= [] + , -- The case with no decision to hang the fact on: the offered range holds + -- no installed unit, so the rule has nothing to return, and it says why. + testCase "a source-only range of one still says why" $ do + (chosen, incs) <- runTestM (expandIn "base" sourceOnly) + chosen @?= Nothing + [p | Fact (CauseOnlyInstalled p _) <- map incompCause incs] @?= [mkPackageName "base"] + , testCase "an ordinary package in the same position says nothing" $ do + (chosen, incs) <- runTestM (expandIn "ordinary" sourceOnly) + chosen @?= Nothing + assertBool "expected no facts" (null incs) + ] + where + expandInstalled name = do + result <- expandIn name (everything name) + case result of + (Just (PackageValue (UsePreInstalled _)), incs) -> pure incs + _ -> liftIO (assertFailure "expected the installed unit to be chosen") + + -- The real provider rule over a world with one installed unit of @name@ and no + -- releases at all, asked about that package with @offered@ on the table. + expandIn name offered = + BP.mkExpand mempty BP.noPreference db source (PackageVar (mkPackageName name)) (instanceSet offered) + where + db = + mkInstalledDb + [ InstalledPkg + { ipUnitId = mkUnitId name + , ipName = mkPackageName name + , ipVersion = mkVersion [1, 0] + , ipDepends = [] + } + ] + source = + BP.ReleaseSource + (const Set.empty) + (\_ _ -> error "this world has no releases to read") + + -- Any source release, and no installed unit: the shape a range takes once a + -- constraint has excluded the compiler's own copy. + sourceOnly = sourceInstances VersionSet.fullVersionSet + + -- What the solver offers before it knows anything: the installed unit, or any + -- source release. + everything name = + InstanceSet + { isInstalled = + Set.singleton + PreInstalledPackage + { pipUnitId = mkUnitId name + , pipVersion = V.mkVersion [1, 0] + , pipDependencies = [] + } + , isSource = VersionSet.fullVersionSet + } + +-- | 8. Also not about flags: a release whose library cannot be built in this +-- environment is __stated__ rather than silently passed over +-- (@references\/pubgrub.md:477@). +-- +-- The world is unsatisfiable either way: @foo 2.0.0@ cannot be built and @foo +-- 1.0.0@ needs a package that has no versions. The verdicts agree; only the proof +-- changes. +unbuildableStatesItself :: TestTree +unbuildableStatesItself = + testGroup + "unbuildable releases" + [ testCase "the proof says a release cannot be built, not that it is absent" $ do + result <- solveWorldWith [(pkg "foo", v2)] world + case result of + Right sol -> assertFailure ("expected no solution, got " ++ show (Map.keys sol)) + Left proof -> do + assertBool + ("the proof should say foo is marked buildable: False:\n" <> T.unpack proof) + (T.pack "is marked buildable: False" `T.isInfixOf` proof) + assertBool + ("and should not report foo >=2.0.0 as empty:\n" <> T.unpack proof) + (not (T.pack "no version for foo in >=2" `T.isInfixOf` proof)) + , testCase "the same world solves when that release can be built" $ do + result <- solveWorld world + result @?= Right (solutionOf [(pkg "root", v1, []), (pkg "foo", v2, [])]) + , -- The offered range holds *nothing but* unbuildable releases, so the scan + -- exhausts and there is no decision for the facts to ride out with. They + -- are reported anyway ('expand' answers @(Nothing, facts)@). + testCase "a range of only unbuildable releases still says why" $ do + let onlyBad = [(pkg "foo", v2), (pkg "foo", v1)] + result <- solveWorldWith onlyBad world + case result of + Right sol -> assertFailure ("expected no solution, got " ++ show (Map.keys sol)) + Left proof -> do + assertBool + ("the proof should still say foo is marked buildable: False:\n" <> T.unpack proof) + (T.pack "is marked buildable: False" `T.isInfixOf` proof) + assertBool + ("and must not call the unbuildable range empty:\n" <> T.unpack proof) + (not (T.pack "no version for foo in >=1" `T.isInfixOf` proof)) + , -- The fact itself, at the point it is minted: the scan passes 2.0.0, + -- settles on 1.0.0, and hands both out together. + testCase "the fact rides out with the release the scan settles on" $ do + let provider = worldProviderUnder FlagPackages [((pkg "foo", v2), Lit True)] world + result <- runTestM (expand provider (PackageVar (pkg "foo")) (instanceSet (sourceInstances VersionSet.fullVersionSet))) + case result of + (Just (PackageValue (BuildSource v)), incs) -> do + v @?= v1 + [p | Fact (CauseUnbuildable p _ _ _) <- map incompCause incs] @?= [pkg "foo"] + _ -> assertFailure "expected 1.0.0 to be chosen" + ] + where + world = + [ (pkg "root", plain [pkg "foo"]) + , (pkg "foo", Pkg [] [Release v2 [], Release v1 [always [pkg "gone"]]]) + ] + +-- | 9. Also not about flags: a release that declares a dependency on __itself__. +-- Where the range admits the release it is an intra-package edge, resolved inside +-- the package, and produces no fact about its own package. Where the range +-- excludes the release no plan can honour it, and the release is ruled out. Both +-- are cabal's verdicts (@Distribution.Solver.Modular.Builder.extendOpen@ and +-- @Distribution.Solver.Modular.Validate.merge@). +selfDependency :: TestTree +selfDependency = + testGroup + "self-dependencies" + [ testCase "a range admitting the release states nothing about itself" $ do + incs <- runTestM expandSelfDep + [q | Fact (CauseDependency _ _ _ (q, _)) <- map incompCause incs, q == pkg "p"] @?= [] + , testCase "its other dependencies are still stated" $ do + incs <- runTestM expandSelfDep + [q | Fact (CauseDependency _ _ _ (q, _)) <- map incompCause incs] @?= [pkg "q"] + , testCase "and the world still solves" $ do + result <- solveWorld admittingWorld + result @?= Right (solutionOf [(pkg "root", v1, []), (pkg "p", v1, []), (pkg "q", v1, [])]) + , testCase "a release its own range excludes is passed over for the next" $ do + result <- solveWorld + [ (pkg "root", plain [pkg "p"]) + , (pkg "p", Pkg [] [Release v1 [], Release v2 [(Lit True, [depAt (pkg "p") v1])]]) + ] + result @?= Right (solutionOf [(pkg "root", v1, []), (pkg "p", v1, [])]) + , testCase "with no other release, the proof names the dependency" $ do + result <- solveWorld + [ (pkg "root", plain [pkg "p"]) + , (pkg "p", Pkg [] [Release v1 [(Lit True, [depAt (pkg "p") v2])]]) + ] + case result of + Right sol -> assertFailure ("expected no solution, got " ++ show (Map.keys sol)) + Left proof -> + assertBool + ("the proof should say p depends on p ==2.0.0:\n" <> T.unpack proof) + (T.pack "depends on p ==2.0.0" `T.isInfixOf` proof) + , testCase "excluded only under a flag, the flag is flipped" $ do + result <- solveWorld + [ (pkg "root", plain [pkg "p"]) + , (pkg "p", Pkg [(tests', True)] [Release v1 [(Var tests', [depAt (pkg "p") v2])]]) + ] + result @?= Right (solutionOf [(pkg "root", v1, []), (pkg "p", v1, [(tests', False)])]) + ] + where + tests' = flg "tests" + + admittingWorld = + [ (pkg "root", plain [pkg "p"]) + , (pkg "p", Pkg [] [Release v1 [(Lit True, [depAt (pkg "p") v1, dep (pkg "q")])]]) + , (pkg "q", leaf) + ] + + depAt p v = mkDependency p (thisVersion (V.toCabalVersion v)) mainLibSet + + expandSelfDep = do + let provider = worldProviderUnder FlagPackages [] admittingWorld + result <- expand provider (PackageVar (pkg "p")) (instanceSet (sourceInstances VersionSet.fullVersionSet)) + case result of + (Just (PackageValue (BuildSource _)), incs) -> pure incs + _ -> liftIO (assertFailure "expected p 1.0.0 to be chosen") + +-- | A release unbuildable only under some flag value: zlib's shape, a +-- @pkgconfig-depends@ behind a flag that defaults on, on a machine without the +-- module. The release is still offered — the verdict is about the flag value, +-- not the release — and the guarded clause makes the solver flip the flag, the +-- way a missing dependency under a flag does ('flagFlip'). Held at the value +-- that cannot be built, the proof names the flag and the reason. +unbuildableUnderFlag :: TestTree +unbuildableUnderFlag = + testGroup + "a release unbuildable under a flag" + [ testCase "the flag is flipped rather than the release dropped" $ do + result <- runSolve (worldProviderUnder FlagPackages unbuildableWhenSys world) + result + @?= Right + ( solutionOf + [ (pkg "root", v1, []) + , (pkg "foo", v1, [(sys, False)]) + , (pkg "bundled", v1, []) + ] + ) + , testCase "held at that value, the proof names the flag and the reason" $ do + result <- runSolveWith [flagConstraint (pkg "foo") (Flag sys True) True] (worldProviderUnder FlagPackages unbuildableWhenSys world) + case result of + Right sol -> assertFailure ("expected no solution, got " ++ show (Map.keys sol)) + Left proof -> + -- Over the release's slot, which here is every version of foo. + assertBool + ("the proof should say foo with +sys is marked buildable: False:\n" <> T.unpack proof) + (T.pack "foo with +sys is marked buildable: False" `T.isInfixOf` proof) + , testCase "the same world solves at the default when the release can be built" $ do + result <- solveWorld world + result @?= Right (solutionOf [(pkg "root", v1, []), (pkg "foo", v1, [(sys, True)])]) + ] + where + sys = flg "sys" + unbuildableWhenSys = [((pkg "foo", v1), Var sys)] + world = + [ (pkg "root", plain [pkg "foo"]) + , (pkg "foo", Pkg [(sys, True)] [Release v1 [whenOff sys [pkg "bundled"]]]) + , (pkg "bundled", leaf) + ] + +-- | 2c. A flag held at a value by a constraint seed ('flagConstraint'), the +-- shape a lock entry's automatic flags take, and the one a flag constraint such +-- as @--constraint 'foo +fast'@ would take. Held at its default, @fast@ cannot +-- flip to escape the missing @speedy@, so the world of 'flagFlip' has no solution +-- and the proof says why; held at the other value, the solver never tries the +-- default at all. +heldFlag :: TestTree +heldFlag = + testGroup + "a flag held by a constraint" + [ testCase "held at the default, the flip that would have rescued the world is forbidden" $ do + result <- runSolveWith [flagConstraint (pkg "foo") (Flag fast True) True] (worldProvider world) + assertBool "expected no solution" (isLeft result) + let proof = fromLeft T.empty result + assertBool ("proof names the constraint:\n" <> T.unpack proof) (T.pack "foo is constrained to +fast" `T.isInfixOf` proof) + , testCase "held at the other value, the default is never tried" $ do + result <- runSolveWith [flagConstraint (pkg "foo") (Flag fast False) False] (worldProvider world) + result + @?= Right + ( solutionOf + [ (pkg "root", v1, []) + , (pkg "foo", v1, [(fast, False)]) + , (pkg "slow", v1, []) + ] + ) + ] + where + fast = flg "fast" + world = + [ (pkg "root", plain [pkg "foo"]) + , (pkg "foo", Pkg [(fast, True)] [Release v1 [whenOn fast [pkg "speedy"], whenOff fast [pkg "slow"]]]) + , (pkg "slow", leaf) + ] + +-- | 'BP.Preference': the main plan's choices, tried first when the offered set +-- admits them. A choice of value and never an incompatibility, so a preferred +-- release that cannot be built here, or that the index lacks, falls through to +-- the rule — installed first, then newest — with nothing lost. +preferenceTests :: TestTree +preferenceTests = + testGroup + "a preference is tried first" + [ testCase "a preferred older release beats the newest" $ do + result <- runSolve (preferring [(pkg "foo", (v1, Map.empty))] world) + fmap (fmap versionOf . Map.lookup (pkg "foo")) result @?= Right (Just (Just v1)) + , testCase "a preferred release the index lacks changes nothing" $ do + result <- runSolve (preferring [(pkg "foo", (V.mkVersion [9], Map.empty))] world) + fmap (fmap versionOf . Map.lookup (pkg "foo")) result @?= Right (Just (Just v2)) + , testCase "a preferred release that cannot be built here falls through, and says why" $ do + result <- runSolveWith [] (worldProviderUnderPreferring (preferring' [(pkg "foo", (v1, Map.empty))]) [((pkg "foo", v1), Lit True)] world) + fmap (fmap versionOf . Map.lookup (pkg "foo")) result @?= Right (Just (Just v2)) + , testCase "a preferred flag value beats the declared default" $ do + result <- runSolve (preferring [(pkg "flagged", (v1, Map.fromList [(fast, False)]))] flagWorld) + result + @?= Right + ( solutionOf + [ (pkg "root", v1, []) + , (pkg "flagged", v1, [(fast, False)]) + , (pkg "slow", v1, []) + ] + ) + ] + where + fast = flg "fast" + -- foo has two releases and nothing forces either. + world = + [ (pkg "root", plain [pkg "foo"]) + , (pkg "foo", Pkg [] [Release v1 [], Release v2 []]) + ] + -- Either value of the flag resolves; the default is True. + flagWorld = + [ (pkg "root", plain [pkg "flagged"]) + , (pkg "flagged", Pkg [(fast, True)] [Release v1 [whenOn fast [pkg "speedy"], whenOff fast [pkg "slow"]]]) + , (pkg "speedy", leaf) + , (pkg "slow", leaf) + ] + preferring' prefs p = lookup p prefs + versionOf (Built v _) = Just v + versionOf Installed{} = Nothing + preferring prefs = worldProviderUnderPreferring (preferring' prefs) [] diff --git a/test/InstalledSpec.hs b/test/InstalledSpec.hs new file mode 100644 --- /dev/null +++ b/test/InstalledSpec.hs @@ -0,0 +1,128 @@ +-- | Tests for 'PubGrub.Cabal.Installed.closureEdges': the walk over the compiler's +-- unit graph that turns "we chose this installed unit" into every dependency +-- edge of its transitive closure. +-- +-- Choosing an installed unit fixes that whole closure — it is a compiled +-- artifact linked against exactly those units — so the provider emits all the +-- edges at once and lets unit propagation chain through them in one fixpoint. +-- What these tests pin down is that the walk is /edges/, not a star from the +-- root: each edge must name the unit that actually declares it, because that is +-- what keeps every emitted incompatibility a genuine direct dependency (and so +-- keeps @CauseDependency@ truthful in reports). +-- +-- The dbs here are hand-built, so nothing needs a compiler or an index. +module InstalledSpec (tests) where + +import qualified Data.Map.Strict as Map +import Distribution.Types.PackageName (PackageName, mkPackageName) +import Distribution.Types.UnitId (UnitId, mkUnitId) +import Distribution.Version (mkVersion) +import PubGrub.Cabal.Installed (InstalledDb (..), + InstalledEdge (..), + InstalledPkg (..), + closureEdges, mkInstalledDb) +import PubGrub.Cabal.PreInstalled (PreInstalledPackage (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +-- | A unit whose id and package name are both the given string, at 1.0. +unit :: String -> [String] -> InstalledPkg +unit n deps = + InstalledPkg + { ipUnitId = mkUnitId n + , ipName = mkPackageName n + , ipVersion = mkVersion [1, 0] + , ipDepends = map mkUnitId deps + } + +-- | Edges as @(depender, dependee)@ unit-id pairs, which is all these tests +-- need to look at. +edgesOf :: [InstalledPkg] -> String -> [(UnitId, UnitId)] +edgesOf pkgs root = + [ (pipUnitId from, pipUnitId to) + | InstalledEdge (_, from) (_, to) <- closureEdges (mkInstalledDb pkgs) (mkUnitId root) + ] + +edge :: String -> String -> (UnitId, UnitId) +edge a b = (mkUnitId a, mkUnitId b) + +-- | The package names an edge relates — the solver variables it is keyed by. +namesOf :: [InstalledPkg] -> String -> [(PackageName, PackageName)] +namesOf pkgs root = + [ (from, to) + | InstalledEdge (from, _) (to, _) <- closureEdges (mkInstalledDb pkgs) (mkUnitId root) + ] + +tests :: TestTree +tests = + testGroup + "PubGrub.Cabal.Installed.closureEdges" + [ testCase "a chain reaches the far end, each edge naming its own depender" $ + -- Not a --> c edge: the second edge is b --> c, because b is what + -- declares it. A star from the root would report a dependency that + -- does not exist. + edgesOf [unit "a" ["b"], unit "b" ["c"], unit "c" []] "a" + @?= [edge "a" "b", edge "b" "c"] + , testCase "edges carry package names, not just unit ids" $ + namesOf [unit "a" ["b"], unit "b" []] "a" + @?= [(mkPackageName "a", mkPackageName "b")] + , testCase "a diamond emits both incoming edges but expands the sink once" $ + -- b --> d and c --> d are different facts and both must be emitted; + -- d itself is walked once, so d --> e appears once. The order is + -- depth-first, which is why d --> e lands before c --> d. + edgesOf + [ unit "a" ["b", "c"] + , unit "b" ["d"] + , unit "c" ["d"] + , unit "d" ["e"] + , unit "e" [] + ] + "a" + @?= [ edge "a" "b" + , edge "a" "c" + , edge "b" "d" + , edge "d" "e" + , edge "c" "d" + ] + , testCase "a cycle terminates and yields each edge once" $ + edgesOf [unit "a" ["b"], unit "b" ["a"]] "a" + @?= [edge "a" "b", edge "b" "a"] + , testCase "a self-dependency emits no edge" $ + -- An incompatibility whose two terms name the same package + -- collapses to a single bogus term, so this must never be emitted. + let es = edgesOf [unit "a" ["a", "b"], unit "b" []] "a" + in do + assertBool "no self-edge" (all (uncurry (/=)) es) + es @?= [edge "a" "b"] + , testCase "a dependency on another unit of the same package emits no edge" $ + -- A library linked against its own installed sublibrary: both + -- units are named a, so the edge would say "if a is a, then a is + -- a:sub", which bans the unit just chosen. + let sub = (unit "a:sub" []) {ipName = mkPackageName "a"} + in namesOf [unit "a" ["a:sub", "b"], sub, unit "b" []] "a" + @?= [(mkPackageName "a", mkPackageName "b")] + , testCase "a unit id listed twice keeps its last entry, by id and by name" $ + -- The two indexes must describe the same units: the provider + -- offers instances by name and walks closures by id. + let older = (unit "a" []) {ipVersion = mkVersion [0, 9]} + db = mkInstalledDb [older, unit "a" []] + in do + fmap ipVersion (Map.lookup (mkUnitId "a") (idbById db)) @?= Just (mkVersion [1, 0]) + map ipVersion (Map.findWithDefault [] (mkPackageName "a") (idbByName db)) @?= [mkVersion [1, 0]] + , testCase "a repeated dependency yields one edge" $ + edgesOf [unit "a" ["b", "b"], unit "b" ["c"], unit "c" []] "a" + @?= [edge "a" "b", edge "b" "c"] + , testCase "a dangling unit id contributes no edge" $ + edgesOf [unit "a" ["ghost", "b"], unit "b" []] "a" + @?= [edge "a" "b"] + , testCase "a root absent from the db has no closure" $ + edgesOf [unit "b" []] "a" @?= [] + , testCase "a leaf has no edges" $ + edgesOf [unit "a" []] "a" @?= [] + , testCase "the walk is deterministic" $ + let pkgs = [unit "a" ["c", "b"], unit "b" ["d"], unit "c" ["d"], unit "d" []] + in edgesOf pkgs "a" @?= edgesOf pkgs "a" + , testCase "dependency order is followed, not name order" $ + edgesOf [unit "a" ["c", "b"], unit "b" [], unit "c" []] "a" + @?= [edge "a" "c", edge "a" "b"] + ] diff --git a/test/InstanceSetSpec.hs b/test/InstanceSetSpec.hs new file mode 100644 --- /dev/null +++ b/test/InstanceSetSpec.hs @@ -0,0 +1,201 @@ +-- | Differential tests for the 'InstanceSet' and 'ValueSet' algebras. +-- +-- The strategy is to fix a small finite universe of instances and compare the +-- real implementation against the obvious extensional model — a plain list of +-- the universe's members, filtered by 'memberInstance'. Every operation must +-- commute with that projection: +-- +-- @ +-- model (a `union` b) == model a ∪ model b +-- @ +-- +-- The source half is a range over /all/ of version space, and the universe +-- here is five points of it, so a range such as @<1@ is non-empty while +-- containing no instance of the universe. The emptiness-based predicates are +-- therefore checked in the one direction a finite sample can check: a claim +-- they make is always true of the model. Their exactness over version space +-- is 'VersionSetSpec''s business. +-- +-- The 'Term' properties matter as much as the set ones: 'Term' is what the +-- solver actually manipulates, and a wrong @difference@ shows up there as a +-- bogus 'Contradicted' — which is how a bad set algebra becomes a wrong +-- "no solution". +module InstanceSetSpec (tests) where + +import qualified Data.Set as Set +import Distribution.Types.UnitId (mkUnitId) +import Distribution.Version (earlierVersion, orLaterVersion) +import PubGrub.Cabal.InstanceSet (Instance (..), InstanceSet (..), + emptyInstanceSet, memberInstance, + singletonInstance) +import PubGrub.Cabal.PreInstalled (PreInstalledPackage (..)) +import PubGrub.Cabal.Value (BoolSet (..), Value (..), boolSet, + flagSet, instanceSet, memberValue, + singletonValue) +import PubGrub.Cabal.Version (Version, mkVersion, toCabalVersion) +import PubGrub.Cabal.VersionSet (VersionSet, emptyVersionSet, + fromVersionRange, fullVersionSet, + singletonVersionSet) +import PubGrub.SetOps (SetOps (..), equivalent, + isDisjoint, isSubsetOf) +import PubGrub.Term (Term (..), intersectTerm, + isBottomTerm, isTopTerm, + negateTerm, unionTerm) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (Arbitrary (..), Gen, elements, + oneof, sized, sublistOf, + testProperty, (===)) + +-- -------------------------------------------------------------------------- +-- The universe +-- -------------------------------------------------------------------------- + +versions :: [Version] +versions = [mkVersion [k] | k <- [1 .. 5]] + +installed :: [PreInstalledPackage] +installed = + [ PreInstalledPackage (mkUnitId "u1") (mkVersion [2]) [] + , PreInstalledPackage (mkUnitId "u2") (mkVersion [4]) [] + ] + +universe :: [Instance] +universe = map UsePreInstalled installed ++ map BuildSource versions + +-- | The extension of a set over the universe. +model :: InstanceSet -> Set.Set Instance +model s = Set.fromList [i | i <- universe, memberInstance i s] + +-- -------------------------------------------------------------------------- +-- Generators +-- -------------------------------------------------------------------------- + +genVersionSet :: Gen VersionSet +genVersionSet = sized go + where + go n + | n <= 1 = oneof [atom, pure emptyVersionSet, pure fullVersionSet] + | otherwise = + oneof + [ atom + , union <$> go (n `div` 2) <*> go (n `div` 2) + , intersect <$> go (n `div` 2) <*> go (n `div` 2) + , difference <$> go (n `div` 2) <*> go (n `div` 2) + ] + atom = + oneof + [ singletonVersionSet <$> elements versions + , fromVersionRange . orLaterVersion . toCabalVersion <$> elements versions + , fromVersionRange . earlierVersion . toCabalVersion <$> elements versions + ] + +newtype Sym = Sym InstanceSet + deriving (Show) + +instance Arbitrary Sym where + arbitrary = do + units <- sublistOf installed + vs <- genVersionSet + pure (Sym (InstanceSet (Set.fromList units) vs)) + +newtype SymTerm = SymTerm (Term InstanceSet) + deriving (Show) + +instance Arbitrary SymTerm where + arbitrary = do + Sym s <- arbitrary + SymTerm <$> elements [Positive s, Negative s] + +-- | A term's extension: over the universe extended by the absent state. +data State = Absent | Present Instance + deriving (Eq, Ord, Show) + +termModel :: Term InstanceSet -> Set.Set State +termModel (Positive s) = Set.map Present (model s) +termModel (Negative s) = Set.insert Absent (Set.map Present (Set.fromList universe `Set.difference` model s)) + +-- -------------------------------------------------------------------------- +-- Tests +-- -------------------------------------------------------------------------- + +tests :: TestTree +tests = + testGroup + "InstanceSet" + [ testGroup + "operations commute with the extensional model" + [ testProperty "union" $ \(Sym a) (Sym b) -> + model (a `union` b) === model a `Set.union` model b + , testProperty "intersect" $ \(Sym a) (Sym b) -> + model (a `intersect` b) === model a `Set.intersection` model b + , testProperty "difference" $ \(Sym a) (Sym b) -> + model (a `difference` b) === model a `Set.difference` model b + ] + , testGroup + "a claim is always true of the model" + [ testProperty "isEmpty" $ \(Sym a) -> + not (isEmpty a) || Set.null (model a) + , testProperty "isSubsetOf" $ \(Sym a) (Sym b) -> + not (isSubsetOf a b) || model a `Set.isSubsetOf` model b + , testProperty "isDisjoint" $ \(Sym a) (Sym b) -> + not (isDisjoint a b) || Set.null (model a `Set.intersection` model b) + , -- The direct forms answer exactly what the set-building defaults + -- would: 'isEmpty' is exact on an instance set, and on a term both + -- sides go through the same one-sided test. + testProperty "isSubsetOf is the emptiness of the difference" $ \(Sym a) (Sym b) -> + isSubsetOf a b === isEmpty (a `difference` b) + , testProperty "isDisjoint is the emptiness of the intersection" $ \(Sym a) (Sym b) -> + isDisjoint a b === isEmpty (a `intersect` b) + , testProperty "on terms, likewise" $ \(SymTerm x) (SymTerm y) -> + (isSubsetOf x y, isDisjoint x y) === (isEmpty (x `difference` y), isEmpty (x `intersect` y)) + , testProperty "equivalent" $ \(Sym a) (Sym b) -> + not (equivalent a b) || model a == model b + , testProperty "Eq" $ \(Sym a) (Sym b) -> + a /= b || model a == model b + , -- The direction the sample can settle: a set whose range holds one of + -- the universe's versions, or an installed unit, is never called empty. + testProperty "a set with a member is not empty" $ \(Sym a) -> + Set.null (model a) || not (isEmpty a) + ] + , testGroup + "constructors" + [ testProperty "the empty set contains nothing" $ + model emptyInstanceSet === Set.empty + , testProperty "singletonInstance denotes exactly that instance" $ + \i -> model (singletonInstance (universe !! (abs i `mod` length universe))) + === Set.singleton (universe !! (abs i `mod` length universe)) + ] + , testGroup + "terms" + [ testProperty "intersectTerm" $ \(SymTerm x) (SymTerm y) -> + termModel (intersectTerm x y) === termModel x `Set.intersection` termModel y + , testProperty "unionTerm" $ \(SymTerm x) (SymTerm y) -> + termModel (unionTerm x y) === termModel x `Set.union` termModel y + , testProperty "negateTerm is complement" $ \(SymTerm x) -> + termModel (negateTerm x) === everything `Set.difference` termModel x + , testProperty "isTopTerm only claims a real top" $ \(SymTerm x) -> + not (isTopTerm x) || termModel x == everything + , testProperty "isBottomTerm only claims a real bottom" $ \(SymTerm x) -> + not (isBottomTerm x) || Set.null (termModel x) + , testProperty "subset and disjointness never claim what the model denies" $ \(SymTerm x) (SymTerm y) -> + (not (x `isSubsetOf` y) || termModel x `Set.isSubsetOf` termModel y) + && (not (x `isDisjoint` y) || Set.null (termModel x `Set.intersection` termModel y)) + ] + , testGroup + "flag value sets" + [ testProperty "BoolSet operations commute with the model" $ \a b c -> + let x = BoolSet a b + y = BoolSet c (a /= c) + m (BoolSet f t) = Set.fromList ([False | f] ++ [True | t]) + in (m (x `union` y), m (x `intersect` y), m (x `difference` y)) + === (m x `Set.union` m y, m x `Set.intersection` m y, m x `Set.difference` m y) + , testProperty "a flag value is a member of its own singleton only" $ \b -> + (memberValue (FlagValue b) (singletonValue (FlagValue b)), memberValue (FlagValue (not b)) (singletonValue (FlagValue b))) + === (True, False) + , testProperty "a package value never belongs to a flag set, nor the reverse" $ \b -> + (memberValue (PackageValue (BuildSource (mkVersion [1]))) (flagSet (boolSet b)), memberValue (FlagValue b) (instanceSet emptyInstanceSet)) + === (False, False) + ] + ] + where + everything = Set.insert Absent (Set.map Present (Set.fromList universe)) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,30 @@ +module Main (main) where + +import qualified ConstraintSpec +import qualified FlagSolveSpec +import qualified InstalledSpec +import qualified InstanceSetSpec +import qualified PaperSpec +import qualified ReleaseSpec +import qualified ReportSpec +import qualified SolverSpec +import qualified StoreSpec +import Test.Tasty (defaultMain, testGroup) +import qualified VersionSetSpec + +main :: IO () +main = + defaultMain $ + testGroup + "pubgrub-cabal" + [ VersionSetSpec.tests + , InstanceSetSpec.tests + , SolverSpec.tests + , ConstraintSpec.tests + , StoreSpec.tests + , PaperSpec.tests + , ReportSpec.tests + , FlagSolveSpec.tests + , InstalledSpec.tests + , ReleaseSpec.tests + ] diff --git a/test/PaperSpec.hs b/test/PaperSpec.hs new file mode 100644 --- /dev/null +++ b/test/PaperSpec.hs @@ -0,0 +1,327 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- | The worked examples from the PubGrub paper (references/pubgrub.md, +-- "Examples" section), as end-to-end solver tests. +-- +-- These tests run the __real__ provider: 'PubGrub.Cabal.Provider.mkExpand' takes its +-- world as arguments, so 'mkProvider' feeds it the paper's universe out of memory +-- instead of Hackage, as @test\/FlagSolveSpec.hs@ does. Nothing about the rule — +-- candidate enumeration, version slots, the newest-first preference, range widening, +-- incompatibility emission — is restated here. A copy of the rule would test only +-- the copy, and a golden file would not notice it drifting, because a golden +-- absorbs whatever proof comes out. +-- +-- What the worlds supply is the /data/, the way the paper writes it: each +-- release declares its dependencies as version /ranges/, and the provider widens +-- them into instance sets. So these tests also exercise 'PubGrub.Cabal.VersionSet' +-- and the provider's own range-to-instance widening. +-- +-- The four satisfiable examples assert the exact solution the paper reports; the two +-- error-reporting examples are unsatisfiable and assert the __rendered proof__ against +-- a golden file in @test\/golden@. The spec publishes its own expected wording for +-- both (@references\/pubgrub.md:1005@ and @:1150@), so these two cases are the closest +-- thing there is to a conformance test for 'PubGrub.Report' — see the note above each +-- for the differences that remain and which known gap each belongs to. +module PaperSpec (tests) where + +import Control.Exception (toException) +import qualified Data.ByteString.Lazy as BL +import Data.Functor.Identity (Identity, runIdentity) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Distribution.Types.Condition (Condition (Lit)) +import Distribution.Types.Dependency (mainLibSet, mkDependency) +import Distribution.Types.PackageName (PackageName, mkPackageName) +import Distribution.Version (VersionRange, earlierVersion, + intersectVersionRanges, + mkVersion, orLaterVersion) +import PubGrub.Cabal (Var (..), request) +import PubGrub.Cabal.Installed (mkInstalledDb) +import PubGrub.Cabal.InstanceSet (Instance (BuildSource)) +import PubGrub.Cabal.Provider (ParseError (..)) +import qualified PubGrub.Cabal.Provider as BP +import PubGrub.Cabal.Report (reportConflict) +import PubGrub.Cabal.Value (Value (..)) +import PubGrub.Cabal.Version (Version) +import qualified PubGrub.Cabal.Version as V +import qualified PubGrub.Cabal.VersionSet as VersionSet +import PubGrub.Incompatibility (Incompatibility) +import PubGrub.Provider (Provider (Provider)) +import PubGrub.Solver (SolveError (..), solve) +import Test.Tasty (TestName, TestTree, testGroup) +import Test.Tasty.Golden (goldenVsString) +import Test.Tasty.HUnit (testCase, (@?=)) + +-- -------------------------------------------------------------------------- +-- A range-based package universe +-- -------------------------------------------------------------------------- + +-- | One source release: a version and its dependencies as (name, range) pairs. +data Release = Release + { relVersion :: [Int] + , relDeps :: [(PackageName, VersionRange)] + } + +-- | The whole universe: each package's available releases. +type World = [(PackageName, [Release])] + +-- Range helpers mirroring the paper's (semver) notation. Note this is NOT +-- Cabal's PVP caret: the paper's @^1.0.0@ is @>=1.0.0 && <2.0.0@ (major = the +-- first component), whereas Cabal's 'majorBoundVersion' would stop at @<1.1@. +-- +-- These are 'VersionRange's, not 'PubGrub.Cabal.VersionSet.VersionSet's, because +-- that is what a @.cabal@ dependency carries and therefore what 'BP.mkExpand' is +-- handed. Turning one into a set is the provider's job, and doing it here would +-- be taking over a step of the rule under test. +caret :: [Int] -> VersionRange -- ^1.2.3 = >=1.2.3 && <2.0.0 +caret [] = error "caret: empty version" +caret v@(major : _) = + intersectVersionRanges (orLaterVersion (mkVersion v)) (earlierVersion (mkVersion [major + 1])) + +gte :: [Int] -> VersionRange -- >=1.2.3 +gte v = orLaterVersion (mkVersion v) + +lt :: [Int] -> VersionRange -- <1.2.3 +lt v = earlierVersion (mkVersion v) + +-- | A release as a solver 'Instance': a source build of its version. An +-- 'Instance' only identifies a release, so the dependencies stay in the world +-- and the provider looks them up — exactly as the real bridge reads them from +-- the index. +releaseInstance :: Release -> Instance +releaseInstance r = BuildSource (V.mkVersion (relVersion r)) + +-- | The instance for a specific package version in the world (for asserting +-- expected solutions). Errors only if the test names a version not in @world@. +instanceOf :: World -> PackageName -> [Int] -> Instance +instanceOf world p v = + case [releaseInstance r | (q, rs) <- world, q == p, r <- rs, relVersion r == v] of + (i : _) -> i + [] -> error ("instanceOf: no " ++ show p ++ " " ++ show v) + +-- | The provider for a world: the /real/ 'BP.mkExpand', driven from an in-memory +-- release source built out of the world. +-- +-- Three departures from a Hackage-backed run, none of them touching the rule: +-- +-- * the 'BP.ReleaseSource' answers from the world rather than from an index, and +-- no @.cabal@ is ever parsed. Its two questions are exactly what a paper world +-- can answer: which versions exist, and what one release declares. +-- * the paper\'s top-level dependencies are the solve\'s seeds, one 'request' +-- per dependency (@:252@). So the worlds hold only the packages the paper +-- resolves, and the expected solutions name only those. +-- * the installed db is empty: these worlds have no pre-installed units, so the +-- installed half of every 'PubGrub.Cabal.InstanceSet.InstanceSet' is empty and +-- the prefer-installed and non-reinstallable branches never run. +-- +-- The paper\'s releases have no flags, so every guard is @'Lit' True@ — a real +-- guard, not the absence of one, which 'PubGrub.Cabal.Flatten.expandGuard' resolves +-- to the single empty pin set. That is the shape every guard folds to while flags +-- are fixed at their declared defaults. +mkProvider :: World -> Provider Var Identity +mkProvider world = Provider (BP.mkExpand mempty BP.noPreference (mkInstalledDb []) source) + where + source = + BP.ReleaseSource + { BP.rsVersionsOf = \p -> + Set.fromList [V.mkVersion (relVersion r) | (q, rs) <- world, q == p, r <- rs] + , BP.rsReadRelease = \p v -> pure (readRelease p v) + } + + -- Every release of every package, in the reduced shape the bridge expects: no + -- declared flags, one unconditional dependency group, buildable. + releases :: Map (PackageName, Version) BP.Release + releases = + Map.fromList + [ ( (p, V.mkVersion (relVersion r)) + , BP.Release + { BP.relAutomatic = [] + , BP.relGuarded = + [(Lit True, [mkDependency d vr mainLibSet | (d, vr) <- relDeps r])] + , BP.relUnbuildable = [] + , BP.relTools = [] + , BP.relSetup = [] + } + ) + | (p, rs) <- world + , r <- rs + ] + + -- 'BP.mkExpand' only ever asks about versions @rsVersionsOf@ reported, so the + -- miss branch is unreachable; it answers with a parse failure rather than an + -- 'error' so a future wiring bug degrades into a skipped release instead of a + -- crash. + readRelease p v = + maybe (Left (missing p v)) Right (Map.lookup (p, v) releases) + + missing p v = + ParseException (toException (userError ("not in world: " <> show (p, v)))) + +-- -------------------------------------------------------------------------- +-- The monad the worlds are solved in +-- -------------------------------------------------------------------------- + +-- | Run the solver purely, discarding both log channels: 'solve' emits +-- 'SolverMsg' and 'BP.mkExpand' emits 'Text', and each takes its action as an +-- argument, so 'mempty' silences both. +-- +-- Over 'Identity' rather than 'IO', which the provider rule permits: 'BP.mkExpand' +-- asks only for 'Monad', so these tests stay pure and their assertions stay a +-- plain '@?='. +runSolve + :: Provider Var Identity + -> [Incompatibility Var] + -> Either (SolveError Var) (Map Var Value) +runSolve provider seeds = + runIdentity (solve mempty provider seeds) + +-- | Run the solver against a world, seeded with the paper's top-level dependencies. +-- A failure is kept as its rendered report rather than 'show'n, because the +-- derived 'Show' would expand the whole derivation DAG as a tree. +solveWorld :: [(PackageName, VersionRange)] -> World -> Either Text (Map Var Value) +solveWorld rootDeps world = + either (Left . renderFailure) Right $ + runSolve (mkProvider world) [request p (BP.widenTo (mkInstalledDb []) p (VersionSet.fromVersionRange vr)) | (p, vr) <- rootDeps] + +-- | Render a solver failure as its explanatory proof. +renderFailure :: SolveError Var -> Text +renderFailure (NoSolution i) = reportConflict i +renderFailure (NoSatisfier p _) = + T.pack ("internal error: no satisfier for " <> show p) +renderFailure _ = T.pack "internal error" + +-- | Assert the rendered proof of an unsatisfiable world against a golden file. +-- +-- Golden rather than an expected list in the source, because what is under test is a +-- block of English: in a file of its own it can be read as the proof a user would +-- see, and when the wording changes on purpose +-- @cabal test --test-options=--accept@ rewrites it instead of anyone hand-editing +-- string literals. +-- +-- A world that /solves/ writes its solution into the same file, so a golden diff +-- says what happened rather than \"expected Left\". +proofGolden :: TestName -> FilePath -> [(PackageName, VersionRange)] -> World -> TestTree +proofGolden name file rootDeps world = + goldenVsString name ("test/golden/" <> file) (pure (utf8 (rendered (solveWorld rootDeps world)))) + where + rendered (Left proof) = proof <> T.pack "\n" + rendered (Right sol) = + T.pack ("expected no solution, got " <> show (Map.keys sol) <> "\n") + utf8 = BL.fromStrict . T.encodeUtf8 + +-- | The expected solution as a map, from (name, version) pairs. +expected :: World -> [(String, [Int])] -> Map Var Value +expected world entries = + Map.fromList [(PackageVar (mkPackageName n), PackageValue (instanceOf world (mkPackageName n) v)) | (n, v) <- entries] + +pkg :: String -> PackageName +pkg = mkPackageName + +-- -------------------------------------------------------------------------- +-- The examples +-- -------------------------------------------------------------------------- + +tests :: TestTree +tests = + testGroup + "PubGrub paper examples" + [ testCase "No Conflicts" $ + let world = + [ (pkg "foo", [Release [1, 0, 0] [(pkg "bar", caret [1, 0, 0])]]) + , (pkg "bar", [Release [1, 0, 0] [], Release [2, 0, 0] []]) + ] + in solveWorld [(pkg "foo", caret [1, 0, 0])] world + @?= Right (expected world [("foo", [1, 0, 0]), ("bar", [1, 0, 0])]) + , testCase "Avoiding Conflict During Decision Making" $ + let world = + [ + ( pkg "foo" + , + [ Release [1, 1, 0] [(pkg "bar", caret [2, 0, 0])] + , Release [1, 0, 0] [] + ] + ) + , (pkg "bar", [Release [1, 0, 0] [], Release [1, 1, 0] [], Release [2, 0, 0] []]) + ] + in solveWorld [(pkg "foo", caret [1, 0, 0]), (pkg "bar", caret [1, 0, 0])] world + @?= Right (expected world [("foo", [1, 0, 0]), ("bar", [1, 1, 0])]) + , testCase "Performing Conflict Resolution" $ + let world = + [ + ( pkg "foo" + , + [ Release [2, 0, 0] [(pkg "bar", caret [1, 0, 0])] + , Release [1, 0, 0] [] + ] + ) + , (pkg "bar", [Release [1, 0, 0] [(pkg "foo", caret [1, 0, 0])]]) + ] + in solveWorld [(pkg "foo", gte [1, 0, 0])] world + @?= Right (expected world [("foo", [1, 0, 0])]) + , testCase "Conflict Resolution With a Partial Satisfier" $ + let world = + [ + ( pkg "foo" + , + [ Release [1, 1, 0] [(pkg "left", caret [1, 0, 0]), (pkg "right", caret [1, 0, 0])] + , Release [1, 0, 0] [] + ] + ) + , (pkg "left", [Release [1, 0, 0] [(pkg "shared", gte [1, 0, 0])]]) + , (pkg "right", [Release [1, 0, 0] [(pkg "shared", lt [2, 0, 0])]]) + , + ( pkg "shared" + , + [ Release [2, 0, 0] [] + , Release [1, 0, 0] [(pkg "target", caret [1, 0, 0])] + ] + ) + , (pkg "target", [Release [2, 0, 0] [], Release [1, 0, 0] []]) + ] + in solveWorld [(pkg "foo", caret [1, 0, 0]), (pkg "target", caret [2, 0, 0])] world + @?= Right (expected world [("foo", [1, 0, 0]), ("target", [2, 0, 0])]) + , -- @:1005@. The spec's own two lines are + -- + -- > Because every version of foo depends on bar ^2.0.0 which depends on + -- > baz ^3.0.0, every version of foo requires baz ^3.0.0. + -- > So, because root depends on both baz ^1.0.0 and foo ^1.0.0, version + -- > solving failed. + -- + -- The first line is ours exactly, in Cabal's range syntax. The last + -- differs in one way: where the spec's line has a depender for baz + -- ^1.0.0 and foo ^1.0.0, ours says the two are requested, which is the + -- same fact without the package in front of it. + proofGolden "Linear Error Reporting (unsat)" "linear-error-reporting.txt" + [(pkg "foo", caret [1, 0, 0]), (pkg "baz", caret [1, 0, 0])] + [ (pkg "foo", [Release [1, 0, 0] [(pkg "bar", caret [2, 0, 0])]]) + , (pkg "bar", [Release [2, 0, 0] [(pkg "baz", caret [3, 0, 0])]]) + , (pkg "baz", [Release [1, 0, 0] [], Release [3, 0, 0] []]) + ] + , -- @:1150@. Here the derivation branches, and the shape the spec asks for + -- is reproduced: one line per step, a line number minted only for the + -- conclusion that gets referred to later (1), the back-reference in the + -- line that joins the two branches, and the blank line between them. + -- Ours differs in which facts each branch's first line fuses, and its + -- last line says \"foo >=1.0.0 && <2 is requested\" where the spec's + -- has a depender for it. + proofGolden "Branching Error Reporting (unsat)" "branching-error-reporting.txt" + [(pkg "foo", caret [1, 0, 0])] + [ + ( pkg "foo" + , + [ Release [1, 0, 0] [(pkg "a", caret [1, 0, 0]), (pkg "b", caret [1, 0, 0])] + , Release [1, 1, 0] [(pkg "x", caret [1, 0, 0]), (pkg "y", caret [1, 0, 0])] + ] + ) + , (pkg "a", [Release [1, 0, 0] [(pkg "b", caret [2, 0, 0])]]) + , (pkg "b", [Release [1, 0, 0] [], Release [2, 0, 0] []]) + , (pkg "x", [Release [1, 0, 0] [(pkg "y", caret [2, 0, 0])]]) + , (pkg "y", [Release [1, 0, 0] [], Release [2, 0, 0] []]) + ] + ] diff --git a/test/ReleaseSpec.hs b/test/ReleaseSpec.hs new file mode 100644 --- /dev/null +++ b/test/ReleaseSpec.hs @@ -0,0 +1,180 @@ +-- | From a @.cabal@ file to a plan, through 'PubGrub.Cabal.Provider.releaseOf': +-- the route a tool takes when it holds the descriptions itself and builds a +-- 'ReleaseSource' out of them, as the bridge does from the index. +-- +-- What is under test is the reduction's two switches as the solve sees them. +-- The 'Stanzas' decide whether a release's test suites and benchmarks are +-- dependencies of it: a planner says yes for a local package under @cabal +-- test@ and no for everything else. And a test suite depends on its own +-- package's library — an intra-package edge, @docs\/DESIGN.md@ §8 — so turning +-- the stanzas on must neither pin the package to itself nor fail the solve. +module ReleaseSpec (tests) where + +import Control.Exception (toException) +import qualified Data.ByteString.Char8 as BS +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import Distribution.Compiler (AbiTag (NoAbiTag), + CompilerFlavor (GHC), + CompilerId (..), + CompilerInfo, + unknownCompilerInfo) +import Distribution.PackageDescription.Parsec (parseGenericPackageDescription, + runParseResult) +import Distribution.System (Arch (X86_64), + OS (Linux), + Platform (..)) +import Distribution.Types.Dependency (depPkgName) +import Distribution.Types.Flag (mkFlagAssignment, + mkFlagName) +import Distribution.Types.GenericPackageDescription (GenericPackageDescription) +import Distribution.Types.PackageName (PackageName, + mkPackageName) +import qualified Distribution.Types.Version as Cabal +import PubGrub.Cabal (Var, foldFlags, + request) +import PubGrub.Cabal.Flatten (FlagModel (..), + Stanzas, + allStanzas, + noStanzas) +import PubGrub.Cabal.Installed (mkInstalledDb) +import PubGrub.Cabal.InstanceSet (Instance (..), + singletonInstance) +import qualified PubGrub.Cabal.Provider as BP +import PubGrub.Cabal.Report (reportConflict) +import PubGrub.Cabal.Value (Resolved (..)) +import PubGrub.Cabal.Version (Version) +import qualified PubGrub.Cabal.Version as V +import PubGrub.Provider (Provider (..)) +import PubGrub.Solver (SolveError (..), + solve) +import Test.Tasty (TestTree, + testGroup) +import Test.Tasty.HUnit (assertFailure, + testCase, (@?=)) + +testPlatform :: Platform +testPlatform = Platform X86_64 Linux + +testCompiler :: CompilerInfo +testCompiler = unknownCompilerInfo (CompilerId GHC (Cabal.mkVersion [9, 12, 2])) NoAbiTag + +-- | Parse a fixture. The error is not shown: Cabal-syntax 3.18 tags it with a +-- source type this test never fixes, and the fixtures are ours. +gpdOf :: String -> IO GenericPackageDescription +gpdOf src = case snd (runParseResult (parseGenericPackageDescription (BS.pack src))) of + Right gpd -> pure gpd + Left _ -> assertFailure ("test fixture failed to parse:\n" ++ src) + +-- | A world of one release per package, each reduced from its @.cabal@ under +-- the 'Stanzas' given for it, with no installed units and no pkg-config. +worldFrom :: [(PackageName, Stanzas, GenericPackageDescription)] -> Provider Var IO +worldFrom entries = + Provider (BP.mkExpand mempty BP.noPreference (mkInstalledDb []) source) + where + releases = + Map.fromList + [ (p, BP.releaseOf FlagPackages stanzas testPlatform testCompiler (const False) gpd) + | (p, stanzas, gpd) <- entries + ] + source = + BP.ReleaseSource + { BP.rsVersionsOf = \p -> if Map.member p releases then Set.singleton v1 else Set.empty + , BP.rsReadRelease = \p v -> + pure $ case Map.lookup p releases of + Just r | v == v1 -> Right r + _ -> Left (BP.ParseException (toException (userError ("not in world: " ++ show (p, v))))) + } + +v1 :: Version +v1 = V.mkVersion [1, 0] + +solveFor :: PackageName -> Provider Var IO -> IO (Either Text (Map.Map PackageName Resolved)) +solveFor target provider = + either (Left . render) (Right . foldFlags) + <$> solve mempty provider [request target (singletonInstance (BuildSource v1))] + where + render (NoSolution i) = reportConflict i + render (NoSatisfier p _) = T.pack ("internal error: no satisfier for " <> show p) + render _ = T.pack "internal error" + +-- | A library package whose test suite depends on the package itself, on a +-- package of its own, and under a flag on a third; a benchmark too. +localSrc :: String +localSrc = + unlines + [ "cabal-version: 3.0" + , "name: local" + , "version: 1.0" + , "build-type: Simple" + , "" + , "flag slow" + , " default: False" + , "" + , "library" + , " build-depends: core, lib-dep" + , "" + , "test-suite spec" + , " type: exitcode-stdio-1.0" + , " main-is: Spec.hs" + , " build-depends: core, local, test-dep" + , " if flag(slow)" + , " build-depends: slow-dep" + , "" + , "benchmark bench" + , " type: exitcode-stdio-1.0" + , " main-is: Bench.hs" + , " build-depends: core, bench-dep" + ] + +leafSrc :: String -> String +leafSrc name = + unlines + [ "cabal-version: 3.0" + , "name: " ++ name + , "version: 1.0" + , "build-type: Simple" + , "" + , "library" + , " build-depends: core" + , "" + , "test-suite spec" + , " type: exitcode-stdio-1.0" + , " main-is: Spec.hs" + , " build-depends: core, " ++ name ++ ", nobody-has-this" + ] + +pkg :: String -> PackageName +pkg = mkPackageName + +tests :: TestTree +tests = + testGroup + "releaseOf (a .cabal file to a plan)" + [ testCase "the stanzas decide what a release depends on" $ do + gpd <- gpdOf localSrc + let depsUnder stanzas = + Set.toList (Set.fromList [depPkgName d | (_, ds) <- BP.relGuarded (BP.releaseOf FlagPackages stanzas testPlatform testCompiler (const False) gpd), d <- ds]) + depsUnder noStanzas @?= [pkg "core", pkg "lib-dep"] + depsUnder allStanzas @?= [pkg "bench-dep", pkg "core", pkg "lib-dep", pkg "local", pkg "slow-dep", pkg "test-dep"] + , testCase "a local package's tests are solved, its dependencies' are not, and the self-dependency pins nothing" $ do + local <- gpdOf localSrc + leaves <- mapM (gpdOf . leafSrc) ["core", "lib-dep", "test-dep", "slow-dep", "bench-dep"] + let world = + worldFrom $ + (pkg "local", allStanzas, local) + : [(pkg n, noStanzas, gpd) | (n, gpd) <- zip ["core", "lib-dep", "test-dep", "slow-dep", "bench-dep"] leaves] + result <- solveFor (pkg "local") world + result + @?= Right + ( Map.fromList + [ (pkg "local", Built v1 (mkFlagAssignment [(mkFlagName "slow", False)])) + , (pkg "core", Built v1 (mkFlagAssignment [])) + , (pkg "lib-dep", Built v1 (mkFlagAssignment [])) + , (pkg "test-dep", Built v1 (mkFlagAssignment [])) + , (pkg "bench-dep", Built v1 (mkFlagAssignment [])) + ] + ) + ] diff --git a/test/ReportSpec.hs b/test/ReportSpec.hs new file mode 100644 --- /dev/null +++ b/test/ReportSpec.hs @@ -0,0 +1,597 @@ +-- | Tests for 'PubGrub.Cabal.Report.collapseNoInstances', the post-pass that absorbs +-- \"no version for @p@ in @r@\" leaves into the sibling they were resolved against. +-- +-- The rendered output of the pass is covered end to end by @PaperSpec@'s golden +-- files. What is covered here is the pass itself, on derivation trees built by hand +-- with 'resolveOn' — because the property that makes it sound is not visible in a +-- rendered proof: __it must preserve the node's terms exactly__. It re-labels a +-- derivation step as the leaf it is equivalent to; it must never widen or narrow +-- what the proof claims. +module ReportSpec (tests) where + +import Data.List (isInfixOf) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Text as T +import Distribution.Types.Flag (mkFlagName) +import Distribution.Types.PackageName (PackageName, + mkPackageName) +import Distribution.Types.PkgconfigDependency (PkgconfigDependency (..)) +import Distribution.Types.PkgconfigName (mkPkgconfigName) +import Distribution.Types.PkgconfigVersionRange (anyPkgconfigVersion) +import qualified Distribution.Types.Version as Cabal +import Distribution.Types.VersionRange (earlierVersion, + orLaterVersion) +import PubGrub.Cabal (CabalFact (..), + Flag (..), + UnbuildableReason (..), + Var (..), + fromDependency, + onlyInstalled, + request, unbuildable) +import PubGrub.Cabal.InstanceSet (InstanceSet (..)) +import PubGrub.Cabal.Report (collapseNoInstances, + reportConflict, + reportHeadline, + styleProof, + wrapProof) +import PubGrub.Cabal.Value (instanceSet) +import PubGrub.Cabal.Version (Version) +import qualified PubGrub.Cabal.Version as V +import qualified PubGrub.Cabal.VersionSet as VersionSet +import PubGrub.Incompatibility (Cause (..), + Incompatibility (..), + noValues, priorCause) +import PubGrub.SetOps (equivalent) +import PubGrub.Term (Term (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, + assertFailure, + testCase, (@?=)) + +-- -------------------------------------------------------------------------- +-- Fixtures +-- -------------------------------------------------------------------------- + +pkgA, pkgB, pkgQ, pkgR, pkgS, pkgBase :: PackageName +pkgA = mkPackageName "a" +pkgBase = mkPackageName "base" +pkgB = mkPackageName "b" +pkgQ = mkPackageName "q" +pkgR = mkPackageName "r" +pkgS = mkPackageName "s" + +v :: Int -> Version +v n = V.mkVersion [n] + +-- | The same, as a Cabal version: what a declared range is written with. +cv :: Int -> Cabal.Version +cv n = Cabal.mkVersion [n] + +sourceOnly :: VersionSet.VersionSet -> InstanceSet +sourceOnly vs = InstanceSet{isInstalled = Set.empty, isSource = vs} + +-- | An unconditional dependency fact, the shape every fact here has. +dependency :: PackageName -> InstanceSet -> PackageName -> InstanceSet -> Incompatibility Var +dependency p s q r = fromDependency p s Map.empty q r + +-- | A resolution step on a package. +resolveOn :: Incompatibility Var -> Incompatibility Var -> PackageName -> Incompatibility Var +resolveOn a b p = priorCause a b (PackageVar p) + +-- | @[lo, hi)@, the shape a release slot and a declared range both have. +range :: Int -> Int -> InstanceSet +range lo hi = + sourceOnly + ( VersionSet.intersectionVersionSet + (VersionSet.fromVersionRange (orLaterVersion (cv lo))) + (VersionSet.fromVersionRange (earlierVersion (cv hi))) + ) + +from :: Int -> InstanceSet +from lo = sourceOnly (VersionSet.fromVersionRange (orLaterVersion (cv lo))) + +-- | @a@ over @dependers@ depends on @q@ in @1..5@. +dependsOnQ :: InstanceSet -> Incompatibility Var +dependsOnQ dependers = dependency pkgA dependers pkgQ (range 1 5) + +-- | The hole the solver learns when a range holds no releases. +hole :: PackageName -> InstanceSet -> Incompatibility Var +hole p s = noValues (PackageVar p) (instanceSet s) + +causeOf :: Incompatibility Var -> Cause Var +causeOf = incompCause + +-- | Every cause in the tree, so a test can assert that no hole survives. +causes :: Incompatibility Var -> [Cause Var] +causes inc = incompCause inc : case incompCause inc of + Derived c1 c2 -> causes c1 ++ causes c2 + _ -> [] + +holesIn :: Incompatibility Var -> Int +holesIn inc = length [() | NoValues _ _ <- causes inc] + +tests :: TestTree +tests = + testGroup + "PubGrub.Cabal.Report.collapseNoInstances" + [ testGroup "what is absorbed" absorbed + , testGroup "what is left alone" untouched + , testGroup "the property that makes it sound" soundness + , testGroup "a run of same-pair steps is one sentence" sameePairRun + , testGroup "a run collected by depender alone is one sentence" widenedRun + , testGroup "the boot-package leaf" bootLeaf + , testGroup "the unbuildable leaf" unbuildableLeaf + , testGroup "the headline" headline + , testGroup "wrapping" wrapping + , testGroup "styling" styling + ] + +-- -------------------------------------------------------------------------- +-- What is absorbed +-- -------------------------------------------------------------------------- + +absorbed :: [TestTree] +absorbed = + [ -- The shape @references/pubgrub.md:1005@'s own example produces: a dependency + -- of one release, plus the fact that the rest of the offered range holds + -- nothing. The step establishes only the union, so it stops being a step. + testCase "a hole on the depender side becomes one dependency fact" $ do + let dep = dependsOnQ (range 1 2) + step = resolveOn dep (hole pkgA (range 2 4)) pkgA + holesIn step @?= 1 + let collapsed = collapseNoInstances step + holesIn collapsed @?= 0 + case causeOf collapsed of + Fact (CauseDependency p s _ (q, r)) -> do + (p, q) @?= (pkgA, pkgQ) + -- the depender is the union of the two, which is what the step + -- concluded; the dependee is untouched + assertBool "depender should span 1..4" (s `equivalent` range 1 4) + assertBool "dependee unchanged" (r `equivalent` range 1 5) + c -> assertFailure ("expected a dependency leaf, got " ++ describe c) + , -- Absorbing on the dependee side is a *narrowing* — the empty part of the + -- declared range comes off — which is why the pass must take the step's own + -- terms rather than union anything itself. + testCase "a hole on the dependee side narrows the dependee range" $ do + let dep = dependsOnQ (range 1 2) + step = resolveOn dep (hole pkgQ (range 4 5)) pkgQ + case causeOf (collapseNoInstances step) of + Fact (CauseDependency _ _ _ (q, r)) -> do + q @?= pkgQ + assertBool "dependee should have lost 4..5" (r `equivalent` range 1 4) + c -> assertFailure ("expected a dependency leaf, got " ++ describe c) + , testCase "the pass reaches holes below the root" $ do + let inner = resolveOn (dependsOnQ (range 1 2)) (hole pkgA (range 2 4)) pkgA + outer = resolveOn inner (hole pkgQ (range 4 5)) pkgQ + holesIn outer @?= 2 + holesIn (collapseNoInstances outer) @?= 0 + ] + +-- -------------------------------------------------------------------------- +-- Collapsing a run of steps that all say the same kind of thing +-- -------------------------------------------------------------------------- + +-- | @a@ over @dependers@ depends on @q@ over @dependees@. +aDependsOn :: InstanceSet -> InstanceSet -> Incompatibility Var +aDependsOn dependers dependees = dependency pkgA dependers pkgQ dependees + +-- | A linear chain of steps, each adding one more range of @a@ with a slightly +-- wider requirement on @q@ — the shape a proof takes when it walks a +-- dependency's bound history one adjacent pair at a time. +chainOf :: [(InstanceSet, InstanceSet)] -> Incompatibility Var +chainOf [] = error "chainOf: needs at least one fact" +chainOf ((s0, r0) : rest) = + foldl step (aDependsOn s0 r0) rest + where + step acc (s, r) = resolveOn acc (aDependsOn s r) pkgA + +proofLines :: Incompatibility Var -> [String] +proofLines = map T.unpack . T.lines . reportConflict + +-- | Six adjacent releases of @a@, each depending on @q@ with a bound one wider. +-- Six, because the ordinary every-other-step skip already fits four facts in +-- two lines: from five on, only a run rule keeps the proof at two. +sixSame :: Incompatibility Var +sixSame = chainOf [(range i (i + 1), range 1 (i + 4)) | i <- [1 .. 6]] + +sameePairRun :: [TestTree] +sameePairRun = + [ -- Without a run rule the four facts after the first line take two more. + testCase "six same-pair steps take two lines" $ + proofLines sixSame + @?= [ "Because a >=1 && <2 depends on q >=1 && <5 and a >=2 && <3 depends on q >=1 && <6, a >=1 && <3 requires q >=1 && <6." + , "So, because a >=3 && <7 depends on q >=1 && <10, version solving failed." + ] + , -- The collapsed sentence may only state the union of the facts it stands in + -- for. Each says @a in Si@ requires @q in Ri@, so together they imply that + -- @a in union S@ requires @q in union R@, since every @Ri@ lies within it. + testCase "the collapsed sentence states the union, not one member" $ do + let proof = unlines (proofLines sixSame) + assertBool + ("the widest dependee bound should appear:\n" ++ proof) + ("<10" `isInfixOf` proof) + , -- Rule 3 keys on the (depender, dependee) pair, and rule 4 takes over where + -- the dependee changes. Either way no dependee may be dropped: a sentence + -- that stood for a fact about @r@ and did not mention @r@ would be claiming + -- something the facts do not say. + testCase "a step about a different dependee keeps that dependee named" $ do + let other = dependency pkgA (range 3 4) (mkPackageName "r") (range 1 9) + base = resolveOn (aDependsOn (range 1 2) (range 1 5)) (aDependsOn (range 2 3) (range 1 6)) pkgA + inc = resolveOn base other pkgA + proof = unlines (proofLines inc) + assertBool ("r should still be named:\n" ++ proof) ("r " `isInfixOf` proof) + ] + +-- -------------------------------------------------------------------------- +-- Rule 4: a run collected by depender alone is one sentence +-- -------------------------------------------------------------------------- + +-- | @a@ over @dependers@ depends on @dependee@ over @dependees@ — like +-- 'aDependsOn', but the dependee is the caller's, which is the whole point of +-- rule 4. +aRequires :: InstanceSet -> String -> InstanceSet -> Incompatibility Var +aRequires dependers dependee dependees = + dependency pkgA dependers (mkPackageName dependee) dependees + +-- | A chain of steps that all name @a@ as the depender and nothing else in +-- common: the shape a proof takes when it walks a target's whole version +-- history, one release and one unrelated dependency at a time. +mixedChainOf :: [(InstanceSet, String, InstanceSet)] -> Incompatibility Var +mixedChainOf [] = error "mixedChainOf: needs at least one fact" +mixedChainOf ((s0, q0, r0) : rest) = foldl step (aRequires s0 q0 r0) rest + where + step acc (s, q, r) = resolveOn acc (aRequires s q r) pkgA + +-- | Six adjacent releases of @a@, each depending on a different package. +sixMixed :: Incompatibility Var +sixMixed = mixedChainOf [(range i (i + 1), [d], range 1 (i + 4)) | (i, d) <- zip [1 .. 6] "qrstuv"] + +widenedRun :: [TestTree] +widenedRun = + [ -- Six facts about @a@ and six different dependees. Rule 3 cannot touch + -- this, since no two facts share a dependee, so without rule 4 the + -- proof takes a line for every two facts. + testCase "six steps with six dependees take two lines" $ + proofLines sixMixed + @?= [ "Because a >=1 && <2 depends on q >=1 && <5 and a >=2 && <3 depends on r >=1 && <6, a >=1 && <3 requires q >=1 && <5 or r >=1 && <6." + , "So, because a >=3 && <7 requires s >=1 && <7 or t >=1 && <8 or u >=1 && <9 or v >=1 && <10, version solving failed." + ] + , -- The collapsed sentence stands in for every fact in the run, so every + -- dependee it collected has to appear in it. Dropping one would be claiming + -- that a range of @a@ requires less than it does. + testCase "every dependee of the run is named" $ do + let proof = unlines (proofLines sixMixed) + mapM_ + (\d -> assertBool (d ++ " should be named:\n" ++ proof) (d `isInfixOf` proof)) + ["q ", "r ", "s ", "t ", "u ", "v "] + , -- The depender's range is the union of the run's, and it may be neither + -- wider nor narrower: wider claims facts the run does not have, narrower + -- drops one it does. The chain is closed with a request for that union, + -- as the solver closes a terminal derivation, so the union is a line's + -- conclusion rather than the proof's last word. + testCase "the depender is the union of the run's ranges" $ do + let chain = + mixedChainOf + [ (range 1 2, "q", range 1 5) + , (range 2 3, "r", range 1 6) + , (range 3 4, "s", range 1 7) + ] + inc = resolveOn chain (request pkgA (range 1 4)) pkgA + proof = unlines (proofLines inc) + assertBool + ("a should span 1..4 in one sentence:\n" ++ proof) + (">=1 && <4" `isInfixOf` proof) + , -- Two facts already fit one line with both of them named, and naming both + -- says strictly more than naming their union. The union has to buy a line + -- to be worth taking, so a two-fact run is left to the ordinary skip. + testCase "two facts are named, not merged" $ do + let inc = mixedChainOf [(range 1 2, "q", range 1 5), (range 2 3, "r", range 1 6)] + proof = unlines (proofLines inc) + assertBool + ("both declared bounds should survive:\n" ++ proof) + ("<5" `isInfixOf` proof && "<6" `isInfixOf` proof) + , -- The union argument is about one depender. Where a package is a depender + -- in one fact and a dependee in another the run has two subjects, no union + -- fact stands for it, and the steps must stay separate. + testCase "a second depender stops the run" $ do + let inc = + resolveOn + (mixedChainOf [(range 1 2, "q", range 1 5), (range 2 3, "r", range 1 6)]) + (dependency pkgQ (range 1 5) pkgA (range 3 4)) + pkgA + proof = unlines (proofLines inc) + assertBool ("q should be named as a depender:\n" ++ proof) ("q " `isInfixOf` proof) + ] + +-- -------------------------------------------------------------------------- +-- What is left alone +-- -------------------------------------------------------------------------- + +-- | The boot-package leaf. The bound that failed is only legible against the +-- installed version, and nothing else in a proof states it. +bootLeaf :: [TestTree] +bootLeaf = + [ testCase "a boot package's fact names the installed version" $ do + let proof = unlines (proofLines (onlyInstalled pkgA [v 3] (from 1))) + assertBool proof ("a is pinned to 3 (installed)" `isInfixOf` proof) + , testCase "two installed versions are both named" $ do + let proof = unlines (proofLines (onlyInstalled pkgA [v 3, v 2] (from 1))) + assertBool proof ("a is pinned to 3 or 2 (installed)" `isInfixOf` proof) + , testCase "a boot package with no installed unit says so" $ do + let proof = unlines (proofLines (onlyInstalled pkgA [] (from 1))) + assertBool proof ("a is not installed and cannot be built from source" `isInfixOf` proof) + ] + +-- | The unbuildable leaf. It names what rules the release out — the module +-- @pkg-config@ could not find, spelled as Cabal-syntax spells the field — rather +-- than saying only that it cannot be built. A lone leaf is rendered as the whole +-- proof here, range and all. +unbuildableLeaf :: [TestTree] +unbuildableLeaf = + [ testCase "a missing pkg-config module is named" $ do + let proof = unlines (proofLines (unbuildable pkgA (from 1) Map.empty (NE.singleton (missing "libpq")))) + assertBool proof ("a >=1 needs pkg-config package libpq, which is not found" `isInfixOf` proof) + , testCase "several missing modules share one needs, in order" $ do + let proof = unlines (proofLines (unbuildable pkgA (from 1) Map.empty (NE.fromList [missing "libpq", missing "zlib"]))) + assertBool proof ("a >=1 needs pkg-config packages libpq and zlib, which are not found" `isInfixOf` proof) + , testCase "buildable: False says so" $ do + let proof = unlines (proofLines (unbuildable pkgA (from 1) Map.empty (NE.singleton NotBuildable))) + assertBool proof ("a >=1 is marked buildable: False" `isInfixOf` proof) + , testCase "both kinds of reason are joined with and" $ do + let proof = unlines (proofLines (unbuildable pkgA (from 1) Map.empty (NE.fromList [NotBuildable, missing "libpq"]))) + assertBool proof ("a >=1 is marked buildable: False and needs pkg-config package libpq, which is not found" `isInfixOf` proof) + , -- A verdict under a flag names the flag value it holds under, as a + -- guarded dependency does. + testCase "a verdict under a flag names the flag" $ do + let proof = unlines (proofLines (unbuildable pkgA (from 1) (Map.singleton (Flag (mkFlagName "pkg-config") True) True) (NE.singleton (missing "zlib")))) + assertBool proof ("a >=1 with +pkg-config needs pkg-config package zlib, which is not found" `isInfixOf` proof) + ] + +-- | A @pkgconfig-depends@ on the module at any version. +missing :: String -> UnbuildableReason +missing name = MissingPkgConfig (PkgconfigDependency (mkPkgconfigName name) anyPkgconfigVersion) + +-- | The line above the proof: the request as the proof names it, and the +-- world-fact leaves verbatim. A terminal derivation ends by resolving against +-- the seeds it rests on, as 'PubGrub.Solver' closes it, so the seeds are its +-- last external facts. +headline :: [TestTree] +headline = + [ -- The second line names the package the search gave up on: the pivot of + -- a step that dropped it after a step below had narrowed it. Here @q@ is + -- refuted a piece at a time — @[1,3)@ through @r@, @>=3@ through @s@ — + -- and the only thing left standing at the dropping step is the depender. + testCase "names the package refuted a piece at a time, and who depends on it" $ do + let aNeedsQ = dependency pkgA (range 1 2) pkgQ (from 1) + lowQ = resolveOn (dependency pkgQ (range 1 3) pkgR (range 1 2)) (hole pkgR (range 1 2)) pkgR + highQ = resolveOn (dependency pkgQ (from 3) pkgS (range 1 2)) (hole pkgS (range 1 2)) pkgS + narrowed = resolveOn aNeedsQ lowQ pkgQ + dropped' = resolveOn narrowed highQ pkgQ + inc = resolveOn dropped' (request pkgA (range 1 2)) pkgA + T.unpack (reportHeadline inc) + @?= "No solution for a >=1 && <2.\nNo version of q suits a >=1 && <2." + , -- With something present that is not a depender, the step's terms are + -- what @q@ cannot be reconciled with, and the depender is named after. + testCase "names what the package cannot be reconciled with" $ do + let aNeedsQ = dependency pkgA (range 1 2) pkgQ (from 1) + lowQ = resolveOn (dependency pkgQ (range 1 3) pkgR (range 1 2)) (hole pkgR (range 1 2)) pkgR + highQ = resolveOn (dependency pkgQ (from 3) pkgS (range 1 2)) (dependency pkgB (range 1 2) pkgS (from 2)) pkgS + narrowed = resolveOn aNeedsQ lowQ pkgQ + dropped' = resolveOn narrowed highQ pkgQ + inc = resolveOn (resolveOn dropped' (request pkgA (range 1 2)) pkgA) (request pkgB (range 1 2)) pkgB + T.unpack (reportHeadline inc) + @?= "No solution for a >=1 && <2 and b >=1 && <2.\na >=1 && <2 needs q, and no version of q is compatible with a >=1 && <2 and b >=1 && <2 together." + , -- Where the proof rests on a pinned package, the line joins who wants + -- @q@, the window they leave for it, and the wall it fails against: the + -- step "q >=1 && <5 is forbidden" with the pinned base among its premises. + testCase "against a wall, names the window and the wall" $ do + let aNeedsQ = dependency pkgA (range 1 2) pkgQ (range 1 5) + qNeedsOldBase = dependency pkgQ (range 1 5) pkgBase (range 0 4) + qForbidden = resolveOn qNeedsOldBase (onlyInstalled pkgBase [v 5] (from 0)) pkgBase + inc = resolveOn (resolveOn aNeedsQ qForbidden pkgQ) (request pkgA (range 1 2)) pkgA + T.unpack (reportHeadline inc) + @?= "No solution for a >=1 && <2: base is pinned to 5 (installed).\na >=1 && <2 needs q >=1 && <5, and no q there builds on base 5 (installed)." + , -- A package refuted in one step was not given up on piece by piece, so + -- nothing is added: the proof's two lines already say it all. + testCase "a package refuted in one step earns no second line" $ do + let inc = + resolveOn + (resolveOn (dependency pkgA (range 1 2) pkgQ (range 1 5)) (hole pkgQ (range 1 5)) pkgQ) + (request pkgA (range 1 2)) + pkgA + T.unpack (reportHeadline inc) @?= "No solution for a >=1 && <2." + , testCase "names the request and the wall" $ do + let inc = resolveOn (onlyInstalled pkgA [v 3] (from 1)) (request pkgA (range 1 2)) pkgA + T.unpack (reportHeadline inc) @?= "No solution for a >=1 && <2: a is pinned to 3 (installed)." + , -- The reason is part of the fact, so it is part of the wall. + testCase "an unbuildable wall carries its reason" $ do + let inc = resolveOn (unbuildable pkgA (from 1) Map.empty (NE.singleton (missing "libpq"))) (request pkgA (range 1 2)) pkgA + T.unpack (reportHeadline inc) + @?= "No solution for a >=1 && <2: a >=1 needs pkg-config package libpq, which is not found." + , testCase "a pure version conflict has no wall" $ do + let inc = resolveOn (hole pkgA (range 1 2)) (request pkgA (range 1 2)) pkgA + T.unpack (reportHeadline inc) @?= "No solution for a >=1 && <2." + , -- Only the seeds the proof reaches are the request; a target the derivation + -- never used did not fail. + testCase "names every seed in the proof, once" $ do + let inc = + resolveOn + (resolveOn (aDependsOn (range 1 2) (range 5 9)) (request pkgA (range 1 2)) pkgA) + (request pkgQ (range 1 5)) + pkgQ + T.unpack (reportHeadline inc) @?= "No solution for a >=1 && <2 and q >=1 && <5." + , -- Two branches of the derivation rest on the same request, and the + -- request is still one target. + testCase "a seed the proof reaches twice is named once" $ do + let via deps = resolveOn (aDependsOn (range 1 2) deps) (request pkgA (range 1 2)) pkgA + inc = resolveOn (via (range 5 9)) (via (range 1 3)) pkgQ + T.unpack (reportHeadline inc) @?= "No solution for a >=1 && <2." + , -- The closing line of such a proof: the seeds, and failure by name. + testCase "the last line names the seeds and concludes failure" $ do + let inc = + resolveOn + (resolveOn (aDependsOn (range 1 2) (range 5 9)) (request pkgA (range 1 2)) pkgA) + (request pkgQ (range 1 5)) + pkgQ + T.unpack (reportConflict inc) + @?= "Because a >=1 && <2 depends on q >=5 && <9 and a >=1 && <2 is requested, q >=5 && <9 is required.\nSo, because q >=1 && <5 is requested, version solving failed." + ] + +-- | 'wrapProof': a hanging indent, and never a break inside a range. +wrapping :: [TestTree] +wrapping = + [ testCase "a short line is left alone" $ + wrapped 80 short @?= [short] + , testCase "a blank line stays blank" $ + T.unpack (wrapProof 80 (T.pack "a\n\nb")) @?= "a\n\nb" + , testCase "continuation lines carry the indent and fit the width" $ do + let ls = wrapped 60 long + assertBool (show ls) (length ls > 1) + mapM_ (\l -> assertBool ("too long: " ++ l) (length l <= 60)) ls + mapM_ (\l -> assertBool ("no indent: " ++ l) (take 4 l == " ")) (drop 1 ls) + , testCase "a range is never split" $ do + let ls = wrapped 60 long + mapM_ + (\l -> assertBool ("starts inside a range: " ++ l) + (not (any (`isPrefixOf'` dropWhile (== ' ') l) [">=", "<", "&&", "(installed)"]))) + ls + , testCase "the words survive, in order" $ + words (unwords (wrapped 60 long)) @?= words long + , testCase "a preposition is not left at the end of a line" $ + mapM_ + (\l -> assertBool ("dangling: " ++ l) (not (any (`isSuffixOf'` l) [" on", " of", " to", " with", " depends"]))) + (wrapped 60 long ++ wrapped 40 long ++ wrapped 50 long) + , -- The haddock bound is a hundred characters of one range. It has to break + -- somewhere, and the only honest place is before a "||". + testCase "an atom too long for a line breaks before ||" $ do + let ls = wrapped 60 seven + assertBool (show ls) (length ls > 1) + mapM_ (\l -> assertBool ("too long: " ++ l) (length l <= 60)) ls + mapM_ + (\l -> assertBool ("bad break: " ++ l) ("|| " `isPrefixOf'` dropWhile (== ' ') l)) + (drop 1 ls) + ] + where + wrapped n = map T.unpack . T.lines . wrapProof n . T.pack + isPrefixOf' p s = take (length p) s == p + isSuffixOf' p s = reverse (take (length p) (reverse s)) == p + short = "So, because foo is requested, version solving failed." + long = "Because aeson >=1.1.0.0 && <1.2.2.0 depends on base >=4.5 && <4.13 and bytestring >=0.10.0.1 && <0.10.6.0 || >=0.10.8.1 && <0.10.9.0 depends on base 4.21.0.0 (installed), aeson >=0.8.1.0 && <1.4.7.0 requires base >=4.2 && <4.15." + seven = "base ^>=4.13.0.0 || ^>=4.14.0.0 || ^>=4.15.0.0 || ^>=4.16.0.0 || ^>=4.17.0.0 || ^>=4.18.0.0 || ^>=4.19.0.0." + +-- | 'styleProof': escapes around what is there, and nothing else. +styling :: [TestTree] +styling = + [ testCase "stripping the escapes gives the input back" $ do + let inp = T.pack (unlines' [headline', "", sentence, continuation, conclusion]) + stripEscapes (styleProof inp) @?= inp + , testCase "a range is dimmed and a package name is not" $ do + let out = T.unpack (styleProof (T.pack sentence)) + assertBool out ("\ESC[2m>=1.0 && <2\ESC[0m" `isInfixOf` out) + assertBool out (not ("\ESC[2mfoo" `isInfixOf` out) && not ("\ESC[1mfoo" `isInfixOf` out)) + , testCase "the connective is bold and a continuation line has none" $ do + assertBool "opener" ("\ESC[1mAnd\ESC[0m \ESC[1mbecause\ESC[0m" `isInfixOf` T.unpack (styleProof (T.pack sentence))) + assertBool "numbered" ("\ESC[1m1.\ESC[0m" `isInfixOf` T.unpack (styleProof (T.pack ("1. " ++ sentence)))) + assertBool "numbered Because" ("\ESC[1m1.\ESC[0m \ESC[1mBecause\ESC[0m" `isInfixOf` T.unpack (styleProof (T.pack ("1. Because" ++ drop (length "And because") sentence)))) + assertBool "continuation" (not ("\ESC[1m" `isInfixOf` T.unpack (styleProof (T.pack continuation)))) + , testCase "the headline and the conclusion are bold throughout" $ do + T.unpack (styleProof (T.pack conclusion)) @?= "\ESC[1m" ++ conclusion ++ "\ESC[0m" + T.unpack (styleProof (T.pack headline')) @?= "\ESC[1m" ++ headline' ++ "\ESC[0m" + , -- A wrapped conclusion is still one bold line to the eye. + testCase "a continuation of the conclusion is bold too" $ do + let out = T.unpack (styleProof (T.pack (conclusion ++ "\n" ++ continuation))) + assertBool out (("\n\ESC[1m" ++ continuation ++ "\ESC[0m") `isInfixOf` out) + ] + where + headline' = "No solution for foo >=1.0: bar is pinned to 2 (installed)." + sentence = "And because foo >=1.0 && <2 depends on bar >=1.0, foo >=1.0 && <2 is forbidden" + continuation = " bar >=1.0 && <2 which depends on baz" + conclusion = "So, because foo >=1.0 is requested, version solving failed." + unlines' = foldr1 (\a b -> a ++ "\n" ++ b) + stripEscapes = T.replace (T.pack "\ESC[1m") T.empty . T.replace (T.pack "\ESC[2m") T.empty . T.replace (T.pack "\ESC[0m") T.empty + +untouched :: [TestTree] +untouched = + [ -- Two empty ranges do not make a sentence, and there is no dependency to + -- absorb into. + testCase "two holes stay a derivation step" $ do + let step = resolveOn (hole pkgA (range 1 2)) (hole pkgA (range 2 4)) pkgA + case causeOf (collapseNoInstances step) of + Derived _ _ -> pure () + c -> assertFailure ("expected the step to survive, got " ++ describe c) + , -- The dependee's *whole* range being empty makes the union over the pivot ⊤, + -- so the dependee entry drops out of the step's terms. Rebuilding from those + -- terms would produce a dependency fact with no dependee range in it, and the + -- proof would never mention @q@ at all. 'PubGrub.Report.dependsOnNothing' + -- renders this case as "depends on …, which has no versions", which keeps + -- the range. + testCase "a wholly empty dependee range stays a derivation step" $ do + let dep = dependsOnQ (range 1 2) + step = resolveOn dep (hole pkgQ (range 1 5)) pkgQ + Map.size (incompTerms step) @?= 1 + case causeOf (collapseNoInstances step) of + Derived _ _ -> pure () + c -> assertFailure ("expected the step to survive, got " ++ describe c) + , -- Only dependency facts are absorbed into. A hole resolved against "cannot be + -- built from source" would have to widen *that* claim, which would say the + -- empty range cannot be built from source — a different and false statement. + testCase "a hole is not absorbed into a boot-package fact" $ do + let step = resolveOn (onlyInstalled pkgA [v 3] (from 1)) (hole pkgA (range 1 2)) pkgA + case causeOf (collapseNoInstances step) of + Derived _ _ -> pure () + c -> assertFailure ("expected the step to survive, got " ++ describe c) + , -- pubgrub-rs leaves this one too (its @collapse_no_versions@ carries a TODO). + -- Dropping the hole here would print a conclusion wider than the two causes + -- named on the line justify, because the widening is what the hole paid for. + testCase "a hole against a derived sibling stays a derivation step" $ do + let inner = resolveOn (dependsOnQ (range 1 2)) (dependsOnQ (range 2 3)) pkgQ + step = resolveOn inner (hole pkgA (range 3 4)) pkgA + case causeOf (collapseNoInstances step) of + Derived _ _ -> pure () + c -> assertFailure ("expected the step to survive, got " ++ describe c) + ] + +-- -------------------------------------------------------------------------- +-- Soundness +-- -------------------------------------------------------------------------- + +soundness :: [TestTree] +soundness = + [ -- The whole argument for the pass: it changes how a step is *explained*, never + -- what it claims. If this ever fails, the proof has started asserting something + -- the solver did not derive. + testCase "the terms of every collapsed node are unchanged" $ do + let inner = resolveOn (dependsOnQ (range 1 2)) (hole pkgA (range 2 4)) pkgA + outer = resolveOn inner (hole pkgQ (range 4 5)) pkgQ + mapM_ sameTerms [inner, outer] + ] + where + sameTerms inc = do + let collapsed = collapseNoInstances inc + Map.keys (incompTerms collapsed) @?= Map.keys (incompTerms inc) + sequence_ + [ assertBool + ("term for " ++ show p ++ " changed") + (sameTerm t (Map.lookup p (incompTerms collapsed))) + | (p, t) <- Map.toList (incompTerms inc) + ] + + sameTerm (Positive a) (Just (Positive b)) = a `equivalent` b + sameTerm (Negative a) (Just (Negative b)) = a `equivalent` b + sameTerm _ _ = False + +describe :: Cause Var -> String +describe (Seed f) = "Seed " ++ fact f +describe (Fact f) = "Fact " ++ fact f +describe NoValues{} = "NoValues" +describe Derived{} = "Derived" + +fact :: CabalFact -> String +fact CauseRequest{} = "CauseRequest" +fact CauseOnlyInstalled{} = "CauseOnlyInstalled" +fact CauseUnbuildable{} = "CauseUnbuildable" +fact CauseDependency{} = "CauseDependency" +fact CauseDeclaresFlag{} = "CauseDeclaresFlag" +fact CauseConstraint{} = "CauseConstraint" diff --git a/test/SolverSpec.hs b/test/SolverSpec.hs new file mode 100644 --- /dev/null +++ b/test/SolverSpec.hs @@ -0,0 +1,131 @@ +-- | End-to-end tests for the solving loop over hand-built toy worlds. A world +-- is a dependency table keyed by instance, and its 'Provider' picks the newest +-- instance in the offered range. That exercises unit propagation, decisions, +-- conflict resolution and backtracking without a Cabal index. +module SolverSpec (tests) where + +import Data.Either (isLeft) +import Data.Functor.Identity (Identity, runIdentity) +import Data.List (maximumBy) +import qualified Data.Map.Strict as Map +import Data.Ord (comparing) +import Data.Text (Text) +import qualified Data.Text as T +import Distribution.Types.PackageName (PackageName, mkPackageName) +import PubGrub.Cabal (Var (..), fromDependency, + request) +import PubGrub.Cabal.InstanceSet (HasVersion (version), + Instance (..), InstanceSet, + emptyInstanceSet, + memberInstance, + singletonInstance) +import PubGrub.Cabal.Report (reportConflict) +import PubGrub.Cabal.Value (Value (..), ValueSet (..)) +import PubGrub.Cabal.Version (mkVersion) +import PubGrub.Provider (Provider (..)) +import PubGrub.SetOps (union) +import PubGrub.Solver (SolveError (..), solve) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +-- -------------------------------------------------------------------------- +-- Toy world helpers +-- -------------------------------------------------------------------------- + +-- | A source instance identified purely by its version; the toy worlds carry +-- their own dependency table. +inst :: [Int] -> Instance +inst ver = BuildSource (mkVersion ver) + +setOf :: [Instance] -> InstanceSet +setOf = foldr (union . singletonInstance) emptyInstanceSet + +-- | Every instance these toy worlds mention. An 'InstanceSet' cannot be +-- enumerated, so the provider enumerates these candidates and keeps the ones +-- the offered set admits, as the real bridge does. +allInstances :: [Instance] +allInstances = [rootI, foo1, foo2, bar1] + +-- | Build a provider from a dependency table. @expand p range@ commits to the +-- newest instance in @range@ (the "newest wins" preference) and turns that +-- instance's table entry into dependency incompatibilities. These worlds have +-- no flags, so a flag variable is never asked about. +mkProvider :: Applicative m => (Instance -> [(PackageName, [Instance])]) -> Provider Var m +mkProvider deps = Provider expand' + where + expand' (PackageVar p) set = + case filter (`memberInstance` vsInstances set) allInstances of + [] -> pure (Nothing, []) + candidates -> + let chosen = maximumBy (comparing version) candidates + incs = + [ fromDependency p (singletonInstance chosen) Map.empty d (setOf ds) + | (d, ds) <- deps chosen + ] + in pure (Just (PackageValue chosen), incs) + expand' _ _ = pure (Nothing, []) + +-- | Run the solver purely, seeded with one package at one instance, discarding +-- the solver's log trace. A failure is kept as its rendered report rather than +-- 'show'n: the derived 'Show' would expand the whole derivation DAG as a tree. +runSolve + :: Provider Var Identity + -> PackageName + -> Instance + -> Either Text (Map.Map Var Value) +runSolve provider p i = + either (Left . renderFailure) Right (runIdentity (solve mempty provider [request p (singletonInstance i)])) + +renderFailure :: SolveError Var -> Text +renderFailure (NoSolution i) = reportConflict i +renderFailure (NoSatisfier p _) = + T.pack ("internal error: no satisfier for " <> show p) +renderFailure _ = T.pack "internal error" + +-- | The expected answer, as the solver states it. +solutionOf :: [(PackageName, Instance)] -> Map.Map Var Value +solutionOf entries = Map.fromList [(PackageVar p, PackageValue i) | (p, i) <- entries] + +root, foo, bar :: PackageName +root = mkPackageName "root" +foo = mkPackageName "foo" +bar = mkPackageName "bar" + +rootI :: Instance +rootI = inst [0] + +foo1, foo2 :: Instance +foo1 = inst [1] +foo2 = inst [2] + +bar1 :: Instance +bar1 = inst [1] + +-- -------------------------------------------------------------------------- +-- Tests +-- -------------------------------------------------------------------------- + +tests :: TestTree +tests = + testGroup + "Solver" + [ testCase "sat: linear chain root -> foo -> bar" $ + let provider = mkProvider $ \i -> + if i == rootI + then [(foo, [foo1, foo2])] + else [(bar, [bar1]) | i == foo2] + in runSolve provider root rootI + @?= Right (solutionOf [(root, rootI), (foo, foo2), (bar, bar1)]) + , testCase "unsat: dependency with no satisfying instance" $ + let provider = mkProvider $ \i -> [(foo, []) | i == rootI] + in assertBool "expected NoSolution" (isLeft (runSolve provider root rootI)) + , testCase "backtrack: newest foo fails, solver recovers with older foo" $ + -- root needs foo; the newest (foo2) depends on an unsatisfiable + -- bar, so the solver must backtrack and settle on foo1. + let provider = mkProvider $ \i -> + if i == rootI + then [(foo, [foo1, foo2])] + else [(bar, []) | i == foo2] + in runSolve provider root rootI + @?= Right (solutionOf [(root, rootI), (foo, foo1)]) + ] diff --git a/test/StoreSpec.hs b/test/StoreSpec.hs new file mode 100644 --- /dev/null +++ b/test/StoreSpec.hs @@ -0,0 +1,471 @@ +-- | Tests for cabal's merge rule: merging dependency facts as they are inserted +-- into the solver's store. +-- +-- The property under test is the one @references\/pubgrub.md:456@ asks for: two +-- facts stating the same dependency of two /adjacent/ releases become one fact +-- over the joined range. It works without reading any @.cabal@ because the +-- provider emits over release __slots__ — half-open ranges up to the next +-- release — so the two ranges touch and their union is contiguous. +-- +-- The cases here are the boundaries of that: what must merge, what must not, and +-- what the merge must preserve (the clause's place in the scan order, and a +-- 'CauseDependency' leaf rather than a derived node). +-- +-- The store itself is the core's and is not exported; the core's own tests hold +-- it to its invariants under any rule. What is +-- tested here is cabal's rule, through 'Store' below: a model of the core's +-- store that applies the domain's rule on insert the way the store does. +module StoreSpec (tests) where + +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Distribution.Types.Flag (mkFlagName) +import Distribution.Types.PackageName (PackageName, + mkPackageName) +import Distribution.Types.PkgconfigDependency (PkgconfigDependency (..)) +import Distribution.Types.PkgconfigName (mkPkgconfigName) +import Distribution.Types.PkgconfigVersionRange (anyPkgconfigVersion) +import qualified Distribution.Types.Version as Cabal +import Distribution.Types.VersionRange (earlierVersion, + orLaterVersion) +import PubGrub.Cabal (CabalFact (..), + Flag (..), + UnbuildableReason (..), + Var (..), + fromDependency, + unbuildable) +import PubGrub.Cabal.InstanceSet (InstanceSet (..)) +import PubGrub.Cabal.Value (ValueSet (..), + instanceSet) +import PubGrub.Cabal.Version (Version) +import qualified PubGrub.Cabal.Version as V +import qualified PubGrub.Cabal.VersionSet as VersionSet +import PubGrub.Incompatibility (Cause (..), + Domain (..), + Incompatibility (..), + MergeRule (..), + noValues) +import PubGrub.SetOps (SetOps (isEmpty), + equivalent) +import PubGrub.Term (Term (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, + assertFailure, + testCase, (@?=)) + +-- -------------------------------------------------------------------------- +-- Fixtures +-- -------------------------------------------------------------------------- + +-- | The store as these tests see it: its clauses, newest first. +newtype Store d = Store {storeClauses :: [Incompatibility d]} + +emptyStore :: Store d +emptyStore = Store [] + +-- | Merge an arriving clause into the clause that has its key, where that +-- clause sits, or put it at the front: what the core's store does. +insertClause :: Domain d => Incompatibility d -> Store d -> Store d +insertClause i (Store cs) = case mergeRule of + MergeRule{mergeParts, mergeBuild} -> case mergeParts i of + Nothing -> Store (i : cs) + Just (k, s) -> case break ((== Just k) . fmap fst . mergeParts) cs of + (newer, existing : older) + | Just (first, held) <- mergeParts existing -> Store (newer ++ mergeBuild first (held <> s) : older) + _ -> Store (i : cs) + +-- | Insert several, leaving them at the front in the order given. +insertClauses :: Domain d => [Incompatibility d] -> Store d -> Store d +insertClauses is store = foldr insertClause store is + +pkgA, pkgB, pkgQ :: PackageName +pkgA = mkPackageName "a" +pkgB = mkPackageName "b" +pkgQ = mkPackageName "q" + +v :: Int -> Version +v n = V.mkVersion [n] + +-- | The same, as a Cabal version: what a declared range is written with. +cv :: Int -> Cabal.Version +cv n = Cabal.mkVersion [n] + +-- | A release's slot, as 'PubGrub.Cabal.Provider.withSlots' mints it: from this release +-- up to the next one that exists. +slot :: Int -> Int -> InstanceSet +slot lo next = sourceOnly (VersionSet.halfOpenVersionSet (v lo) (Just (v next))) + +-- | An unbounded slot — the newest release, with nothing above it. +slotFrom :: Int -> InstanceSet +slotFrom lo = sourceOnly (VersionSet.halfOpenVersionSet (v lo) Nothing) + +-- | A dependee set, the shape the provider's @widen@ produces: one cell, no pins. +range :: Int -> Int -> InstanceSet +range lo hi = + sourceOnly + ( VersionSet.intersectionVersionSet + (VersionSet.fromVersionRange (orLaterVersion (cv lo))) + (VersionSet.fromVersionRange (earlierVersion (cv hi))) + ) + +sourceOnly :: VersionSet.VersionSet -> InstanceSet +sourceOnly vs = InstanceSet{isInstalled = Set.empty, isSource = vs} + +-- | An unconditional dependency fact. +dependency :: PackageName -> InstanceSet -> PackageName -> InstanceSet -> Incompatibility Var +dependency p s q r = fromDependency p s Map.empty q r + +-- | A ban on a range of a package, as the solver mints one. +ban :: PackageName -> InstanceSet -> Incompatibility Var +ban p s = noValues (PackageVar p) (instanceSet s) + +-- | @a@ over some range depends on @q@ in @1..3@. +dependsOnQ :: InstanceSet -> Incompatibility Var +dependsOnQ dependers = dependency pkgA dependers pkgQ (range 1 3) + +-- | The same, under a flag guard. +dependsOnQWhen :: Flag -> Bool -> InstanceSet -> Incompatibility Var +dependsOnQWhen f b dependers = fromDependency pkgA dependers (Map.singleton f b) pkgQ (range 1 3) + +fast :: Flag +fast = Flag (mkFlagName "fast") True + +-- | Why a release cannot be built: a @pkg-config@ module this machine lacks. +missing :: String -> UnbuildableReason +missing name = MissingPkgConfig (PkgconfigDependency (mkPkgconfigName name) anyPkgconfigVersion) + +libpq, zlib :: NonEmpty UnbuildableReason +libpq = NE.singleton (missing "libpq") +zlib = NE.singleton (missing "zlib") + +-- | A release cannot be built here for want of @libpq@ — the reason every +-- unbuildable fact below gives unless it says otherwise. +needsLibpq :: InstanceSet -> Incompatibility Var +needsLibpq s = unbuildable pkgA s Map.empty libpq + +tests :: TestTree +tests = + testGroup + "PubGrub.Cabal: mergeRule" + [ testGroup "merging dependency facts" mergeTests + , testGroup "merging unbuildable facts" unbuildableTests + , testGroup "what must not merge" separateTests + , testGroup "self-dependencies" selfDepTests + ] + +-- -------------------------------------------------------------------------- +-- What merges +-- -------------------------------------------------------------------------- + +mergeTests :: [TestTree] +mergeTests = + [ testCase "two adjacent slots of one depender become one fact" $ do + let store = insertClauses [dependsOnQ (slot 1 2), dependsOnQ (slot 2 3)] emptyStore + case storeClauses store of + [only] -> dependerOf only `shouldDenote` sourceOnly (halfOpen 1 3) + cs -> assertFailure ("expected one clause, got " ++ show (length cs)) + , -- The reason slots are what the provider emits: two singleton ranges would + -- union to a set with a hole in it, and the hole is a range the solver then + -- has to refute separately. + testCase "the joined range is contiguous, with no hole between the releases" $ do + let store = insertClauses [dependsOnQ (slot 1 2), dependsOnQ (slot 2 3)] emptyStore + wholeSpan = sourceOnly (halfOpen 1 3) + case storeClauses store of + [only] -> + do + assertBool + "1.5 should be inside the merged depender range" + (dependerOf only `denotesVersion` V.mkVersion [1, 5]) + dependerOf only `shouldDenote` wholeSpan + cs -> assertFailure ("expected one clause, got " ++ show (length cs)) + , testCase "three slots merge into one, in any arrival order" $ do + let forwards = insertClauses [dependsOnQ (slot 1 2), dependsOnQ (slot 2 3), dependsOnQ (slotFrom 3)] emptyStore + backwards = insertClauses [dependsOnQ (slotFrom 3), dependsOnQ (slot 2 3), dependsOnQ (slot 1 2)] emptyStore + length (storeClauses forwards) @?= 1 + length (storeClauses backwards) @?= 1 + , -- What the merge is for on the reporting side: the result must stay a leaf. + -- Reaching the same range by resolving the narrow facts against each other + -- produces a 'Derived' node, and those nodes are the proof lines + -- this exists to remove. + testCase "the merged fact is a dependency leaf, not a derived node" $ do + let store = insertClauses [dependsOnQ (slot 1 2), dependsOnQ (slot 2 3)] emptyStore + case map incompCause (storeClauses store) of + [Fact (CauseDependency p _ _ (q, _))] -> (p, q) @?= (pkgA, pkgQ) + _ -> assertFailure "expected a single CauseDependency leaf" + , -- Scan position decides which clause fires first, so a merge must not move + -- the clause it merges into: the store here is [newest … oldest] and the + -- merged fact stays where the fact it absorbed was. + testCase "merging leaves the scan order alone" $ do + let other = ban pkgB (sourceOnly (halfOpen 1 2)) + store = + insertClause (dependsOnQ (slot 2 3)) $ + insertClause other $ + insertClause (dependsOnQ (slot 1 2)) emptyStore + case storeClauses store of + [b, a] -> do + case incompCause b of + NoValues p _ -> p @?= PackageVar pkgB + _ -> assertFailure "the newest clause should still be the ban" + dependerOf a `shouldDenote` sourceOnly (halfOpen 1 3) + cs -> assertFailure ("expected two clauses, got " ++ show (length cs)) + ] + +-- -------------------------------------------------------------------------- +-- What stays separate +-- -------------------------------------------------------------------------- + +separateTests :: [TestTree] +separateTests = + [ testCase "different dependees stay separate" $ do + let store = + insertClauses + [ dependency pkgA (slot 1 2) pkgQ (range 1 3) + , dependency pkgA (slot 2 3) pkgB (range 1 3) + ] + emptyStore + length (storeClauses store) @?= 2 + , -- The dependee term has to be identical, not merely overlapping: two + -- releases requiring different ranges of @q@ are two different facts, and + -- unioning their dependers would claim each release accepts the other's + -- range. + testCase "the same dependee at a different range stays separate" $ do + let store = + insertClauses + [ dependency pkgA (slot 1 2) pkgQ (range 1 3) + , dependency pkgA (slot 2 3) pkgQ (range 1 4) + ] + emptyStore + length (storeClauses store) @?= 2 + , testCase "different dependers stay separate" $ do + let store = + insertClauses + [ dependency pkgA (slot 1 2) pkgQ (range 1 3) + , dependency pkgB (slot 1 2) pkgQ (range 1 3) + ] + emptyStore + length (storeClauses store) @?= 2 + , -- A @noValues@ ban is not a merge candidate. Unlike the unbuildable facts + -- below it is minted by the /solver/, for the one range it happened to query, + -- and no part of the spec asks for those to be collapsed; merging them would + -- be sound and simply is not done. Derived clauses are + -- excluded for a stronger reason: their terms have been through the algebra, + -- where the DNF stops being canonical and structural equality stops meaning + -- set equality. + testCase "bans are never merged, even for the same package" $ do + let store = + insertClauses + [ ban pkgA (sourceOnly (halfOpen 1 2)) + , ban pkgA (sourceOnly (halfOpen 1 2)) + ] + emptyStore + length (storeClauses store) @?= 2 + , -- The guard is part of the fact. A dependency that holds only with @fast@ on + -- and one that holds unconditionally say different things about the same + -- releases, and merging them would drop the condition from one of them. + testCase "a guarded fact and an unguarded one stay separate" $ do + let store = + insertClauses + [ dependsOnQWhen fast True (slot 1 2) + , dependsOnQ (slot 2 3) + ] + emptyStore + length (storeClauses store) @?= 2 + , testCase "the same guard at the opposite value stays separate" $ do + let store = + insertClauses + [ dependsOnQWhen fast True (slot 1 2) + , dependsOnQWhen fast False (slot 2 3) + ] + emptyStore + length (storeClauses store) @?= 2 + , -- Two adjacent releases carrying the same guarded occurrence are one fact, + -- exactly as unguarded ones are: the guard's terms are identical on both + -- sides, so the union argument holds term for term. + testCase "two adjacent slots under the same guard become one fact" $ do + let store = + insertClauses + [ dependsOnQWhen fast True (slot 1 2) + , dependsOnQWhen fast True (slot 2 3) + ] + emptyStore + case storeClauses store of + [only] -> do + dependerOf only `shouldDenote` sourceOnly (halfOpen 1 3) + case incompCause only of + Fact (CauseDependency _ _ g _) -> g @?= Map.singleton fast True + _ -> assertFailure "expected a dependency leaf" + cs -> assertFailure ("expected one clause, got " ++ show (length cs)) + ] + +-- -------------------------------------------------------------------------- +-- Unbuildable facts +-- -------------------------------------------------------------------------- + +-- | @references\/pubgrub.md:477@ asks for the same adjacency collapsing that +-- @:456@ asks for on dependencies: an unselectable version, "as well as any +-- adjacent versions that are also incompatible", is /one/ incompatibility. The +-- provider states one per release slot and these are where the run becomes +-- contiguous. +unbuildableTests :: [TestTree] +unbuildableTests = + [ testCase "two adjacent unbuildable slots become one fact" $ do + let store = + insertClauses + [needsLibpq (slot 1 2), needsLibpq (slot 2 3)] + emptyStore + case storeClauses store of + [only] -> bannedBy only `shouldDenote` sourceOnly (halfOpen 1 3) + cs -> assertFailure ("expected one clause, got " ++ show (length cs)) + , -- The point of the slot, again: a run of unbuildable releases must read as one + -- range in the proof, not as one line per release with holes between them. + testCase "the run is contiguous, and covers between the releases" $ do + let store = + insertClauses + [needsLibpq (slot 1 2), needsLibpq (slot 2 3)] + emptyStore + case storeClauses store of + [only] -> + assertBool + "1.5 should be inside the merged run" + (bannedBy only `denotesVersion` V.mkVersion [1, 5]) + cs -> assertFailure ("expected one clause, got " ++ show (length cs)) + , testCase "the merged fact stays an unbuildable leaf, with its reasons" $ do + let store = + insertClauses + [needsLibpq (slot 1 2), needsLibpq (slot 2 3)] + emptyStore + case map incompCause (storeClauses store) of + [Fact (CauseUnbuildable p _ _ why)] -> (p, why) @?= (pkgA, libpq) + _ -> assertFailure "expected a single CauseUnbuildable leaf" + , testCase "different packages stay separate" $ do + let store = + insertClauses + [needsLibpq (slot 1 2), unbuildable pkgB (slot 2 3) Map.empty libpq] + emptyStore + length (storeClauses store) @?= 2 + , -- The reasons are part of the fact. Merging a release that lacks libpq with + -- one that lacks zlib would print one module against both ranges, which is + -- false of each. + testCase "adjacent slots ruled out for different reasons stay separate" $ do + let store = + insertClauses + [needsLibpq (slot 1 2), unbuildable pkgA (slot 2 3) Map.empty zlib] + emptyStore + length (storeClauses store) @?= 2 + , -- ...but the same reasons in another order are the same fact: the key is a + -- set, so the order the .cabal lists its modules in does not split a run. + testCase "the same reasons in a different order still merge" $ do + let both = unbuildable pkgA (slot 1 2) Map.empty (NE.fromList [missing "libpq", missing "zlib"]) + swapped = unbuildable pkgA (slot 2 3) Map.empty (NE.fromList [missing "zlib", missing "libpq"]) + store = insertClauses [both, swapped] emptyStore + case storeClauses store of + [only] -> bannedBy only `shouldDenote` sourceOnly (halfOpen 1 3) + cs -> assertFailure ("expected one clause, got " ++ show (length cs)) + , -- A verdict under a flag is a fact about those flag values, so two runs + -- unbuildable under the same value of the same flag are one fact, and the + -- merged clause keeps the flag term. + testCase "guarded unbuildable facts merge under the same guard, and keep it" $ do + let under b s = unbuildable pkgA s (Map.singleton fast b) libpq + store = insertClauses [under True (slot 1 2), under True (slot 2 3)] emptyStore + case storeClauses store of + [only] -> do + bannedBy only `shouldDenote` sourceOnly (halfOpen 1 3) + Map.member (FlagVar pkgA fast) (incompTerms only) @?= True + cs -> assertFailure ("expected one clause, got " ++ show (length cs)) + , testCase "guarded unbuildable facts under different guards stay separate" $ do + let under b s = unbuildable pkgA s (Map.singleton fast b) libpq + store = insertClauses [under True (slot 1 2), under False (slot 2 3), needsLibpq (slot 3 4)] emptyStore + length (storeClauses store) @?= 3 + , -- Two different facts about the same instances: "cannot be built" and + -- "has this dependency". Merging them would state one as the other. + testCase "an unbuildable fact does not merge with a dependency fact" $ do + let store = + insertClauses + [needsLibpq (slot 1 2), dependsOnQ (slot 2 3)] + emptyStore + length (storeClauses store) @?= 2 + ] + +-- -------------------------------------------------------------------------- +-- Helpers +-- -------------------------------------------------------------------------- + +-- | The instance set an unbuildable fact bans, read off its cause. +bannedBy :: Incompatibility Var -> InstanceSet +bannedBy i = case incompCause i of + Fact (CauseUnbuildable _ s _ _) -> s + _ -> error "not an unbuildable clause" + +halfOpen :: Int -> Int -> VersionSet.VersionSet +halfOpen lo hi = VersionSet.halfOpenVersionSet (v lo) (Just (v hi)) + +-- | The depender's instance set, read off the clause's cause. +dependerOf :: Incompatibility Var -> InstanceSet +dependerOf i = case incompCause i of + Fact (CauseDependency _ s _ _) -> s + _ -> error "not a dependency clause" + +-- | Semantic equality, by mutual containment; with a canonical 'InstanceSet' +-- this is '==', and keeping the semantic form says what is being asked. +shouldDenote :: InstanceSet -> InstanceSet -> IO () +shouldDenote actual expected = + assertBool "instance sets denote different things" (equivalent actual expected) + +-- | Whether the set contains the given version — asked about a version that +-- exists in no index, to check the merged range has no hole where the two slots +-- met. +denotesVersion :: InstanceSet -> Version -> Bool +denotesVersion s ver = VersionSet.contains (isSource s) ver + +-- -------------------------------------------------------------------------- +-- Self-dependencies +-- -------------------------------------------------------------------------- + +-- | A dependency of @p@ on @p@ puts /two/ entries about one variable into +-- 'fromDependency'. They have to be intersected, not overwritten. +-- +-- 'PubGrub.Store.mergeInto' rebuilds a merged clause through 'fromDependency', so +-- the shape matters here as well as at the provider, which is the other reason +-- this lives in this module. The provider does not emit such a fact at all +-- (@Bridge.Provider@, following cabal\'s @extendOpen@), so these tests are the +-- guard rather than the rule. +selfDepTests :: [TestTree] +selfDepTests = + [ testCase "the depender term survives, and the clause stays positive" $ do + -- p in [1,2) requires p in [2,3): impossible for every instance of p in + -- [1,2), and says nothing whatever about the rest of p. + case Map.toList (incompTerms (dependency pkgA (slot 1 2) pkgA (range 2 3))) of + [(p, Positive (ValueSet s _))] -> do + p @?= PackageVar pkgA + s `shouldDenote` sourceOnly (halfOpen 1 2) + ts -> + assertFailure + ( "expected one positive term about a, got " + ++ show (length ts) + ++ " term(s): " + ++ show [(p, negativeTerm t) | (p, t) <- ts] + ) + , -- The regression proper. Overwriting instead of intersecting left + -- Overwriting instead of intersecting would leave @{p: Negative depSet}@ — + -- "p must be in depSet", asserted of every instance of p rather than of the + -- ones the depender term named. On @lens@ that forces @lens ==1.7@ across a + -- whole solve. + testCase "it is never a bare requirement on the whole package" $ do + let inc = dependency pkgA (slot 1 2) pkgA (range 2 3) + assertBool + "a self-dependency must not become a Negative unit clause" + (not (any negativeTerm (Map.elems (incompTerms inc)))) + , testCase "a self-dependency covering its own slot claims nothing" $ do + -- The ordinary case: a component built against its own library, at its own + -- version. The difference is empty, so the clause is unsatisfiable — it + -- forbids nothing and constrains nothing. + case Map.toList (incompTerms (dependency pkgA (slot 1 2) pkgA (range 1 3))) of + [(_, Positive s)] -> + assertBool "expected an empty positive term" (isEmpty s) + ts -> assertFailure ("expected one term, got " ++ show (length ts)) + ] + where + negativeTerm (Negative _) = True + negativeTerm (Positive _) = False diff --git a/test/VersionSetSpec.hs b/test/VersionSetSpec.hs new file mode 100644 --- /dev/null +++ b/test/VersionSetSpec.hs @@ -0,0 +1,445 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module VersionSetSpec (tests) where + +import Data.List (nub, sort) +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Text as T +import Distribution.Pretty (prettyShow) +import qualified Distribution.Types.Version as Cabal +import Distribution.Version (VersionRange, anyVersion, + earlierVersion, + intersectVersionRanges, + laterVersion, majorBoundVersion, + majorUpperBound, noVersion, + orEarlierVersion, orLaterVersion, + thisVersion, unionVersionRanges, + withinRange) +import PubGrub.Cabal.Version (Version, fromCabalVersion, + mkVersion, toCabalVersion, + versionNumbers) +import PubGrub.Cabal.VersionSet +import PubGrub.Pretty (Pretty (pretty)) +import PubGrub.SetOps (SetOps (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (Arbitrary (..), Gen, choose, + elements, forAll, listOf, oneof, + property, sized, testProperty, + (.&&.), (===)) + +-- Small bounded version universe: components drawn from 0..3, length 1..3. +-- Trailing zeros are allowed on purpose: @1.0@ and @1@ are one version here, +-- and the properties below have to hold across both spellings. +genVersion :: Gen Version +genVersion = do + n <- choose (1, 3) + cs <- vectorOfRange n (choose (0, 3)) + pure (mkVersion cs) + where + vectorOfRange k g = sequence (replicate k g) + +-- | The same version for a Cabal range combinator: what a declared range is +-- written with. +asCabal :: Version -> Cabal.Version +asCabal = toCabalVersion + +cv :: [Int] -> Cabal.Version +cv = Cabal.mkVersion + +-- A version set built from a handful of random singletons/ranges, unioned. +instance Arbitrary VersionSet where + arbitrary = do + pieces <- listOf genPiece + pure (foldr unionVersionSet emptyVersionSet pieces) + where + genPiece = do + kind <- elements [0 :: Int, 1, 2] + a <- genVersion + b <- genVersion + let lo = min a b; hi = max a b + pure $ case kind of + 0 -> singletonVersionSet a + 1 -> fromVersionRange (orLaterVersion (asCabal lo)) + _ -> + intersectionVersionSet + (fromVersionRange (orLaterVersion (asCabal lo))) + (complementVersionSet (fromVersionRange (orLaterVersion (asCabal hi)))) + +sampleVersions :: [Version] +sampleVersions = [mkVersion [a, b] | a <- [0 .. 3], b <- [0 .. 3]] + +tests :: TestTree +tests = + testGroup + "VersionSet" + [ testProperty "complement is involutive" $ \(s :: VersionSet) -> + complementVersionSet (complementVersionSet s) === s + , testProperty "De Morgan (union)" $ \(a :: VersionSet) (b :: VersionSet) -> + complementVersionSet (unionVersionSet a b) === intersectionVersionSet (complementVersionSet a) (complementVersionSet b) + , testProperty "De Morgan (intersection)" $ \(a :: VersionSet) (b :: VersionSet) -> + complementVersionSet (intersectionVersionSet a b) === unionVersionSet (complementVersionSet a) (complementVersionSet b) + , testProperty "intersection membership" $ \(a :: VersionSet) (b :: VersionSet) -> + conjoinV $ \v -> + contains (intersectionVersionSet a b) v === (contains a v && contains b v) + , testProperty "union membership" $ \(a :: VersionSet) (b :: VersionSet) -> + conjoinV $ \v -> + contains (unionVersionSet a b) v === (contains a v || contains b v) + , testProperty "complement membership" $ \(a :: VersionSet) -> + conjoinV $ \v -> contains (complementVersionSet a) v === not (contains a v) + , testProperty "singleton contains exactly its version" $ \(NonEmptyVer v) -> + contains (singletonVersionSet v) v + .&&. conjoinV + ( \w -> + if w == v + then property True + else contains (singletonVersionSet v) w === False + ) + , testProperty "isSubsetOf agrees with intersection" $ \(a :: VersionSet) (b :: VersionSet) -> + isSubsetOf a b === (intersectionVersionSet a b == a) + , -- The sweeps answer exactly what the set-building definitions they + -- replace answered; 'isEmpty' is exact on a version set, so this is an + -- equality and not a one-sided claim. + testProperty "isSubsetOf is the emptiness of the difference" $ \(a :: VersionSet) (b :: VersionSet) -> + isSubsetOf a b === isEmpty (a `difference` b) + , testProperty "isDisjoint is the emptiness of the intersection" $ \(a :: VersionSet) (b :: VersionSet) -> + isDisjoint a b === isEmpty (a `intersect` b) + , testGroup + -- What the provider's version /slots/ rest on. A slot is + -- @halfOpenVersionSet release (next release in the index)@. Slots + -- touch, so they coalesce and tile without gaps, and an empty + -- region between releases never becomes a term the solver has to + -- learn about. + "half-open ranges (version slots)" + [ testProperty "holds its lower bound, up to but excluding the upper" $ + forAll (twoAscending genVersion) $ \(lo, hi) -> + conjoinV $ \v -> + contains (halfOpenVersionSet lo (Just hi)) v === (lo <= v && v < hi) + , testProperty "adjacent ranges coalesce" $ + forAll (threeAscending genVersion) $ \(a, b, c) -> + unionVersionSet (halfOpenVersionSet a (Just b)) (halfOpenVersionSet b (Just c)) + === halfOpenVersionSet a (Just c) + , testProperty "consecutive ranges tile from the first bound up, with no holes" $ + forAll (ascendingList genVersion) $ \vs -> case vs of + [] -> property True + (first : _) -> + foldr + (unionVersionSet . uncurry halfOpenVersionSet) + emptyVersionSet + (zip vs (map Just (drop 1 vs) ++ [Nothing])) + === fromVersionRange (orLaterVersion (asCabal first)) + , testProperty "empty when the bounds cross or meet" $ + forAll (twoAscending genVersion) $ \(lo, hi) -> + (halfOpenVersionSet hi (Just lo) === emptyVersionSet) + .&&. (halfOpenVersionSet lo (Just lo) === emptyVersionSet) + ] + , testGroup + -- 'snapToVersions' drops version space no member of the universe + -- occupies. Its whole contract is the pair "same versions of the + -- universe" and "never larger than what it was given" — the first is + -- what makes it sound to apply to a declared dependency range, the + -- second is what stops a report quoting a range wider than its author + -- wrote. + "snapToVersions" + [ testProperty "keeps exactly the universe members it had" $ + forAll genUniverse $ \universe (vs :: VersionSet) -> + foldr + ((.&&.) . (\v -> contains (snapToVersions universe vs) v === contains vs v)) + (property True) + (Set.toList universe) + , testProperty "never grows the set" $ + forAll genUniverse $ \universe (vs :: VersionSet) -> + isSubsetOf (snapToVersions universe vs) vs + , testProperty "idempotent" $ + forAll genUniverse $ \universe (vs :: VersionSet) -> + snapToVersions universe (snapToVersions universe vs) + === snapToVersions universe vs + , testProperty "an empty universe snaps everything away" $ \(vs :: VersionSet) -> + snapToVersions Set.empty vs === emptyVersionSet + ] + , testGroup + -- A set built from a declared range remembers that range's spelling, + -- and only that: the tag is what a report quotes, so it has to be the + -- author's; it must not leak into equality, or two sets denoting the + -- same versions would stop being equal; and nothing an operation + -- produces may carry one, because nobody wrote that range. A set + -- nobody wrote prints canonically, and the core's own spelling of the + -- intervals is held to Cabal's printer, so a proof reads the same + -- whether a range was declared or derived. + "declared range" + [ testProperty "is handed back as written" $ + forAll genVersion $ \v -> + pretty (fromVersionRange (majorBoundVersion (asCabal v))) + === T.pack (prettyShow (majorBoundVersion (asCabal v))) + , testProperty "a derived set prints as Cabal prints its range" $ + \vs -> pretty (vs :: VersionSet) === T.pack (prettyShow (toVersionRange vs)) + , testProperty "is invisible to Eq and Ord" $ + forAll genVersion $ \v -> + let sugared = fromVersionRange (majorBoundVersion (asCabal v)) + spelled = + fromVersionRange + ( intersectVersionRanges + (orLaterVersion (asCabal v)) + (earlierVersion (majorUpperBound (asCabal v))) + ) + in (sugared === spelled) .&&. (compare sugared spelled === EQ) + , testProperty "is dropped by every operation" $ \(a :: VersionSet) b -> + let untagged vs = declared vs === Nothing + in untagged (unionVersionSet a b) + .&&. untagged (intersectionVersionSet a b) + .&&. untagged (complementVersionSet a) + .&&. untagged (fromVersionRange anyVersion `unionVersionSet` a) + , testProperty "the constructors carry none" $ + forAll genVersion $ \v -> + (declared (singletonVersionSet v) === Nothing) + .&&. (declared (halfOpenVersionSet v Nothing) === Nothing) + .&&. (declared (belowVersionSet (Just v)) === Nothing) + .&&. (declared fullVersionSet === Nothing) + .&&. (declared emptyVersionSet === Nothing) + , testProperty "an untagged set prints canonically" $ \(a :: VersionSet) -> + prettyShow (toVersionRange a) + === prettyShow (toVersionRange (fromVersionRange (toVersionRange a))) + ] + , testGroup + -- 'fillGaps' is the dual of 'snapToVersions' restricted to interior + -- holes: it may only ever add version space that no member of the + -- universe occupies, and it may never move an outer bound. + "fillGaps" + [ testProperty "keeps exactly the universe members it had" $ + forAll genUniverse $ \universe (vs :: VersionSet) -> + foldr + ((.&&.) . (\v -> contains (fillGaps universe vs) v === contains vs v)) + (property True) + (Set.toList universe) + , testProperty "never shrinks the set" $ + forAll genUniverse $ \universe (vs :: VersionSet) -> + isSubsetOf vs (fillGaps universe vs) + , testProperty "idempotent" $ + forAll genUniverse $ \universe (vs :: VersionSet) -> + fillGaps universe (fillGaps universe vs) === fillGaps universe vs + , testProperty "leaves the outer bounds where they were" $ + forAll genUniverse $ \universe (vs :: VersionSet) -> + let bounds s = (take 1 (intervals s), take 1 (reverse (intervals s))) + lower = fst + upper = snd + (los, his) = bounds vs + (los', his') = bounds (fillGaps universe vs) + in (map lower los === map lower los') .&&. (map upper his === map upper his') + , testProperty "fills a gap nobody published into, and only that" $ + let declared = + fromVersionRange + ( unionVersionRanges + (intersectVersionRanges (orLaterVersion (cv [1, 0])) (earlierVersion (cv [1, 2]))) + (intersectVersionRanges (orLaterVersion (cv [1, 3])) (earlierVersion (cv [2]))) + ) + published = Set.fromList (map mkVersion [[1, 0], [1, 1], [1, 3], [1, 4]]) + filled = fromVersionRange (intersectVersionRanges (orLaterVersion (cv [1, 0])) (earlierVersion (cv [2]))) + in (fillGaps published declared === filled) + -- and leaves the gap alone once something is published in it + .&&. (fillGaps (Set.insert (mkVersion [1, 2, 5]) published) declared === declared) + , testProperty "an empty universe fills every hole" $ \(vs :: VersionSet) -> + length (intervals (fillGaps Set.empty vs)) <= 1 + , testProperty "the result carries no declared range" $ + forAll genUniverse $ \universe (vs :: VersionSet) -> + declared (fillGaps universe vs) === Nothing + ] + , testGroup + -- The operations work on the intervals directly. This pins them + -- to the round trip through 'VersionRange' syntax: hand each side + -- back as a range, combine with Cabal's combinator, fold the result + -- into a set again. Same set, and the same canonical + -- /representation/, since 'Eq' is semantic equality only while the + -- form stays canonical. Cabal's own canonicaliser is not the + -- reference: it orders @1.0@ below @1@, and this module does not. + -- + -- The round trip folds every range through this module's own + -- union and intersection, so it cannot catch an operation that is + -- wrong in the same way on both sides. The first property is the + -- independent check: a set built from raw range syntax holds + -- exactly the versions Cabal's 'withinRange' accepts. Its versions + -- have no trailing zero, where Cabal's order and this one agree. + "agree with the VersionRange reference" + [ testProperty "a set built from a range holds the versions Cabal's withinRange accepts" $ + forAll genPlainRange $ \r -> + foldr + (\v acc -> (contains (fromVersionRange r) (fromCabalVersion v) === withinRange v r) .&&. acc) + (property True) + plainVersions + , testProperty "union" $ + forAll genViaRange $ \a -> forAll genViaRange $ \b -> + unionVersionSet a b === viaRange2 unionVersionRanges a b + , testProperty "intersection" $ + forAll genViaRange $ \a -> forAll genViaRange $ \b -> + intersectionVersionSet a b === viaRange2 intersectVersionRanges a b + , testProperty "complement" $ + forAll genViaRange $ \a -> + complementVersionSet a === refComplement a + , testProperty "difference" $ + forAll genViaRange $ \a -> forAll genViaRange $ \b -> + intersectionVersionSet a (complementVersionSet b) + === viaRange2 intersectVersionRanges a (refComplement b) + ] + , testGroup + -- The version order is the solver's, not Cabal's: trailing zeros are + -- insignificant (see 'PubGrub.Cabal.Version'). Each case here is a + -- shape found in real proofs or in the index. + "trailing zeros are insignificant" + [ testProperty "two spellings are one version, and sort as one" $ + (mkVersion [1, 2] === mkVersion [1, 2, 0, 0]) + .&&. (compare (mkVersion [1, 2]) (mkVersion [1, 2, 0]) === EQ) + .&&. (mkVersion [1, 2] < mkVersion [1, 2, 0, 1]) + .&&. (Set.size (Set.fromList [mkVersion [1, 2], mkVersion [1, 2, 0], mkVersion [1, 2, 0, 0]]) === 1) + , testProperty "a version keeps its spelling for display" $ + (T.unpack (pretty (mkVersion [1, 2, 0, 0])) === "1.2.0.0") .&&. (T.unpack (pretty (mkVersion [1, 2])) === "1.2") + , testProperty "a singleton admits every spelling of its version" $ + contains (singletonVersionSet (mkVersion [1, 2])) (mkVersion [1, 2, 0, 0]) + .&&. contains (singletonVersionSet (mkVersion [1, 2, 0, 0])) (mkVersion [1, 2]) + , testProperty "consecutive major windows are one interval" $ + -- haddock's @base ^>=4.13.0.0 || ^>=4.14.0.0@: Cabal's @^>=4.13.0.0@ + -- stops at @<4.14@ and the next window starts at @>=4.14.0.0@. + let windows = fromVersionRange (unionVersionRanges (majorBoundVersion (cv [4, 13, 0, 0])) (majorBoundVersion (cv [4, 14, 0, 0]))) + spelled = fromVersionRange (intersectVersionRanges (orLaterVersion (cv [4, 13, 0, 0])) (earlierVersion (cv [4, 15]))) + in (windows === spelled) .&&. (length (intervals windows) === 1) + , testProperty "the space between two spellings is empty" $ + -- scion-browser's @tar >=0.3 && <0.3.0.0@: a declared @>=0.3@ minus + -- the slot of the release @0.3.0.0@ leaves no residue below it. + let declared = fromVersionRange (orLaterVersion (cv [0, 3])) + slot = halfOpenVersionSet (mkVersion [0, 3, 0, 0]) (Just (mkVersion [0, 3, 2, 0])) + in (halfOpenVersionSet (mkVersion [0, 3]) (Just (mkVersion [0, 3, 0, 0])) === emptyVersionSet) + .&&. (intersectionVersionSet declared (complementVersionSet slot) === fromVersionRange (orLaterVersion (cv [0, 3, 2, 0]))) + , testProperty "a bound spelled longer than the release still names it" $ + -- @time >=1.8.0@ against the release @time 1.8@, and @lens <5.0@ + -- against @lens 5@: Cabal excludes the first and admits the second. + contains (fromVersionRange (orLaterVersion (cv [1, 8, 0]))) (mkVersion [1, 8]) + .&&. (contains (fromVersionRange (earlierVersion (cv [5, 0]))) (mkVersion [5]) === False) + , testProperty "where two spellings meet at one cut, the shorter is kept, either way round" $ + -- language-puppet's @aeson >=2.0@ against the slot of @aeson 2.0.0.0@: + -- the derived term should read @>=2.0@, as the author wrote it. + let declared = fromVersionRange (orLaterVersion (cv [2, 0])) + slot = halfOpenVersionSet (mkVersion [2, 0, 0, 0]) (Just (mkVersion [2, 0, 2, 0])) + lowerSpelling s = [versionNumbers v | (Cut v _, _) <- intervals s] + upperSpelling s = [versionNumbers v | (_, Cut v _) <- intervals s] + below = fromVersionRange (earlierVersion (cv [1, 5])) + belowLong = halfOpenVersionSet (mkVersion [1]) (Just (mkVersion [1, 5, 0, 0])) + in (lowerSpelling (intersectionVersionSet declared slot) === [[2, 0]]) + .&&. (lowerSpelling (intersectionVersionSet slot declared) === [[2, 0]]) + .&&. (upperSpelling (intersectionVersionSet below belowLong) === [[1, 5]]) + .&&. (upperSpelling (intersectionVersionSet belowLong below) === [[1, 5]]) + .&&. (upperSpelling (unionVersionSet below belowLong) === [[1, 5]]) + .&&. (lowerSpelling (unionVersionSet slot (halfOpenVersionSet (mkVersion [2]) (Just (mkVersion [2, 0, 1])))) === [[2]]) + , testProperty "two cuts at one version, spelled differently, are one cut" $ + intersectionVersionSet (fromVersionRange (earlierVersion (cv [1, 5]))) (fromVersionRange (earlierVersion (cv [1, 5, 0, 0]))) + === fromVersionRange (earlierVersion (cv [1, 5])) + ] + , testGroup + "Lattice laws" + [ testProperty "union commutative" $ \(a :: VersionSet) b -> unionVersionSet a b === unionVersionSet b a + , testProperty "intersection commutative" $ \(a :: VersionSet) b -> intersectionVersionSet a b === intersectionVersionSet b a + , testProperty "union idempotent" $ \(a :: VersionSet) -> unionVersionSet a a === a + , testProperty "absorption" $ \(a :: VersionSet) b -> + unionVersionSet a (intersectionVersionSet a b) === a + ] + ] + where + conjoinV f = foldr ((.&&.) . f) (property True) sampleVersions + +-- | Apply a Cabal range combinator by round-tripping through 'VersionRange'. +viaRange2 :: (VersionRange -> VersionRange -> VersionRange) -> VersionSet -> VersionSet -> VersionSet +viaRange2 f a b = fromVersionRange (f (toVersionRange a) (toVersionRange b)) + +-- | The reference complement: intersect the complements of each interval, each +-- built as a union of "below the lower bound" and "above the upper bound". +refComplement :: VersionSet -> VersionSet +refComplement vs = + fromVersionRange + (foldr (intersectVersionRanges . complementInterval) anyVersion (intervals vs)) + where + complementInterval (lo, hi) = + unionVersionRanges (belowLower lo) (aboveUpper hi) + belowLower (Cut v Before) = earlierVersion (asCabal v) -- < v + belowLower (Cut v After) = orEarlierVersion (asCabal v) -- <= v + belowLower Unbounded = noVersion -- unreachable: no interval starts there + aboveUpper Unbounded = noVersion -- nothing above + aboveUpper (Cut v After) = laterVersion (asCabal v) -- > v + aboveUpper (Cut v Before) = orLaterVersion (asCabal v) -- >= v + +-- | Sets built from random 'VersionRange' syntax. 'fromVersionRange' folds it +-- through this module's own union and intersection, so these sets are not +-- independent of the implementation under test. +genViaRange :: Gen VersionSet +genViaRange = fromVersionRange <$> sized (\n -> genRange (min n 4)) + where + genRange 0 = leaf + genRange n = + oneof + [ leaf + , unionVersionRanges <$> genRange (n `div` 2) <*> genRange (n `div` 2) + , intersectVersionRanges <$> genRange (n `div` 2) <*> genRange (n `div` 2) + ] + leaf = + oneof + [ pure anyVersion + , pure noVersion + , thisVersion . asCabal <$> genVersion + , orLaterVersion . asCabal <$> genVersion + , laterVersion . asCabal <$> genVersion + , earlierVersion . asCabal <$> genVersion + , orEarlierVersion . asCabal <$> genVersion + ] + +-- | Versions with no trailing zero, as Cabal versions: on these Cabal's order +-- is the solver's, so Cabal's own 'withinRange' is an independent reference. +plainVersions :: [Cabal.Version] +plainVersions = map Cabal.mkVersion ([[a] | a <- [1 .. 4]] ++ [[a, b] | a <- [0 .. 3], b <- [1 .. 3]]) + +-- | Random range syntax over 'plainVersions', never folded through this +-- module's operations. +genPlainRange :: Gen VersionRange +genPlainRange = sized (\n -> go (min n 4)) + where + go 0 = leaf + go n = + oneof + [ leaf + , unionVersionRanges <$> go (n `div` 2) <*> go (n `div` 2) + , intersectVersionRanges <$> go (n `div` 2) <*> go (n `div` 2) + ] + leaf = do + v <- elements plainVersions + elements + [ anyVersion + , noVersion + , thisVersion v + , orLaterVersion v + , laterVersion v + , earlierVersion v + , orEarlierVersion v + , majorBoundVersion v + ] + +newtype NonEmptyVer = NonEmptyVer Version deriving Show +instance Arbitrary NonEmptyVer where + arbitrary = NonEmptyVer <$> genVersion + +-- | Distinct, strictly ascending draws — what a package's version list looks +-- like. Retried rather than sorted-and-nubbed so the generator cannot quietly +-- shrink the tuple to fewer distinct versions than the property asks for. +twoAscending :: Gen Version -> Gen (Version, Version) +twoAscending g = do + (a, b) <- (,) <$> g <*> g + if a == b then twoAscending g else pure (min a b, max a b) + +threeAscending :: Gen Version -> Gen (Version, Version, Version) +threeAscending g = do + (a, b, c) <- (,,) <$> g <*> g <*> g + case nub (sort [a, b, c]) of + [x, y, z] -> pure (x, y, z) + _ -> threeAscending g + +ascendingList :: Gen Version -> Gen [Version] +ascendingList g = nub . sort <$> listOf g + +-- | A package's version universe, in the shape 'snapToVersions' takes it. +genUniverse :: Gen (Set Version) +genUniverse = Set.fromList <$> listOf genVersion diff --git a/test/golden/branching-error-reporting.txt b/test/golden/branching-error-reporting.txt new file mode 100644 --- /dev/null +++ b/test/golden/branching-error-reporting.txt @@ -0,0 +1,7 @@ +Because every version of a depends on b >=2.0.0 && <3 and foo <1.1.0 depends on b >=1.0.0 && <2, a is incompatible with foo <1.1.0. +1. And because foo <1.1.0 depends on a >=1.0.0 && <2, foo <1.1.0 is forbidden. + +Because every version of x depends on y >=2.0.0 && <3 and foo >=1.1.0 depends on y >=1.0.0 && <2, foo >=1.1.0 is incompatible with x. +And because foo >=1.1.0 depends on x >=1.0.0 && <2, foo >=1.1.0 is forbidden. +And because foo <1.1.0 is forbidden (1), foo is forbidden. +So, because foo >=1.0.0 && <2 is requested, version solving failed. diff --git a/test/golden/linear-error-reporting.txt b/test/golden/linear-error-reporting.txt new file mode 100644 --- /dev/null +++ b/test/golden/linear-error-reporting.txt @@ -0,0 +1,2 @@ +Because every version of foo depends on bar >=2.0.0 && <3 which depends on baz >=3.0.0 && <4, every version of foo requires baz >=3.0.0 && <4. +So, because baz >=1.0.0 && <2 and foo >=1.0.0 && <2 are requested, version solving failed.