packages feed

pubgrub-cabal (empty) → 0.1.0.0

raw patch · 32 files changed

+7317/−0 lines, 32 filesdep +Cabal-syntaxdep +basedep +bytestring

Dependencies added: Cabal-syntax, base, bytestring, co-log-core, containers, pubgrub, pubgrub-cabal, tasty, tasty-golden, tasty-hunit, tasty-quickcheck, text

Files

+ CHANGELOG.md view
@@ -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++<!-- generated by git-cliff -->
+ LICENSE view
@@ -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.
+ README.md view
@@ -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
+ pubgrub-cabal.cabal view
@@ -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
+ src/PubGrub/Cabal.hs view
@@ -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
+ src/PubGrub/Cabal/Flatten.hs view
@@ -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 <buildable> then+-- <tree>@, 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]
+ src/PubGrub/Cabal/Installed.hs view
@@ -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)
+ src/PubGrub/Cabal/InstanceSet.hs view
@@ -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))]
+ src/PubGrub/Cabal/PreInstalled.hs view
@@ -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)
+ src/PubGrub/Cabal/Pretty.hs view
@@ -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
+ src/PubGrub/Cabal/Provider.hs view
@@ -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
+ src/PubGrub/Cabal/Report.hs view
@@ -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
+ src/PubGrub/Cabal/Report/Headline.hs view
@@ -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
+ src/PubGrub/Cabal/Report/Layout.hs view
@@ -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"
+ src/PubGrub/Cabal/Report/Rule.hs view
@@ -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
+ src/PubGrub/Cabal/Report/Wording.hs view
@@ -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
+ src/PubGrub/Cabal/Value.hs view
@@ -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)
+ src/PubGrub/Cabal/Version.hs view
@@ -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
+ src/PubGrub/Cabal/VersionSet.hs view
@@ -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 && <b@ pieces joined by+-- @||@, a one-version interval as @==v@ and a lower bound at @0@ omitted. The+-- declared spelling is not consulted — it is text, not syntax — so a major+-- bound comes back as @>=v && <v'@; 'PubGrub.Pretty.Pretty' is where @^>=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))
+ test/ConstraintSpec.hs view
@@ -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"+        ]
+ test/FlagSolveSpec.hs view
@@ -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) []
+ test/InstalledSpec.hs view
@@ -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"]+        ]
+ test/InstanceSetSpec.hs view
@@ -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))
+ test/Main.hs view
@@ -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+            ]
+ test/PaperSpec.hs view
@@ -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] []])+            ]+        ]
+ test/ReleaseSpec.hs view
@@ -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 []))+                        ]+                    )+        ]
+ test/ReportSpec.hs view
@@ -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"
+ test/SolverSpec.hs view
@@ -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)])+        ]
+ test/StoreSpec.hs view
@@ -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
+ test/VersionSetSpec.hs view
@@ -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
+ test/golden/branching-error-reporting.txt view
@@ -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.
+ test/golden/linear-error-reporting.txt view
@@ -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.