Cookbook.hs

{-# OPTIONS_GHC -Wno-unused-imports #-}

-- | How-to guides: recipes for the tasks a user of the library meets. They
-- assume the terms of "PubGrub.Tutorial"; "PubGrub" explains the model, and
-- each module documents its names.
--
-- The recipes share one example: a domain of packages with versions and
-- ranges, an index of releases, and a provider over it. Their code is one
-- module, @Cookbook.hs@, which the recipes build up in order: each uses only
-- what the recipes before it added, so the module compiles after every one of
-- them, and a GHCi session at the end of a recipe runs on what there is so
-- far. It needs @pubgrub@, @containers@, @text@ and @co-log-core@, and starts
-- with every import the recipes will use:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > {-# LANGUAGE TypeFamilies      #-}
-- >
-- > module Cookbook where
-- >
-- > import           Colog.Core            (LogAction (..))
-- > import           Control.Monad         (guard)
-- > import           Data.Functor.Identity (Identity (..))
-- > import           Data.List             (find, sortOn)
-- > import           Data.Map.Strict       (Map)
-- > import qualified Data.Map.Strict       as Map
-- > import           Data.Maybe            (isJust)
-- > import           Data.Ord              (Down (..))
-- > import           Data.Semigroup        (First (..))
-- > import qualified Data.Set              as Set
-- > import           Data.Text             (Text)
-- > import qualified Data.Text             as T
-- > import           PubGrub
-- > import           PubGrub.SetOps        (isSubsetOf)
module PubGrub.Cookbook
    ( -- * How to give a domain versions and ranges
      -- $versions

      -- * How to request a package, or constrain one without requesting it
      -- $requests

      -- * How to write a provider over an index of releases
      -- $provider

      -- * How to merge facts that say the same thing
      -- $merging

      -- * How to explain a failure in your domain's words
      -- $explaining

      -- * How to watch the search
      -- $watching

      -- * How to find what to release from a lock after a failure
      -- $unlocking
    ) where

import           PubGrub

-- $versions
--
-- When a variable's values are versions, use 'Version' for the values and
-- 'VersionSet' for the sets: ranges of versions, built from bounds. Make the
-- variable type an instance of 'Domain', naming the types of its values, sets
-- and facts, and give 'singleton':
--
-- > newtype Name = Name Text
-- >     deriving (Eq, Ord, Show)
-- >
-- > data Said
-- >     = Requested Name VersionSet
-- >     | Constrained Name VersionSet
-- >     | DependsOn Name VersionSet Name VersionSet
-- >     | Unusable Name VersionSet Text
-- >
-- >
-- > instance Domain Name where
-- >     type ValueOf Name = Version
-- >     type SetOf Name = VersionSet
-- >     type FactOf Name = Said
-- >     singleton _ = singletonVersionSet
--
-- The fact type is what explanations are made from: give it one constructor
-- per kind of fact the request and the provider state, carrying what a sentence
-- about it needs. The four constructors here are the four kinds of fact the
-- recipes state. A domain can also say which facts merge, which is one more line
-- in this instance; [How to merge facts that say the same thing](#g:4) adds it.
--
-- Build ranges from their bounds. @'halfOpenVersionSet' lo ('Just' hi)@ is
-- @>=lo && \<hi@, and 'aboveVersionSet', 'belowVersionSet',
-- 'singletonVersionSet' and the 'SetOps' operations make the rest. The recipes
-- write their ranges with this:
--
-- > range :: [Int] -> [Int] -> VersionSet
-- > range lo hi = halfOpenVersionSet (mkVersion lo) (Just (mkVersion hi))
--
-- A set built from a range someone wrote can keep their spelling for
-- explanations: 'declare' tags it, and 'pretty' prints the tag rather than
-- the canonical form.

-- $requests
--
-- The request is a list of seeds: incompatibilities of one term, built with
-- 'seed' from what the request said. To require a package to have a version
-- in a set, state that its having none there is impossible, with a 'Negative'
-- term:
--
-- > request :: Name -> VersionSet -> Incompatibility Name
-- > request p s = seed (Requested p s) p (Negative s)
--
-- To constrain a package without requiring it, so that /if/ it is in the plan
-- its version is in a range, forbid the versions outside the range with a
-- 'Positive' term. Sets need not have a complement, so a constraint is stated
-- through what it forbids; a version set has one, 'complementVersionSet':
--
-- > constrain :: Name -> VersionSet -> Incompatibility Name
-- > constrain p allowed = seed (Constrained p allowed) p (Positive (complementVersionSet allowed))
--
-- Give both to 'solve' in one list. A constraint narrows the choice for a
-- package the plan needs, and does not bring into the plan a package nothing
-- requires. A conflict among the seeds alone ends the solve, and the
-- explanation ends with the requests and constraints it rests on. The next
-- recipe solves with both.

-- $provider
--
-- A provider is asked about one package at a time: here are the versions it may
-- still have, pick one and say what it needs. Over an index of releases,
-- describe each release by what it needs and whether it can be used:
--
-- > data Release = Release
-- >     { needs  :: [(Name, VersionSet)]
-- >     , broken :: Maybe Text
-- >     }
-- >
-- > type Index = Map Name [(Version, Release)]
--
-- State each dependency over the release's /slot/ rather than over its version
-- alone: the range from its version up to the next release in the index, and
-- for the first release everything up to the next one, since nothing is
-- published below it. A slot holds the same releases as the version, but the
-- slots of neighbouring releases touch, so facts over them can merge into one
-- (the next recipe), and a proof says @lib \<2@ rather than
-- @lib >=1 && \<2@ of a first release:
--
-- > slot :: [Version] -> Version -> VersionSet
-- > slot versions x
-- >     | all (>= x) versions = belowVersionSet next
-- >     | otherwise = halfOpenVersionSet x next
-- >   where
-- >     next = find (> x) versions
-- >
-- > dependsOn :: Name -> VersionSet -> Name -> VersionSet -> Incompatibility Name
-- > dependsOn p ps q qs = fact (DependsOn p ps q qs) [(p, Positive ps), (q, Negative qs)]
--
-- Pick the newest release the offered set admits; the answer must be in the
-- set. When releases are passed over because they cannot be used, say why, with
-- a fact over each one's slot: the solver keeps the facts, and an explanation
-- then names the reason rather than saying that no version exists. If no
-- release is left, answer 'Nothing', still with the reasons:
--
-- > provider :: Index -> Provider Name Identity
-- > provider index = Provider $ \p offered ->
-- >     let releases = Map.findWithDefault [] p index
-- >         versions = map fst releases
-- >         newestFirst = sortOn (Down . fst) [r | r@(x, _) <- releases, offered `contains` x]
-- >         (unusable, usable) = span (isJust . broken . snd) newestFirst
-- >         reasons =
-- >             [ fact (Unusable p (slot versions x) reason) [(p, Positive (slot versions x))]
-- >             | (x, Release{broken = Just reason}) <- unusable
-- >             ]
-- >      in Identity $ case usable of
-- >             (x, release) : _ -> (Just x, reasons ++ [dependsOn p (slot versions x) q qs | (q, qs) <- needs release])
-- >             []               -> (Nothing, reasons)
--
-- An example index, and a function that solves over one:
--
-- > app, lib, util, extra :: Name
-- > app = Name "app"
-- > lib = Name "lib"
-- > util = Name "util"
-- > extra = Name "extra"
-- >
-- > example :: Index
-- > example =
-- >     Map.fromList
-- >         [ (app, [(mkVersion [1], Release [(lib, range [1] [2, 1])] Nothing)])
-- >         , ( lib
-- >           , [ (mkVersion [1], Release [(util, range [1] [3])] Nothing)
-- >             , (mkVersion [2], Release [(util, range [1] [3])] Nothing)
-- >             , (mkVersion [2, 1], Release [] (Just "it does not build here"))
-- >             ]
-- >           )
-- >         , (util, [(mkVersion [1], Release [] Nothing), (mkVersion [2], Release [] Nothing)])
-- >         , (extra, [(mkVersion [1], Release [] Nothing), (mkVersion [2], Release [] Nothing)])
-- >         ]
-- >
-- > plan :: Index -> [Incompatibility Name] -> Maybe (Map Name Version)
-- > plan index seeds = case runIdentity (solve mempty (provider index) seeds) of
-- >     Right solution -> Just solution
-- >     Left _         -> Nothing
--
-- A request alone, then with a constraint on a package the plan needs, then
-- with one on a package nothing requires:
--
-- @
-- ghci> plan example [request app fullVersionSet]
-- Just (fromList [(Name \"app\",mkVersion [1]),(Name \"lib\",mkVersion [2]),(Name \"util\",mkVersion [2])])
-- ghci> plan example [request app fullVersionSet, constrain util (range [1] [2])]
-- Just (fromList [(Name \"app\",mkVersion [1]),(Name \"lib\",mkVersion [2]),(Name \"util\",mkVersion [1])])
-- ghci> plan example [request app fullVersionSet, constrain extra (range [2] [3])]
-- Just (fromList [(Name \"app\",mkVersion [1]),(Name \"lib\",mkVersion [2]),(Name \"util\",mkVersion [2])])
-- @
--
-- This provider runs in 'Data.Functor.Identity.Identity'. One that reads its
-- index from disk runs in 'IO', and so does 'solve' then.

-- $merging
--
-- A provider that states the same dependency for each of several releases gives
-- the solver several facts where one would do. A t'MergeRule' tells the solver
-- which incompatibilities can be stated as one: it splits each into a key and a
-- part, and those with the same key are merged as they arrive, their parts
-- combined with @<>@, which for a 'VersionSet' is union. Here, two dependencies
-- with the same depender and the same dependee range merge into one over both
-- depender ranges:
--
-- > sameDependency :: MergeRule Name
-- > sameDependency =
-- >     MergeRule
-- >         { mergeParts = \i -> case incompCause i of
-- >             Fact (DependsOn p ps q qs) -> Just ((p, q, qs), ps)
-- >             _                          -> Nothing
-- >         , mergeBuild = \(p, q, qs) ps -> dependsOn p ps q qs
-- >         }
--
-- Name the rule in the domain's instance, as 'mergeRule': add this line to the
-- @instance Domain Name@ of the first recipe, after 'singleton':
--
-- >     mergeRule = sameDependency
--
-- Check one thing. The merged fact replaces both, so it must say exactly what
-- the two said together; a union of depender ranges does, since \"@lib@ in @a@
-- or @b@ needs @util@ in @r@\" is both \"@lib@ in @a@ needs @util@ in @r@\" and
-- \"@lib@ in @b@ needs @util@ in @r@\".
--
-- The dependencies of @lib@ 1 and @lib@ 2 on @util@ are stated over their
-- slots, which touch, so the merged fact is one range:
--
-- @
-- ghci> let slotOf = slot (map fst (example Map.! lib))
-- ghci> pretty (slotOf (mkVersion [1]) <> slotOf (mkVersion [2]))
-- \"\<2.1\"
-- @
--
-- The plans of the previous recipe are the same with the rule as without it;
-- what it buys is a shorter search and, in the next recipe, a proof that
-- states the dependency once.
--
-- A domain whose facts do not merge still has a reason to name a rule. When the
-- solver backtracks and decides a variable again, the provider states that
-- value's facts again, and with no rule each is one more incompatibility to
-- judge. On a search that backtracks far and often, that can cost more than the
-- rest of the search: a synthetic problem took more than ten times as long. A
-- rule that keeps one incompatibility per set of terms stops it:
--
-- > sameTerms :: (Domain v, Ord (SetOf v)) => MergeRule v
-- > sameTerms =
-- >     MergeRule
-- >         { mergeParts = \i -> case incompCause i of
-- >             Fact _ -> Just (incompTerms i, First i)
-- >             _      -> Nothing
-- >         , mergeBuild = \_ (First i) -> i
-- >         }
--
-- It needs 'Ord' on the domain's sets. Two facts with the same terms forbid the
-- same thing, so keeping the first says all that both said. A rule like
-- @sameDependency@ already does this for the facts it merges, since a repeated
-- dependency merges with itself.

-- $explaining
--
-- When there is no plan, 'solve' answers with the incompatibility the proof
-- ends with, and 'reportConflict' writes the proof out in the sentences a
-- t'Formatter' gives it. 'mkFormatter' builds one from the domain's three
-- sentences: one for each kind of fact, one for the solver's finding that a
-- package has no version in a set, and how to name a package with a set of
-- versions, from which 'summaryWith' makes the conclusions. Its other fields
-- hold rules of your own, set by record update ("PubGrub.Report" describes
-- them). This domain sets 'clauseRules', below:
--
-- > name :: Name -> VersionSet -> Text
-- > name (Name p) s = p <> " " <> pretty s
-- >
-- > formatter :: Formatter Name
-- > formatter = (mkFormatter says hole name){clauseRules = [whichDependsOn]}
-- >   where
-- >     says said _ = case said of
-- >         Requested p s       -> name p s <> " is requested"
-- >         Constrained p s     -> name p s <> " is required by a constraint"
-- >         DependsOn p ps q qs -> name p ps <> " depends on " <> name q qs
-- >         Unusable p s reason -> name p s <> " cannot be used: " <> reason
-- >     hole p s = "no version of " <> name p s <> " exists"
--
-- A sentence is a fragment: no capital letter, no full stop, and no leading
-- \"because\" or \"and\", since the proof adds its own connectives. The second
-- argument of @says@, ignored here, is the incompatibility the fact is the
-- cause of, for a sentence that depends on which of its terms survived.
--
-- A clause rule says two facts as one premise where that reads better. This one
-- writes \"a depends on b which depends on c\" rather than naming @b@ twice. It
-- fires only when the second fact covers every version of @b@ the first one
-- names, so the sentence stays true. 'Rule', 'symmetric' and 'asFact' come from
-- "PubGrub.Derivation":
--
-- > whichDependsOn :: Rule (Incompatibility Name, Incompatibility Name) Text
-- > whichDependsOn = symmetric $ \(first, second) -> do
-- >     DependsOn p ps q qs <- asFact first
-- >     DependsOn q' qs' r rs <- asFact second
-- >     guard (q == q' && qs `isSubsetOf` qs')
-- >     pure (name p ps <> " depends on " <> name q qs <> " which depends on " <> name r rs)
--
-- Then render a failure. Any 'Left' other than 'NoSolution' is a bug, in the
-- seeds, in the provider or in the solver, not a verdict on the index:
--
-- > why :: Index -> [Incompatibility Name] -> Text
-- > why index seeds = case runIdentity (solve mempty (provider index) seeds) of
-- >     Right _                -> "There is a plan."
-- >     Left (NoSolution root) -> reportConflict formatter root
-- >     Left _                 -> "The solver failed unexpectedly."
--
-- @
-- ghci> import qualified Data.Text.IO as T
-- ghci> T.putStrLn (why example [request app fullVersionSet, constrain util (range [3] [4])])
-- Because app >=0 depends on lib >=1 && \<2.1 which depends on util >=1 && \<3, app >=0 requires util >=1 && \<3.
-- So, because app >=0 is requested and util >=3 && \<4 is required by a constraint, version solving failed.
-- ghci> T.putStrLn (why example [request lib (singletonVersionSet (mkVersion [2, 1]))])
-- So, because lib >=2.1 cannot be used: it does not build here and lib ==2.1 is requested, version solving failed.
-- @
--
-- The first proof names the dependency of @lib@ on @util@ once: the merged
-- fact of the previous recipe covers @lib@ 1 and @lib@ 2 together, and the
-- clause rule joins it to @app@'s dependency on @lib@.

-- $watching
--
-- 'solve' sends a 'SolverMsg' for each step of the search to the @LogAction@ it
-- is given, from co-log-core, and the provider runs in the same monad. To print
-- the steps, solve in 'IO' with @LogAction (mapM_ T.putStrLn . describe)@. To
-- collect them, solve in a monad that can, such as a pair with a list, and lift
-- the provider into it:
--
-- > searchLog :: Index -> [Incompatibility Name] -> [Text]
-- > searchLog index seeds = fst (solve logger (Provider expandLogged) seeds)
-- >   where
-- >     logger = LogAction $ \msg -> (describe msg, ())
-- >     expandLogged p s = ([], runIdentity (expand (provider index) p s))
-- >
-- > describe :: SolverMsg Name -> [Text]
-- > describe msg = case msg of
-- >     Chose (Name p) x            -> [p <> " " <> pretty x]
-- >     NoVersionFor (Name p) s     -> ["no " <> p <> " in " <> pretty s]
-- >     Learned i                   -> ["learned: " <> sayTerms formatter (incompTerms i)]
-- >     Backtracked level           -> ["back to level " <> T.pack (show level)]
-- >     _                           -> []
--
-- @
-- ghci> mapM_ T.putStrLn (searchLog example [request app fullVersionSet, constrain util (range [3] [4])])
-- app 1
-- lib 2
-- learned: lib >=2 && \<2.1 requires util >=1 && \<3
-- back to level 1
-- lib 1
-- @
--
-- Each @learned@ line is an incompatibility the solver derived from a conflict
-- and keeps; each @back to@ line is the backtrack that followed it.

-- $unlocking
--
-- A planner that holds packages at the versions a lock file names states each as
-- a constraint. When the solve fails, 'conflictSet' gives every package that took
-- part in the failure. A held package outside it played no part, and stays held;
-- release the held packages inside it, and solve again:
--
-- > solveWithLock :: Index -> Map Name Version -> [Incompatibility Name] -> Either (SolveError Name) (Map Name Version)
-- > solveWithLock index lock requests = case attempt lock of
-- >     Left (NoSolution root)
-- >         | let involved = Map.keysSet lock `Set.intersection` conflictSet root
-- >         , not (Set.null involved) ->
-- >             attempt (Map.withoutKeys lock involved)
-- >     result -> result
-- >   where
-- >     attempt held =
-- >         runIdentity . solve mempty (provider index) $
-- >             requests ++ [constrain p (singletonVersionSet x) | (p, x) <- Map.toList held]
--
-- Here the lock holds @util@ and @extra@ at 1, and the request now asks for
-- @util >=2 && \<3@. @util@ is released and @extra@ stays at 1:
--
-- @
-- ghci> either (const Nothing) Just (solveWithLock example (Map.fromList [(util, mkVersion [1]), (extra, mkVersion [1])]) [request app fullVersionSet, request util (range [2] [3]), request extra fullVersionSet])
-- Just (fromList [(Name \"app\",mkVersion [1]),(Name \"extra\",mkVersion [1]),(Name \"lib\",mkVersion [2]),(Name \"util\",mkVersion [2])])
-- @