From 413a3f94fe358c418cd7d016e36fe2ca82bc368e Mon Sep 17 00:00:00 2001 From: Gaetano Checinski Date: Tue, 26 Feb 2019 20:43:55 +0000 Subject: [PATCH 01/25] WIP --- buckaroo/Solver.fs | 638 +++++++++++++++------------------------------ 1 file changed, 209 insertions(+), 429 deletions(-) diff --git a/buckaroo/Solver.fs b/buckaroo/Solver.fs index c3922a1..ac1dbda 100644 --- a/buckaroo/Solver.fs +++ b/buckaroo/Solver.fs @@ -18,43 +18,127 @@ module Solver = type Constraints = Map> + type ResolutionPath = + | Root of Manifest + | Node of PackageIdentifier * ResolvedVersion + type SolverState = { - Solution : Solution - Constraints : Constraints - Depth : int - Visited : Set Locations : Map - Hints : AsyncSeq - Failures: Map> + Root: Manifest + Hints: Map> + Selections : Map } - type SearchStrategyError = - | NotSatisfiable of NotSatisfiable + let constraintsOf (ds: Set) = + ds + |> Seq.map (fun x -> (x.Package, x.Constraint)) + |> Seq.groupBy fst + |> Seq.map (fun (k, xs) -> (k, xs |> Seq.map snd |> Set.ofSeq)) + |> Map.ofSeq - type LocatedVersionSet = PackageLocation * Set + let constraintsOfSelection selections = + Map.valueList selections + |> List.map (fun m -> m.Manifest.Dependencies) + |> List.fold Set.union Set.empty + |> constraintsOf - type SearchStrategy = ISourceExplorer -> SolverState -> AsyncSeq> - let private withTimeout timeout action = - async { - let! child = Async.StartChild (action, timeout) - return! child + let trimSelections (selections: Map) (deps: Set) = + + let rec loop (visited: Set) (deps: Set) : seq = seq { + let notVisited = + deps + |> Seq.filter (fun d -> visited |> Set.contains d.Package |> not) + |> Seq.toList + + let nextVisited = deps |> Seq.map (fun d -> d.Package) |> Set |> Set.union visited + + yield! + notVisited + |> Seq.filter (fun d -> selections |> Map.containsKey d.Package) + |> Seq.map (fun d -> (d.Package, selections.[d.Package])) + + let next = + notVisited + |> Seq.choose (fun d -> selections |> Map.tryFind d.Package) + |> Seq.fold (fun deps m -> Set.union m.Manifest.Dependencies deps) Set.empty + + yield! loop nextVisited next + } + + loop Set.empty deps |> Map.ofSeq + + let isUnresolved (selections : Map) (constraints : Map>) (dep:Dependency) = + let c = constraints.[dep.Package] |> Seq.toList |> All |> Constraint.simplify + selections + |> Map.tryFind dep.Package + |> Option.map (fun rv -> rv.Versions |> Constraint.satisfies c |> not) + |> Option.defaultValue true + + let findUnresolved pick (selections: Map) (deps: Set) = + + let constraints = + Map.valueList selections + |> List.map (fun m -> m.Manifest.Dependencies) + |> List.fold Set.union Set.empty + |> constraintsOf + + let rec loop (visited: Set) (deps: Set) : seq> = seq { + let notVisited = + deps + |> Seq.filter (fun d -> visited |> Set.contains d.Package |> not) + |> Seq.toList + + let nextVisited = deps |> Seq.map (fun d -> d.Package) |> Set |> Set.union visited + + let next = + notVisited + |> Seq.choose (fun d -> selections |> Map.tryFind d.Package) + |> Seq.fold (fun deps m -> Set.union m.Manifest.Dependencies deps) Set.empty + + yield! + pick + (notVisited + |> Seq.filter (isUnresolved selections constraints) + |> Seq.map (fun d -> (d.Package, constraints.[d.Package]))) + (loop nextVisited next) } - let fetchCandidatesForConstraint sourceExplorer locations package constraints = asyncSeq { - let candidatesToExplore = SourceExplorer.fetchLocationsForConstraint sourceExplorer locations package (Constraint.simplify constraints) + loop Set.empty deps + + + let breathFirst = findUnresolved (fun a b -> seq { + yield! a + yield! b + }) + + let depthFirst = findUnresolved (fun a b -> seq { + yield! b + yield! a + }) + + + + type LocatedVersionSet = PackageLocation * Set + + type SearchStrategyError = + | LimitReached of PackageIdentifier * Set + | Unsatisfiable of PackageIdentifier * Set + | TransitiveFailure of List + + type SearchStrategy = ISourceExplorer -> SolverState -> AsyncSeq> + + let fetchCandidatesForConstraint sourceExplorer locations (dep : Dependency) = asyncSeq { + let candidatesToExplore = SourceExplorer.fetchLocationsForConstraint sourceExplorer locations dep.Package dep.Constraint let mutable hasCandidates = false let mutable branchFailures = Map.empty for x in candidatesToExplore do if branchFailures |> Map.exists (fun _ v -> v > MaxConsecutiveFailures) then + let d = (dep.Package, Set [dep.Constraint]) yield - NotSatisfiable { - Package = package; - Constraint = constraints - Msg = (string MaxConsecutiveFailures) + " consecutive versions didn't have a valid manifest" - } + LimitReached d |> Result.Error else yield! @@ -71,7 +155,7 @@ module Solver = try let! lock = sourceExplorer.LockLocation packageLocation do! sourceExplorer.FetchManifest (lock, c) |> Async.Ignore - yield Result.Ok (package, (packageLocation, c)) + yield Result.Ok (dep.Package, (packageLocation, c)) hasCandidates <- true @@ -86,421 +170,131 @@ module Solver = branchFailures |> Map.insertWith (fun i j -> i + j + 1) branch 0 } - | Unsatisfiable u -> asyncSeq { - yield - Result.Error (NotSatisfiable { - Package = package; - Constraint = u - Msg = "Constraint not satisfiable" - }) - } + | FetchResult.Unsatisfiable (All xs) -> asyncSeq { + let d = (dep.Package, Set xs) + yield d |> Unsatisfiable |> Result.Error + } + | FetchResult.Unsatisfiable u -> asyncSeq { + let d = (dep.Package, Set[u]) + yield d |> Unsatisfiable |> Result.Error + } if hasCandidates = false then + let d = (dep.Package, Set [dep.Constraint]) yield - Result.Error (NotSatisfiable { - Package = package; - Constraint = constraints; - Msg = "No Version we tested had a valid manifest" - }) + LimitReached d + |> Result.Error } - let constraintsOf (ds: Set) = - ds - |> Seq.map (fun x -> (x.Package, x.Constraint)) - |> Seq.groupBy fst - |> Seq.map (fun (k, xs) -> (k, xs |> Seq.map snd |> Set.ofSeq)) - |> Map.ofSeq - - let findConflicts (solution : Solution) (dependencies : Constraints) = seq { - let maybeConflict = - Set.intersect - (dependencies |> Map.keys |> Set.ofSeq) - (solution.Resolutions |> Map.keys |> Set.ofSeq) - - yield! - maybeConflict - |> Set.toSeq - |> Seq.map (fun package -> - (package, - Constraint.satisfies - (Constraint.All (dependencies.[package] |> Set.toList )) - (fst solution.Resolutions.[package]).Versions )) - |> Seq.filter(snd >> not) - |> Seq.map fst - } - - let findUnsatisfied (solution : Solution) (dependencies : Constraints) = seq { - yield! Set.difference - (dependencies |> Map.keys |> Set.ofSeq) - (solution.Resolutions |> Map.keys |> Set.ofSeq) - } - - let private lockToHints (lock : Lock) = - lock.Packages - |> Map.toSeq - |> Seq.map (fun (k, v) -> ({ Package = k; Versions = v.Versions }, v.Location)) - - let private mergeLocations (a : Map) (b : Map) = - let folder state next = result { - let (key : AdhocPackageIdentifier, source) = next - let! s = state - match (s |> Map.tryFind key, source) with - | Some (PackageSource.Http l), PackageSource.Http r -> - let conflicts = - l - |> Map.toSeq - |> Seq.map (fun (v, s) -> (v, s, r.[v])) - |> Seq.filter(fun (_, sl, sr) -> sl <> sr) - |> Seq.toList - - match (conflicts |> List.length > 0) with - | false -> - return! - Result.Error - (ConflictingLocations (key, PackageSource.Http l, PackageSource.Http r)) - | true -> - return s - |> Map.add - key - (PackageSource.Http (Map(Seq.concat [ (Map.toSeq l) ; (Map.toSeq r) ]))) - - | Some (PackageSource.Git _), PackageSource.Git _ -> - return - s - |> Map.add key source - | Some a, b -> - return! Result.Error - (ConflictingLocations (key, a, b)) - | None, _-> - return - s - |> Map.add key source - } - a - |> Map.toSeq - |> Seq.fold folder (Result.Ok b) - - let quickSearchStrategy (sourceExplorer : ISourceExplorer) (state : SolverState) = asyncSeq { - let unsatisfied = - findUnsatisfied state.Solution state.Constraints - |> Set.ofSeq - - yield! - state.Hints - |> AsyncSeq.filter (fun (atom, _) -> unsatisfied |> Set.contains atom.Package) - |> AsyncSeq.map (fun (atom, lock) -> - Result.Ok (atom.Package, (PackageLock.toLocation lock, atom.Versions)) - ) - - for package in unsatisfied do - let constraints = - state.Constraints - |> Map.tryFind package - |> Option.defaultValue Set.empty - |> Seq.toList - |> Constraint.All - - yield! fetchCandidatesForConstraint sourceExplorer state.Locations package constraints - } - - let upgradeSearchStrategy (sourceExplorer : ISourceExplorer) (state : SolverState) = asyncSeq { - let unsatisfied = findUnsatisfied state.Solution state.Constraints - - for package in unsatisfied do - let constraints = - state.Constraints - |> Map.tryFind package - |> Option.defaultValue Set.empty - |> Seq.toList - |> Constraint.All - - yield! fetchCandidatesForConstraint sourceExplorer state.Locations package constraints - } + type ResolutionRequest = Map * Dependency * PackageSources * AsyncReplyChannel> + + let resolutionManger (sourceExplorer : ISourceExplorer) : MailboxProcessor = MailboxProcessor.Start(fun inbox -> async { + let mutable badManifests : Map = Map.empty + let mutable badDeps : Map = Map.empty + + let fetch selections locations dep = asyncSeq { + for candidate in fetchCandidatesForConstraint sourceExplorer locations dep do + match candidate with + | Result.Error (TransitiveFailure _) -> () + | Result.Error (Unsatisfiable d) -> + badDeps <- (badDeps |> Map.add d (Unsatisfiable d)) + yield Result.Error <| Unsatisfiable d + | Result.Error (LimitReached d) -> + badDeps <- (badDeps |> Map.add d (LimitReached d)) + yield Result.Error <| LimitReached d + | Result.Ok (_, (location, versions)) -> + let! lock = sourceExplorer.LockLocation location + let! manifest = sourceExplorer.FetchManifest (lock, versions) + let resolvedVersion : ResolvedVersion = { + Manifest = manifest + Versions = versions + Lock = lock + } - let private printManifestInfo log (state: SolverState) (manifest:Manifest) = - let newDepCount = - manifest.Dependencies - |> Seq.filter(fun (x : Dependency) -> state.Constraints.ContainsKey x.Package |> not) - |> Seq.length - - if newDepCount > 0 then - log(("Manifest introduces " |> text) + - (manifest.Dependencies - |> Seq.filter(fun (x : Dependency) -> state.Constraints.ContainsKey x.Package |> not) - |> Seq.length - |> string - |> info) + - ((" new dependenc" + if newDepCount > 1 then "ies" else "y") |> text), LoggingLevel.Info) - - let private candidateToAtom (sourceExplorer : ISourceExplorer) (state: SolverState) (package, (location, versions)) = async { - let! packageLock = sourceExplorer.LockLocation location - return (package, (packageLock, versions)) - } - let private filterAtom state (package, (packageLock, _)) = ( - (Set.contains (package, packageLock) state.Visited |> not) && - (match state.Solution.Resolutions |> Map.tryFind package with - | Some (rv, _) -> rv.Lock = packageLock - | None -> true) - ) - - let unlock (solution : Solution) (packages : Set) : Solution = { - Resolutions = - solution.Resolutions - |> Map.toSeq - |> Seq.filter (fst >> packages.Contains >> not) - |> Map.ofSeq - } + let constraints = constraintsOfSelection selections + let badSet = badDeps |> Map.keySet + let isBad = + constraints + |> Map.toSeq + |> Seq.map (fun (p, cs) -> p ) - let private recoverOrFail atom state log resolutions = - resolutions - |> AsyncSeq.map (fun resolution -> - match resolution with - | Resolution.Backtrack (s, f) -> - log("trying to recover from: " + f.ToString() + " [" + atom.ToString() + "]" |> text, LoggingLevel.Info) - if state.Constraints.ContainsKey f.Package && - match f.Constraint with - | All xs -> xs |> List.forall state.Constraints.[f.Package].Contains - | x -> state.Constraints.[f.Package].Contains x - then resolution - else - log("Trying different resolution to workaround: " + f.ToString() |> text, LoggingLevel.Info) - Resolution.Avoid (s, f) - | x -> x - ) - |> AsyncSeq.takeWhileInclusive (fun resolution -> - match resolution with - | Resolution.Backtrack (_, f) -> - log("Backtracking due to failure " + f.ToString() |> text, LoggingLevel.Debug) - false - | _ -> true - ) - - let private mergeConstraints c1 c2 = - c2 - |> Seq.fold - (fun m (dep : Dependency) -> - Map.insertWith - Set.union - dep.Package - (Set[dep.Constraint]) - m) - c1 - - let private updateState (package, packageLock) (freshHints) (manifest: Manifest) (state: SolverState) = - let mergedLocations = - match mergeLocations state.Locations manifest.Locations with - | Result.Ok xs -> xs - | Result.Error e -> raise (new System.Exception(e.ToString())) - - let nextConstraints = mergeConstraints state.Constraints manifest.Dependencies - - {state with - Constraints = nextConstraints - Visited = - state.Visited - |> Set.add (package, packageLock); - Locations = mergedLocations; - Hints = - state.Hints - |> AsyncSeq.append freshHints - } - let private unlockConflicts (state: SolverState) = + () - let conflicts = - findConflicts state.Solution state.Constraints - |> Set.ofSeq + //allRevisions <- (allRevisions |> Set.add (dep.Package, resolvedVersion)) - { - state with - Solution = unlock state.Solution conflicts + () } - let private addPrivatePackageSolution state package resolvedVersion solution = - { - state with - Solution = { - state.Solution with - Resolutions = - state.Solution.Resolutions - |> Map.add package (resolvedVersion, solution) - }} - - let private getHintsFromLockTask log state package lockTask = asyncSeq { - try - log( (text "Fetching lock-file for ") + (PackageIdentifier.showRich package) + "...", LoggingLevel.Debug) - let! lock = lockTask - log( (success "success ") + (text "Fetched the lock-file for ") + (PackageIdentifier.showRich package), LoggingLevel.Info) - yield! - lock - |> lockToHints - |> Seq.filter (fun (atom, packageLock) -> - Set.contains (atom.Package, packageLock) state.Visited |> not && - state.Solution.Resolutions |> Map.containsKey atom.Package |> not) - |> AsyncSeq.ofSeq - with error -> - log(string error|>text, LoggingLevel.Debug) - () - } + while true do + let! (selections, dep, locations, channel) = inbox.Receive() + let candidates = fetch locations dep - let private solvePrivate solver state dependencies = - let privatePackagesSolverState = { - Solution = Solution.empty - Locations = Map.empty - Visited = Set.empty - Hints = state.Hints - Depth = state.Depth + 1 - Constraints = constraintsOf dependencies - Failures = state.Failures - } + () + }) - solver - privatePackagesSolverState - |> AsyncSeq.choose (fun resolution -> - match resolution with - | Resolution.Ok solution -> Some solution - | _ -> None - ) - let rec private step (context : TaskContext) (strategy : SearchStrategy) (state : SolverState) : AsyncSeq = asyncSeq { + let rec private step (context : TaskContext) (strategy : SearchStrategy) (state : SolverState) : AsyncSeq = asyncSeq { let sourceExplorer = context.SourceExplorer let log = namespacedLogger context.Console ("solver") - let unsatisfied = - findUnsatisfied state.Solution state.Constraints + let manifests = + state.Selections + |> Map.valueList + |> Seq.map (fun rv -> rv.Manifest) + |> Seq.append [state.Root] |> Seq.toList - let unsatisfiables = - unsatisfied - |> Seq.filter (fun u -> - let allConstraints = state.Constraints.[u] - let badConstraints = state.Failures |> Map.findOrDefault u (Set[]) - - Set.intersect - allConstraints - badConstraints - |> Set.isEmpty |> not) - - if Seq.isEmpty unsatisfiables |> not - then () - elif Seq.isEmpty unsatisfied - then - yield Resolution.Ok state.Solution - else - let totalDeps = state.Constraints |> Map.count - let satisfiedDepsCount = totalDeps - (unsatisfied |> Seq.length) - - log( ("Resolved " |> text) + - (satisfiedDepsCount.ToString() |> highlight) + - (subtle "/") + - (totalDeps.ToString() |> highlight), - LoggingLevel.Info) - - let atomsToExplore = - strategy sourceExplorer state - |> AsyncSeq.mapAsync (fun x -> - match x with - | Result.Ok candidate -> - candidate - |> candidateToAtom sourceExplorer state - |> fun x -> async { - let! result = x; - return Result.Ok result; } - | Result.Error e -> async { return Result.Error e } - ) - |> AsyncSeq.filter (fun x -> - match x with - | Result.Ok atom -> filterAtom state atom - | _ -> true) - - let rec loop state atoms = asyncSeq { - let! atom = atoms |> AsyncSeq.tryFirst - match atom with - | None -> () - | Some (Result.Error (NotSatisfiable e)) -> - log("failed to retrive valid version for:" + e.ToString() |> text, LoggingLevel.Info) - yield Resolution.Backtrack (state.Solution, e) - | Some(Result.Ok (package, (packageLock, versions))) -> - log(("Exploring " |> text) + (PackageIdentifier.showRich package) + "...", LoggingLevel.Info) - - // We pre-emptively grab the lock - let! lockTask = - sourceExplorer.FetchLock (packageLock, versions) - |> Async.StartChild - - log("Fetching manifest..." |> text, LoggingLevel.Info) - let manifestFetchStart = System.DateTime.Now - let! manifest = sourceExplorer.FetchManifest (packageLock, versions) - let manifestFetchEnd = System.DateTime.Now - log((success "success ") + - ("Manifest fetched in " |> text) + - (info ((manifestFetchEnd - manifestFetchStart).TotalSeconds.ToString("N3") + "s")), - LoggingLevel.Info) - printManifestInfo log state manifest - - let versionSetStr = - packageLock - |> PackageLock.toLocation - |> PackageLocation.versionSetFromLocation - |> Set.union versions - |> Version.showRichSet - - log ( (success "success ") + (text "Resolved ") + (PackageIdentifier.showRich package) + (subtle " -> ") + versionSetStr, LoggingLevel.Info) - - let resolvedVersion = { - Versions = versions; - Lock = packageLock; - Manifest = manifest; - } - - let freshHints = lockTask |> getHintsFromLockTask log state package - - let privatePackagesSolutions = - solvePrivate - (step context strategy) - state - manifest.PrivateDependencies - - let newState = - state - |> updateState (package, packageLock) freshHints manifest - |> unlockConflicts - - let resolutions = - privatePackagesSolutions - |> AsyncSeq.map(addPrivatePackageSolution newState package resolvedVersion) - |> AsyncSeq.collect (step context strategy) - |> recoverOrFail (packageLock, versions) newState log - |> recoverOrFail (packageLock, versions) state log - |> AsyncSeq.scan - (fun (failures, _) resolution -> - match resolution with - | Resolution.Avoid (_, f) -> - ((failures - |> Map.insertWith - Set.union f.Package - (Set[f.Constraint])), - resolution) - | _ -> (failures, resolution)) - (newState.Failures, Resolution.Ok newState.Solution) - |> AsyncSeq.skip 1 - |> AsyncSeq.cache - - yield! resolutions |> AsyncSeq.map snd - - let! maybeLastState = AsyncSeq.tryLast resolutions - match maybeLastState with - | None -> () - | Some (_, Backtrack _) -> () - | Some (failures, _) -> - yield! loop {state with Failures = failures} (atoms |> AsyncSeq.skip 1) + let locations = + manifests + |> Seq.map (fun m -> m.Locations |> Map.toSeq) + |> Seq.fold Seq.append (Seq.ofList[]) + |> Map.ofSeq + + let unresolved = depthFirst state.Selections state.Root.Dependencies + + for (p, cs) in unresolved do + let c = cs |> Seq.toList |> All + + let hints = + state.Hints + |> Map.tryFind p + |> Option.defaultValue([]) + |> Seq.filter(fun (atom, _) -> atom.Versions |> Constraint.satisfies c) + |> AsyncSeq.ofSeq + |> AsyncSeq.mapAsync(fun (atom, location) -> async { + let! lock = sourceExplorer.LockLocation location + let! manifest = sourceExplorer.FetchManifest (lock, atom.Versions) + let resolvedVersion = { + Lock = lock + Versions = atom.Versions + Manifest = manifest + } + resolvedVersion + }) + + let candidates = SourceExplorer.fetchLocationsForConstraint sourceExplorer locations p c + + for candidate in candidates do + match candidate with + | Candidate (location, versions) -> + let! lock = sourceExplorer.LockLocation location + let! manifest = sourceExplorer.FetchManifest (lock, versions) + let resolvedVersion = { + Lock = lock + Versions = versions + Manifest = manifest } - // here we start the loop - yield! loop state atomsToExplore + let nextState = {state with Selections = state.Selections |> Map.add p resolvedVersion} + + yield! step context strategy nextState + () + + yield state } let solutionCollector resolutions = @@ -526,25 +320,11 @@ module Solver = |> Option.map (lockToHints >> AsyncSeq.ofSeq) |> Option.defaultValue AsyncSeq.empty - let strategy = - match style with - | Quick -> quickSearchStrategy - | Upgrading -> upgradeSearchStrategy - - let state = { - Solution = partialSolution; - Constraints = - Set.unionMany [ manifest.Dependencies; manifest.PrivateDependencies ] - |> constraintsOf - Depth = 0; - Visited = Set.empty; - Locations = manifest.Locations; - Hints = hints; - Failures = Map.empty - } + + let resolutions = - step context strategy state + step context strategy state manifest let result = resolutions From d49778a5b8329f40b4f6ab69532bfe4d98dcf5da Mon Sep 17 00:00:00 2001 From: Gaetano Checinski Date: Fri, 1 Mar 2019 16:56:22 +0000 Subject: [PATCH 02/25] poc: actor based resolver --- buckaroo-tests/Solver.fs | 116 ++++++++-------- buckaroo/Solver.fs | 276 +++++++++++++++++++++++-------------- buckaroo/UpgradeCommand.fs | 7 +- 3 files changed, 231 insertions(+), 168 deletions(-) diff --git a/buckaroo-tests/Solver.fs b/buckaroo-tests/Solver.fs index f2f486e..23fe763 100644 --- a/buckaroo-tests/Solver.fs +++ b/buckaroo-tests/Solver.fs @@ -510,64 +510,64 @@ let ``Solver does not upgrade if a complete solution is supplied`` () = Assert.Equal ("1", getLockedRev "c" solution) () -[] -let ``Solver upgrades completes partial solution with latest packages`` () = - let cookBook = [ - (package "a", - Set[ver 2; br "a"], - manifest []) - (package "a", - Set[ver 1; br "a"], - manifest []) - (package "b", - Set[ver 2; br "a"], - manifest []) - (package "b", - Set[ver 1; br "a"], - manifest []) - (package "c", - Set[ver 2; br "a"], - manifest []) - (package "c", - Set[ver 1; br "a"], - manifest []) - ] - - let lockBookSpec = [ - (("root", 0), [ - ("a", 1, Set[ver 1; br "a"]) - ("b", 1, Set[ver 1; br "a"]) - ("c", 1, Set[ver 1; br "a"]) - ]) - ] - - let root = manifest [ - ("a", Exactly (br "a") ) - ("b", Exactly (br "a") ) - ("c", Exactly (br "a") ) - ] - - let lockBook = lockBookOf lockBookSpec - let rootLock = lockBook |> Map.find (packageLock ("root", 0)) - - let explorer = TestingSourceExplorer(cookBook, lockBook) - let completeSolution = - Solver.fromLock explorer rootLock - |> Async.RunSynchronously - - let partialSolution = Set[package "b"] |> Solver.unlock completeSolution - - let solution = - solve - partialSolution - cookBook lockBookSpec root - ResolutionStyle.Upgrading - |> Async.RunSynchronously - - Assert.Equal ("1", getLockedRev "a" solution) - Assert.Equal ("2", getLockedRev "b" solution) - Assert.Equal ("1", getLockedRev "c" solution) - () +//[] +// let ``Solver upgrades completes partial solution with latest packages`` () = +// let cookBook = [ +// (package "a", +// Set[ver 2; br "a"], +// manifest []) +// (package "a", +// Set[ver 1; br "a"], +// manifest []) +// (package "b", +// Set[ver 2; br "a"], +// manifest []) +// (package "b", +// Set[ver 1; br "a"], +// manifest []) +// (package "c", +// Set[ver 2; br "a"], +// manifest []) +// (package "c", +// Set[ver 1; br "a"], +// manifest []) +// ] + +// let lockBookSpec = [ +// (("root", 0), [ +// ("a", 1, Set[ver 1; br "a"]) +// ("b", 1, Set[ver 1; br "a"]) +// ("c", 1, Set[ver 1; br "a"]) +// ]) +// ] + +// let root = manifest [ +// ("a", Exactly (br "a") ) +// ("b", Exactly (br "a") ) +// ("c", Exactly (br "a") ) +// ] + +// let lockBook = lockBookOf lockBookSpec +// let rootLock = lockBook |> Map.find (packageLock ("root", 0)) + +// let explorer = TestingSourceExplorer(cookBook, lockBook) +// let completeSolution = +// Solver.fromLock explorer rootLock +// |> Async.RunSynchronously + +// let partialSolution = Set[package "b"] |> Solver.unlock completeSolution + +// let solution = +// solve +// partialSolution +// cookBook lockBookSpec root +// ResolutionStyle.Upgrading +// |> Async.RunSynchronously + +// Assert.Equal ("1", getLockedRev "a" solution) +// Assert.Equal ("2", getLockedRev "b" solution) +// Assert.Equal ("1", getLockedRev "c" solution) +// () [] let ``Solver can handle the simple triangle case`` () = diff --git a/buckaroo/Solver.fs b/buckaroo/Solver.fs index ac1dbda..134d472 100644 --- a/buckaroo/Solver.fs +++ b/buckaroo/Solver.fs @@ -43,7 +43,7 @@ module Solver = |> constraintsOf - let trimSelections (selections: Map) (deps: Set) = + let pruneSelections (selections: Map) (deps: Set) = let rec loop (visited: Set) (deps: Set) : seq = seq { let notVisited = @@ -51,19 +51,22 @@ module Solver = |> Seq.filter (fun d -> visited |> Set.contains d.Package |> not) |> Seq.toList - let nextVisited = deps |> Seq.map (fun d -> d.Package) |> Set |> Set.union visited + if notVisited |> List.isEmpty + then () + else + let nextVisited = deps |> Seq.map (fun d -> d.Package) |> Set |> Set.union visited - yield! - notVisited - |> Seq.filter (fun d -> selections |> Map.containsKey d.Package) - |> Seq.map (fun d -> (d.Package, selections.[d.Package])) + yield! + notVisited + |> Seq.filter (fun d -> selections |> Map.containsKey d.Package) + |> Seq.map (fun d -> (d.Package, selections.[d.Package])) - let next = - notVisited - |> Seq.choose (fun d -> selections |> Map.tryFind d.Package) - |> Seq.fold (fun deps m -> Set.union m.Manifest.Dependencies deps) Set.empty + let next = + notVisited + |> Seq.choose (fun d -> selections |> Map.tryFind d.Package) + |> Seq.fold (fun deps m -> Set.union m.Manifest.Dependencies deps) Set.empty - yield! loop nextVisited next + yield! loop nextVisited next } loop Set.empty deps |> Map.ofSeq @@ -76,11 +79,10 @@ module Solver = |> Option.defaultValue true let findUnresolved pick (selections: Map) (deps: Set) = - let constraints = Map.valueList selections |> List.map (fun m -> m.Manifest.Dependencies) - |> List.fold Set.union Set.empty + |> List.fold Set.union deps |> constraintsOf let rec loop (visited: Set) (deps: Set) : seq> = seq { @@ -89,19 +91,22 @@ module Solver = |> Seq.filter (fun d -> visited |> Set.contains d.Package |> not) |> Seq.toList - let nextVisited = deps |> Seq.map (fun d -> d.Package) |> Set |> Set.union visited + if notVisited |> List.isEmpty + then () + else + let nextVisited = deps |> Seq.map (fun d -> d.Package) |> Set |> Set.union visited - let next = - notVisited - |> Seq.choose (fun d -> selections |> Map.tryFind d.Package) - |> Seq.fold (fun deps m -> Set.union m.Manifest.Dependencies deps) Set.empty + let next = + notVisited + |> Seq.choose (fun d -> selections |> Map.tryFind d.Package) + |> Seq.fold (fun deps m -> Set.union m.Manifest.Dependencies deps) Set.empty - yield! - pick - (notVisited - |> Seq.filter (isUnresolved selections constraints) - |> Seq.map (fun d -> (d.Package, constraints.[d.Package]))) - (loop nextVisited next) + yield! + pick + (notVisited + |> Seq.filter (isUnresolved selections constraints) + |> Seq.map (fun d -> (d.Package, constraints.[d.Package]))) + (loop nextVisited next) } loop Set.empty deps @@ -121,22 +126,25 @@ module Solver = type LocatedVersionSet = PackageLocation * Set + type PackageConstraint = PackageIdentifier * Set + type SearchStrategyError = - | LimitReached of PackageIdentifier * Set - | Unsatisfiable of PackageIdentifier * Set - | TransitiveFailure of List + | LimitReached of PackageConstraint + | Unsatisfiable of PackageConstraint + | IntroducesConflict of List + type ResolutionRequest = Map * PackageConstraint * PackageSources * AsyncReplyChannel>> type SearchStrategy = ISourceExplorer -> SolverState -> AsyncSeq> - let fetchCandidatesForConstraint sourceExplorer locations (dep : Dependency) = asyncSeq { - let candidatesToExplore = SourceExplorer.fetchLocationsForConstraint sourceExplorer locations dep.Package dep.Constraint + let fetchCandidatesForConstraint sourceExplorer locations p c = asyncSeq { + let candidatesToExplore = SourceExplorer.fetchLocationsForConstraint sourceExplorer locations p c let mutable hasCandidates = false let mutable branchFailures = Map.empty for x in candidatesToExplore do if branchFailures |> Map.exists (fun _ v -> v > MaxConsecutiveFailures) then - let d = (dep.Package, Set [dep.Constraint]) + let d = (p, Set [c]) yield LimitReached d |> Result.Error @@ -155,7 +163,7 @@ module Solver = try let! lock = sourceExplorer.LockLocation packageLocation do! sourceExplorer.FetchManifest (lock, c) |> Async.Ignore - yield Result.Ok (dep.Package, (packageLocation, c)) + yield Result.Ok (p, (packageLocation, c)) hasCandidates <- true @@ -171,78 +179,107 @@ module Solver = |> Map.insertWith (fun i j -> i + j + 1) branch 0 } | FetchResult.Unsatisfiable (All xs) -> asyncSeq { - let d = (dep.Package, Set xs) + let d = (p, Set xs) yield d |> Unsatisfiable |> Result.Error } | FetchResult.Unsatisfiable u -> asyncSeq { - let d = (dep.Package, Set[u]) + let d = (p, Set[u]) yield d |> Unsatisfiable |> Result.Error } if hasCandidates = false then - let d = (dep.Package, Set [dep.Constraint]) + let d = (p, Set [c]) yield - LimitReached d + Unsatisfiable d |> Result.Error } - type ResolutionRequest = Map * Dependency * PackageSources * AsyncReplyChannel> + let rec constraintToSet c = + match c with + | All xs -> xs |> List.map constraintToSet |> Set.unionMany + | _ -> Set [c] let resolutionManger (sourceExplorer : ISourceExplorer) : MailboxProcessor = MailboxProcessor.Start(fun inbox -> async { - let mutable badManifests : Map = Map.empty - let mutable badDeps : Map = Map.empty + let mutable badDeps : Map = Map.empty - let fetch selections locations dep = asyncSeq { - for candidate in fetchCandidatesForConstraint sourceExplorer locations dep do + let trackLocal locations (p, cs) = asyncSeq { + let mutable hadCandidate = false + let c = cs |> Seq.toList |> All |> Constraint.simplify + + for candidate in fetchCandidatesForConstraint sourceExplorer locations p c do match candidate with - | Result.Error (TransitiveFailure _) -> () + | Result.Error (IntroducesConflict _) -> () | Result.Error (Unsatisfiable d) -> badDeps <- (badDeps |> Map.add d (Unsatisfiable d)) yield Result.Error <| Unsatisfiable d | Result.Error (LimitReached d) -> - badDeps <- (badDeps |> Map.add d (LimitReached d)) + if hadCandidate <> false + then + badDeps <- (badDeps |> Map.add d (LimitReached d)) yield Result.Error <| LimitReached d | Result.Ok (_, (location, versions)) -> let! lock = sourceExplorer.LockLocation location let! manifest = sourceExplorer.FetchManifest (lock, versions) - let resolvedVersion : ResolvedVersion = { - Manifest = manifest - Versions = versions - Lock = lock - } - - let constraints = constraintsOfSelection selections - let badSet = badDeps |> Map.keySet - let isBad = - constraints - |> Map.toSeq - |> Seq.map (fun (p, cs) -> p ) - - - () - - //allRevisions <- (allRevisions |> Set.add (dep.Package, resolvedVersion)) + let conflicts = + manifest.Dependencies + |> Seq.choose (fun d -> badDeps |> Map.tryFind (d.Package, constraintToSet d.Constraint)) + |> Seq.toList + + if conflicts.IsEmpty + then + hadCandidate <- true + yield candidate + else + yield Result.Error (IntroducesConflict conflicts) + + if hadCandidate + then () + else badDeps <- (badDeps |> Map.add (p, cs) (IntroducesConflict[])) + } + let trackGlobal (constraints: Constraints) (candidates: AsyncSeq>) = asyncSeq { + for candidate in candidates do + match candidate with + | Result.Error e -> yield Result.Error e + | Result.Ok (_, (location, versions)) -> + let! lock = sourceExplorer.LockLocation location + let! manifest = sourceExplorer.FetchManifest (lock, versions) + let conflicts = + manifest.Dependencies + |> Seq.filter (fun d -> constraints |> Map.containsKey d.Package) + |> Seq.filter (fun d -> constraints.[d.Package] <> (constraintToSet d.Constraint)) + |> Seq.map (fun d -> (d.Package, constraintToSet d.Constraint)) + |> Seq.choose (fun (p, cs) -> + badDeps + |> Map.tryFindKey (fun (q, bs) _ -> p = q && cs |> Set.isSubset bs) + |> Option.map (fun k -> badDeps.[k])) + |> Seq.toList + + if conflicts.IsEmpty + then yield candidate + else yield Result.Error (IntroducesConflict conflicts) () + () } while true do let! (selections, dep, locations, channel) = inbox.Receive() - let candidates = fetch locations dep - - () + let constraints = constraintsOfSelection selections + let candidates = trackLocal locations dep |> trackGlobal constraints + channel.Reply candidates }) - let rec private step (context : TaskContext) (strategy : SearchStrategy) (state : SolverState) : AsyncSeq = asyncSeq { - + let rec private step (context : TaskContext) (resolver : MailboxProcessor) (state : SolverState) (path: List): AsyncSeq = asyncSeq { let sourceExplorer = context.SourceExplorer let log = namespacedLogger context.Console ("solver") + let selections = pruneSelections state.Selections state.Root.Dependencies + let manifests = - state.Selections + selections |> Map.valueList |> Seq.map (fun rv -> rv.Manifest) |> Seq.append [state.Root] @@ -254,47 +291,61 @@ module Solver = |> Seq.fold Seq.append (Seq.ofList[]) |> Map.ofSeq - let unresolved = depthFirst state.Selections state.Root.Dependencies + let unresolved = depthFirst selections state.Root.Dependencies |> Seq.toList - for (p, cs) in unresolved do - let c = cs |> Seq.toList |> All + System.Console.WriteLine (List.length unresolved |> string) + if (unresolved |> List.length) = 0 + then yield state + else + for (p, cs) in unresolved do + let c = cs |> Seq.toList |> All - let hints = - state.Hints - |> Map.tryFind p - |> Option.defaultValue([]) - |> Seq.filter(fun (atom, _) -> atom.Versions |> Constraint.satisfies c) - |> AsyncSeq.ofSeq - |> AsyncSeq.mapAsync(fun (atom, location) -> async { - let! lock = sourceExplorer.LockLocation location - let! manifest = sourceExplorer.FetchManifest (lock, atom.Versions) - let resolvedVersion = { - Lock = lock - Versions = atom.Versions - Manifest = manifest - } - resolvedVersion - }) - - let candidates = SourceExplorer.fetchLocationsForConstraint sourceExplorer locations p c - - for candidate in candidates do - match candidate with - | Candidate (location, versions) -> - let! lock = sourceExplorer.LockLocation location - let! manifest = sourceExplorer.FetchManifest (lock, versions) - let resolvedVersion = { - Lock = lock - Versions = versions - Manifest = manifest - } + let hints = + state.Hints + |> Map.tryFind p + |> Option.defaultValue([]) + |> Seq.filter(fun (atom, _) -> atom.Versions |> Constraint.satisfies c) + |> AsyncSeq.ofSeq + |> AsyncSeq.chooseAsync(fun (atom, location) -> async { + try + let! lock = sourceExplorer.LockLocation location + let! manifest = sourceExplorer.FetchManifest (lock, atom.Versions) + let resolvedVersion = { + Lock = lock + Versions = atom.Versions + Manifest = manifest + } + return Some {state with Selections = state.Selections |> Map.add p resolvedVersion} + with _ -> return None + }) - let nextState = {state with Selections = state.Selections |> Map.add p resolvedVersion} + let! request = resolver.PostAndAsyncReply (fun channel -> (selections, (p, cs), locations, channel)) + + let fetched = + request + |> AsyncSeq.chooseAsync(fun candidate -> async { + match candidate with + | Result.Error _ -> + //TODO + return None + | Result.Ok (_, (location, versions)) -> + let! lock = sourceExplorer.LockLocation location + let! manifest = sourceExplorer.FetchManifest (lock, versions) + let resolvedVersion = { + Lock = lock + Versions = versions + Manifest = manifest + } + return Some {state with Selections = state.Selections |> Map.add p resolvedVersion}}) + + for nextState in AsyncSeq.append hints fetched do + let node = Node (p, nextState.Selections.[p]) + let visited = path |> List.contains node + if visited <> true + then + yield! step context resolver nextState (node :: path) - yield! step context strategy nextState () - - yield state } let solutionCollector resolutions = @@ -315,19 +366,32 @@ module Solver = |> List.tryHead let solve (context : TaskContext) (partialSolution : Solution) (manifest : Manifest) (style : ResolutionStyle) (lock : Lock option) = async { - let hints = - lock - |> Option.map (lockToHints >> AsyncSeq.ofSeq) - |> Option.defaultValue AsyncSeq.empty + System.Console.WriteLine "aaaa" + let hints = Map.empty + // lock + // |> Option.map (fun l -> + // l.Packages |> Map.map (fun p v -> [({Package = p; Versions = v.Versions}, v.Location)] ) ) + // |> Option.defaultValue Map.empty + + let state = { + Root = manifest + Hints = hints + Selections = Map.empty + Locations = manifest.Locations + } + let resolver = resolutionManger context.SourceExplorer let resolutions = - step context strategy state manifest + step context resolver state [Root manifest] let result = resolutions + |> AsyncSeq.map (fun s -> + Resolution.Ok <| {Resolutions = s.Selections |> Map.map(fun k v -> (v, Solution.empty))} + ) |> solutionCollector |> Option.defaultValue (Set.empty |> Resolution.Conflict) diff --git a/buckaroo/UpgradeCommand.fs b/buckaroo/UpgradeCommand.fs index 0ef8fe5..cdfdcc8 100644 --- a/buckaroo/UpgradeCommand.fs +++ b/buckaroo/UpgradeCommand.fs @@ -37,10 +37,9 @@ let task context (packages : List) = async { async { let! solution = Solver.fromLock context.SourceExplorer lock - return - packages - |> Set.ofList - |> Solver.unlock solution + return solution + // |> Set.ofList + // |> Solver.unlock solution } do! ResolveCommand.task context partial ResolutionStyle.Upgrading From 564f138c05a8c2083928572d2551a0c855fec591 Mon Sep 17 00:00:00 2001 From: Gaetano Checinski Date: Fri, 1 Mar 2019 23:22:36 +0000 Subject: [PATCH 03/25] further refinements --- buckaroo/Solver.fs | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/buckaroo/Solver.fs b/buckaroo/Solver.fs index 134d472..0ce2f03 100644 --- a/buckaroo/Solver.fs +++ b/buckaroo/Solver.fs @@ -24,7 +24,7 @@ module Solver = type SolverState = { Locations : Map - Root: Manifest + Root : Set Hints: Map> Selections : Map } @@ -276,22 +276,21 @@ module Solver = let sourceExplorer = context.SourceExplorer let log = namespacedLogger context.Console ("solver") - let selections = pruneSelections state.Selections state.Root.Dependencies + let selections = pruneSelections state.Selections state.Root let manifests = selections |> Map.valueList |> Seq.map (fun rv -> rv.Manifest) - |> Seq.append [state.Root] |> Seq.toList let locations = manifests |> Seq.map (fun m -> m.Locations |> Map.toSeq) - |> Seq.fold Seq.append (Seq.ofList[]) + |> Seq.fold Seq.append (state.Locations |> Map.toSeq) |> Map.ofSeq - let unresolved = depthFirst selections state.Root.Dependencies |> Seq.toList + let unresolved = depthFirst selections state.Root |> Seq.toList System.Console.WriteLine (List.length unresolved |> string) if (unresolved |> List.length) = 0 @@ -366,9 +365,6 @@ module Solver = |> List.tryHead let solve (context : TaskContext) (partialSolution : Solution) (manifest : Manifest) (style : ResolutionStyle) (lock : Lock option) = async { - - System.Console.WriteLine "aaaa" - let hints = Map.empty // lock // |> Option.map (fun l -> @@ -376,7 +372,9 @@ module Solver = // |> Option.defaultValue Map.empty let state = { - Root = manifest + Root = Set.union + manifest.Dependencies + manifest.PrivateDependencies Hints = hints Selections = Map.empty Locations = manifest.Locations From 1beb7396d570b67c31f7a540f014141916547129 Mon Sep 17 00:00:00 2001 From: Gaetano Checinski Date: Sat, 2 Mar 2019 23:38:41 +0000 Subject: [PATCH 04/25] WIP --- buckaroo/DefaultSourceExplorer.fs | 2 +- buckaroo/GitCli.fs | 1 + buckaroo/GitManager.fs | 1 + buckaroo/Solver.fs | 163 +++++++++++++++++++++--------- 4 files changed, 120 insertions(+), 47 deletions(-) diff --git a/buckaroo/DefaultSourceExplorer.fs b/buckaroo/DefaultSourceExplorer.fs index 72ebe0e..4e702e3 100644 --- a/buckaroo/DefaultSourceExplorer.fs +++ b/buckaroo/DefaultSourceExplorer.fs @@ -101,7 +101,7 @@ type DefaultSourceExplorer (console : ConsoleManager, downloadManager : Download match maybeBranchRef with | Some branchRef -> yield branchRef.Revision - yield! gitManager.FetchCommits url branchRef.Revision + yield! gitManager.FetchCommits url branch () | None -> () } diff --git a/buckaroo/GitCli.fs b/buckaroo/GitCli.fs index 4bbef58..b840cdd 100644 --- a/buckaroo/GitCli.fs +++ b/buckaroo/GitCli.fs @@ -222,6 +222,7 @@ type GitCli (console : ConsoleManager) = return (skip + (nextList |> List.length), nextList, fetchNext) }) ( 0, List.empty, async { return () } ) + |> AsyncSeq.takeWhile (fun (_, revs, _) -> revs.Length > 0) |> AsyncSeq.collect (fun (_, revs, fetchNext) -> asyncSeq { yield! revs |> AsyncSeq.ofSeq do! fetchNext diff --git a/buckaroo/GitManager.fs b/buckaroo/GitManager.fs index ac865ec..a7d52a2 100644 --- a/buckaroo/GitManager.fs +++ b/buckaroo/GitManager.fs @@ -94,6 +94,7 @@ type GitManager (console : ConsoleManager, git : IGit, cacheDirectory : string) |> Async.Ignore | None -> let! defaultBranch = git.DefaultBranch targetDirectory + yield AsyncSeq.interleave (if defaultBranch <> "master" diff --git a/buckaroo/Solver.fs b/buckaroo/Solver.fs index 0ce2f03..c68c6aa 100644 --- a/buckaroo/Solver.fs +++ b/buckaroo/Solver.fs @@ -133,7 +133,11 @@ module Solver = | Unsatisfiable of PackageConstraint | IntroducesConflict of List - type ResolutionRequest = Map * PackageConstraint * PackageSources * AsyncReplyChannel>> + type ResolutionRequest = + | GetSnapshot of AsyncReplyChannel>>> + | GetCandidates of Constraints * PackageConstraint * PackageSources * AsyncReplyChannel>> + + type SearchStrategy = ISourceExplorer -> SolverState -> AsyncSeq> let fetchCandidatesForConstraint sourceExplorer locations p c = asyncSeq { @@ -201,42 +205,69 @@ module Solver = | All xs -> xs |> List.map constraintToSet |> Set.unionMany | _ -> Set [c] + + let resolutionManger (sourceExplorer : ISourceExplorer) : MailboxProcessor = MailboxProcessor.Start(fun inbox -> async { let mutable badDeps : Map = Map.empty + let mutable world : Map>> = Map.empty + let mutable complete : Set = Set.empty + + let testIfBad (p, cs) = + badDeps + |> Map.tryFindKey (fun (q, bs) _ -> p = q && cs |> Set.isSubset bs) + |> Option.map (fun k -> badDeps.[k]) + + let testIfSelectionGood (constraints : Constraints) = + constraints + |> Map.toSeq + |> Seq.tryFind (fun (p, cs) -> + badDeps |> Map.containsKey (p, cs)) + |> Option.isNone + let trackLocal locations (p, cs) = asyncSeq { let mutable hadCandidate = false let c = cs |> Seq.toList |> All |> Constraint.simplify - for candidate in fetchCandidatesForConstraint sourceExplorer locations p c do - match candidate with - | Result.Error (IntroducesConflict _) -> () - | Result.Error (Unsatisfiable d) -> - badDeps <- (badDeps |> Map.add d (Unsatisfiable d)) - yield Result.Error <| Unsatisfiable d - | Result.Error (LimitReached d) -> - if hadCandidate <> false - then - badDeps <- (badDeps |> Map.add d (LimitReached d)) - yield Result.Error <| LimitReached d - | Result.Ok (_, (location, versions)) -> - let! lock = sourceExplorer.LockLocation location - let! manifest = sourceExplorer.FetchManifest (lock, versions) - let conflicts = - manifest.Dependencies - |> Seq.choose (fun d -> badDeps |> Map.tryFind (d.Package, constraintToSet d.Constraint)) - |> Seq.toList - - if conflicts.IsEmpty - then - hadCandidate <- true - yield candidate - else - yield Result.Error (IntroducesConflict conflicts) - - if hadCandidate - then () - else badDeps <- (badDeps |> Map.add (p, cs) (IntroducesConflict[])) + let isBad = testIfBad (p, cs) + + match isBad with + | Some e -> yield Result.Error e + | None -> + for candidate in fetchCandidatesForConstraint sourceExplorer locations p c do + match candidate with + | Result.Error (IntroducesConflict _) -> () + | Result.Error (Unsatisfiable d) -> + badDeps <- (badDeps |> Map.add d (Unsatisfiable d)) + yield Result.Error <| Unsatisfiable d + | Result.Error (LimitReached d) -> + if hadCandidate <> false + then + badDeps <- (badDeps |> Map.add d (LimitReached d)) + yield Result.Error <| LimitReached d + | Result.Ok (_, (location, versions)) -> + let! lock = sourceExplorer.LockLocation location + let! manifest = sourceExplorer.FetchManifest (lock, versions) + + let packageConstraints = manifest.Dependencies |> Set.map (fun d -> (d.Package, d.Constraint |> constraintToSet)) + world <- (world |> Map.insertWith Set.union (p, cs) (Set[packageConstraints])) + + let conflicts = + manifest.Dependencies + |> Seq.choose (fun d -> badDeps |> Map.tryFind (d.Package, constraintToSet d.Constraint)) + |> Seq.toList + + if conflicts.IsEmpty + then + hadCandidate <- true + yield candidate + else + yield Result.Error (IntroducesConflict conflicts) + + if hadCandidate + then () + else badDeps <- (badDeps |> Map.add (p, cs) (IntroducesConflict[])) + complete <- complete |> Set.add (p, cs) } let trackGlobal (constraints: Constraints) (candidates: AsyncSeq>) = asyncSeq { @@ -254,21 +285,28 @@ module Solver = |> Seq.choose (fun (p, cs) -> badDeps |> Map.tryFindKey (fun (q, bs) _ -> p = q && cs |> Set.isSubset bs) - |> Option.map (fun k -> badDeps.[k])) + |> Option.map (fun k -> IntroducesConflict [badDeps.[k]])) |> Seq.toList if conflicts.IsEmpty - then yield candidate - else yield Result.Error (IntroducesConflict conflicts) + then + yield candidate + else + yield Result.Error (IntroducesConflict conflicts) () () } while true do - let! (selections, dep, locations, channel) = inbox.Receive() - let constraints = constraintsOfSelection selections - let candidates = trackLocal locations dep |> trackGlobal constraints - channel.Reply candidates + let! req = inbox.Receive() + match req with + | GetCandidates (constraints, dep, locations, channel) -> + trackLocal locations dep + |> trackGlobal constraints + |> AsyncSeq.takeWhileInclusive (fun _ -> testIfBad dep |> Option.isNone) + |> AsyncSeq.takeWhileInclusive (fun _ -> testIfSelectionGood constraints) + |> channel.Reply + | GetSnapshot channel -> channel.Reply world }) @@ -277,6 +315,13 @@ module Solver = let log = namespacedLogger context.Console ("solver") let selections = pruneSelections state.Selections state.Root + let constraints = + selections + |> Map.valueList + |> Seq.map (fun m -> m.Manifest.Dependencies) + |> Seq.append [state.Root] + |> Set.unionMany + |> constraintsOf let manifests = selections @@ -290,11 +335,11 @@ module Solver = |> Seq.fold Seq.append (state.Locations |> Map.toSeq) |> Map.ofSeq - let unresolved = depthFirst selections state.Root |> Seq.toList + let unresolved = breathFirst selections state.Root |> Seq.toList - System.Console.WriteLine (List.length unresolved |> string) - if (unresolved |> List.length) = 0 - then yield state + if (unresolved |> Seq.isEmpty) + then + yield state else for (p, cs) in unresolved do let c = cs |> Seq.toList |> All @@ -318,14 +363,14 @@ module Solver = with _ -> return None }) - let! request = resolver.PostAndAsyncReply (fun channel -> (selections, (p, cs), locations, channel)) + let! candidates = resolver.PostAndAsyncReply (fun channel -> GetCandidates (constraints, (p, cs), locations, channel)) let fetched = - request + candidates |> AsyncSeq.chooseAsync(fun candidate -> async { match candidate with - | Result.Error _ -> - //TODO + | Result.Error e -> + System.Console.WriteLine e return None | Result.Ok (_, (location, versions)) -> let! lock = sourceExplorer.LockLocation location @@ -336,6 +381,9 @@ module Solver = Manifest = manifest } return Some {state with Selections = state.Selections |> Map.add p resolvedVersion}}) + |> AsyncSeq.distinctUntilChangedWith (fun prev next -> + prev.Selections.[p].Manifest = next.Selections.[p].Manifest + ) for nextState in AsyncSeq.append hints fetched do let node = Node (p, nextState.Selections.[p]) @@ -344,7 +392,30 @@ module Solver = then yield! step context resolver nextState (node :: path) - () + System.Console.WriteLine ("Exhausted " + (string p) + (string cs)) + let! world = resolver.PostAndAsyncReply (fun ch -> GetSnapshot ch) + System.Console.WriteLine ( + world |> Map.toSeq |> Seq.map (fun (pc, ss) -> + (string pc) + " -> {\n" + + ((ss |> Seq.map (fun s -> s |> Seq.map string |> String.concat "\n") |> String.concat "\n") + + "\n}" + + ) + ) |> String.concat "\n") + + + // System.Console.WriteLine (unresolved |> List.map (fun (p, cs) -> string p + (string cs) ) |> String.concat "\n") + + // System.Console.WriteLine ( + // path + // |> List.map( + // fun x -> + // match x with + // | Root _ -> "Root" + // | Node (p, r) -> (string p + "@" + string r.Versions)) + // |> String.concat "\n" + // ) + // () } let solutionCollector resolutions = From 3af77d484933da19a108c41c977ace185eaefddd Mon Sep 17 00:00:00 2001 From: Gaetano Checinski Date: Mon, 4 Mar 2019 11:26:22 +0000 Subject: [PATCH 05/25] computes unresolvable cores now. TODO: trim the tree properly --- buckaroo/Solver.fs | 140 +++++++++++++++++++++++++++++++++++---------- 1 file changed, 110 insertions(+), 30 deletions(-) diff --git a/buckaroo/Solver.fs b/buckaroo/Solver.fs index c68c6aa..24d979e 100644 --- a/buckaroo/Solver.fs +++ b/buckaroo/Solver.fs @@ -134,7 +134,7 @@ module Solver = | IntroducesConflict of List type ResolutionRequest = - | GetSnapshot of AsyncReplyChannel>>> + | MarkBadPath of List * PackageConstraint * PackageConstraint * AsyncReplyChannel | GetCandidates of Constraints * PackageConstraint * PackageSources * AsyncReplyChannel>> @@ -205,12 +205,11 @@ module Solver = | All xs -> xs |> List.map constraintToSet |> Set.unionMany | _ -> Set [c] - - let resolutionManger (sourceExplorer : ISourceExplorer) : MailboxProcessor = MailboxProcessor.Start(fun inbox -> async { let mutable badDeps : Map = Map.empty + let mutable badCores : Set> = Set.empty let mutable world : Map>> = Map.empty - let mutable complete : Set = Set.empty + let testIfBad (p, cs) = badDeps @@ -224,6 +223,24 @@ module Solver = badDeps |> Map.containsKey (p, cs)) |> Option.isNone + let testIfHasBadCore (constraints : Constraints) = + let deps = + constraints + |> Map.toSeq + |> Set + + let isBad = + badCores + |> Set.exists (fun core -> Set.isSuperset deps core) + + System.Console.WriteLine (badCores + |> Set.map (fun core -> Set.difference core deps)) + + if isBad + then System.Console.WriteLine "BADDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD" + + isBad + let trackLocal locations (p, cs) = asyncSeq { let mutable hadCandidate = false @@ -248,9 +265,9 @@ module Solver = | Result.Ok (_, (location, versions)) -> let! lock = sourceExplorer.LockLocation location let! manifest = sourceExplorer.FetchManifest (lock, versions) - let packageConstraints = manifest.Dependencies |> Set.map (fun d -> (d.Package, d.Constraint |> constraintToSet)) - world <- (world |> Map.insertWith Set.union (p, cs) (Set[packageConstraints])) + + world <- (world |> Map.insertWith Set.union (p, cs) (Set [packageConstraints])) let conflicts = manifest.Dependencies @@ -262,30 +279,33 @@ module Solver = hadCandidate <- true yield candidate else - yield Result.Error (IntroducesConflict conflicts) + () + //ield Result.Error (IntroducesConflict conflicts) if hadCandidate then () - else badDeps <- (badDeps |> Map.add (p, cs) (IntroducesConflict[])) - complete <- complete |> Set.add (p, cs) + else () + //badDeps <- (badDeps |> Map.add (p, cs) (IntroducesConflict[])) + + } let trackGlobal (constraints: Constraints) (candidates: AsyncSeq>) = asyncSeq { for candidate in candidates do match candidate with - | Result.Error e -> yield Result.Error e + | Result.Error e -> + yield Result.Error e | Result.Ok (_, (location, versions)) -> let! lock = sourceExplorer.LockLocation location let! manifest = sourceExplorer.FetchManifest (lock, versions) let conflicts = manifest.Dependencies |> Seq.filter (fun d -> constraints |> Map.containsKey d.Package) - |> Seq.filter (fun d -> constraints.[d.Package] <> (constraintToSet d.Constraint)) - |> Seq.map (fun d -> (d.Package, constraintToSet d.Constraint)) - |> Seq.choose (fun (p, cs) -> + |> Seq.map (fun d -> (d.Package, constraintToSet d.Constraint |> Set.union constraints.[d.Package])) + |> Seq.choose (fun (p, _) -> badDeps - |> Map.tryFindKey (fun (q, bs) _ -> p = q && cs |> Set.isSubset bs) - |> Option.map (fun k -> IntroducesConflict [badDeps.[k]])) + |> Map.tryFindKey (fun (q, bs) _ -> p = q && constraints.[p] |> Set.isSubset bs) + |> Option.map (fun k -> badDeps.[k])) |> Seq.toList if conflicts.IsEmpty @@ -294,6 +314,7 @@ module Solver = else yield Result.Error (IntroducesConflict conflicts) () + () } @@ -303,10 +324,51 @@ module Solver = | GetCandidates (constraints, dep, locations, channel) -> trackLocal locations dep |> trackGlobal constraints - |> AsyncSeq.takeWhileInclusive (fun _ -> testIfBad dep |> Option.isNone) - |> AsyncSeq.takeWhileInclusive (fun _ -> testIfSelectionGood constraints) + |> AsyncSeq.takeWhile (fun _ -> testIfBad dep |> Option.isNone) + |> AsyncSeq.takeWhile (fun _ -> testIfSelectionGood constraints) + |> AsyncSeq.takeWhile (fun _ -> testIfHasBadCore constraints |> not) |> channel.Reply - | GetSnapshot channel -> channel.Reply world + | MarkBadPath (path, failedDep, (p, bs), channel) -> + //System.Console.WriteLine ("Marking " + string failedDep + " because " + string (p, bs) ) + + let groups = + world.[failedDep] + |> Set.map(fun xs -> + xs + |> Set.filter(fun (q, _) -> p = q ) + |> Set.map(fun (_, cs) -> cs ) + |> Set.unionMany) + + for contribution in groups do + + let core = + path + |> Seq.choose(fun x -> + match x with + | Root m -> Some m.Dependencies + | Node (q, rv) -> + if q <> fst failedDep && p <> q + then + Some rv.Manifest.Dependencies + else None) + |> Seq.map (fun deps -> + deps + |> Seq.map (fun x -> (x.Package, x.Constraint |> constraintToSet |> (fun c -> Set.difference c contribution))) + |> Seq.filter (fun (q, cs) -> cs.IsEmpty |> not) + |> Seq.filter (fun (q, cs) -> p = q && Set.isProperSubset cs bs) // should be an intersection + |> Set + + ) + |> Set.unionMany + |> Set.add failedDep + + badCores <- badCores |> Set.add core + // System.Console.WriteLine "bad core: " + //System.Console.WriteLine core + // System.Console.WriteLine "-------" + + channel.Reply () + }) @@ -323,6 +385,7 @@ module Solver = |> Set.unionMany |> constraintsOf + let manifests = selections |> Map.valueList @@ -335,7 +398,7 @@ module Solver = |> Seq.fold Seq.append (state.Locations |> Map.toSeq) |> Map.ofSeq - let unresolved = breathFirst selections state.Root |> Seq.toList + let unresolved = depthFirst selections state.Root |> Seq.toList if (unresolved |> Seq.isEmpty) then @@ -363,14 +426,16 @@ module Solver = with _ -> return None }) - let! candidates = resolver.PostAndAsyncReply (fun channel -> GetCandidates (constraints, (p, cs), locations, channel)) + let! requested = + resolver.PostAndAsyncReply (fun channel -> GetCandidates (constraints, (p, cs), locations, channel)) + let candidates = requested |> AsyncSeq.cache let fetched = candidates |> AsyncSeq.chooseAsync(fun candidate -> async { match candidate with | Result.Error e -> - System.Console.WriteLine e + //System.Console.WriteLine e return None | Result.Ok (_, (location, versions)) -> let! lock = sourceExplorer.LockLocation location @@ -392,16 +457,31 @@ module Solver = then yield! step context resolver nextState (node :: path) - System.Console.WriteLine ("Exhausted " + (string p) + (string cs)) - let! world = resolver.PostAndAsyncReply (fun ch -> GetSnapshot ch) - System.Console.WriteLine ( - world |> Map.toSeq |> Seq.map (fun (pc, ss) -> - (string pc) + " -> {\n" - + ((ss |> Seq.map (fun s -> s |> Seq.map string |> String.concat "\n") |> String.concat "\n") - + "\n}" - ) - ) |> String.concat "\n") + let! error = + candidates + |> AsyncSeq.choose (fun candidate -> + match candidate with + | Result.Error (IntroducesConflict [Unsatisfiable (p, cs)]) -> + //System.Console.WriteLine "####################################################################" + Some (p, cs) + | _ -> None) + |> AsyncSeq.tryFirst + + match error with + | Some transitiveFailure -> + () + do! resolver.PostAndAsyncReply (fun ch -> MarkBadPath (path, (p, cs), transitiveFailure, ch)) + + constraints + |> Map.toSeq + |> Seq.map(fun x -> System.Console.WriteLine x) + |> Seq.toList + |> ignore + + + | None -> () + // System.Console.WriteLine (unresolved |> List.map (fun (p, cs) -> string p + (string cs) ) |> String.concat "\n") From a0ea65fa15dacc764d0557cfaf5aefaa6cae38db Mon Sep 17 00:00:00 2001 From: Gaetano Checinski Date: Mon, 4 Mar 2019 11:37:09 +0000 Subject: [PATCH 06/25] feat: compound Constraints use sets instead of list --- buckaroo/Constraint.fs | 68 ++++++++++++++++++++------------------ buckaroo/Solver.fs | 10 +++--- buckaroo/SourceExplorer.fs | 6 ++-- 3 files changed, 44 insertions(+), 40 deletions(-) diff --git a/buckaroo/Constraint.fs b/buckaroo/Constraint.fs index 1d4d795..0d1f4a7 100644 --- a/buckaroo/Constraint.fs +++ b/buckaroo/Constraint.fs @@ -21,8 +21,8 @@ type RangeComparatorTypes = type Constraint = | Exactly of Version | Range of RangeComparatorTypes * SemVer -| Any of List -| All of List +| Any of Set +| All of Set | Complement of Constraint #nowarn "40" @@ -31,13 +31,13 @@ module Constraint = open FParsec - let wildcard = All [] + let wildcard = All Set.empty let intersection (c : Constraint) (d : Constraint) : Constraint = - All [ c; d ] + All (Set[ c; d ]) let union (c : Constraint) (d : Constraint) : Constraint = - Any [ c; d ] + Any (Set[ c; d ]) let complement (c : Constraint) : Constraint = Complement c @@ -120,30 +120,34 @@ module Constraint = let iterate c = match c with | Complement (Complement x) -> x - | Constraint.All [ x ] -> x | Constraint.All xs -> - xs - |> Seq.collect (fun x -> - match x with - | All xs -> xs - | _ -> [ x ] - ) - |> Seq.sort - |> Seq.distinct - |> Seq.toList - |> Constraint.All - | Constraint.Any [ x ] -> x + match xs |> Set.toList with + | [x] -> x + | xs -> + xs + |> Seq.collect (fun x -> + match x with + | All xs -> xs + | _ -> Set[ x ] + ) + |> Seq.sort + |> Seq.distinct + |> Set + |> Constraint.All | Constraint.Any xs -> - xs - |> Seq.collect (fun x -> - match x with - | Any xs -> xs - | _ -> [ x ] - ) - |> Seq.sort - |> Seq.distinct - |> Seq.toList - |> Constraint.Any + match xs |> Set.toList with + | [x] -> x + | xs -> + xs + |> Seq.collect (fun x -> + match x with + | Any xs -> xs + | _ -> Set[ x ] + ) + |> Seq.sort + |> Seq.distinct + |> Set + |> Constraint.Any | _ -> c let next = iterate c if next = c @@ -154,7 +158,7 @@ module Constraint = let wildcardParser = parse { do! CharParsers.skipString "*" - return All [] + return All Set.empty } let symbolParser<'T> (token : string, symbol : 'T) = parse { @@ -178,10 +182,10 @@ module Constraint = | Patch -> { semVer with Patch = semVer.Patch + 1; Increment = 0 } Constraint.All - [ + (Set[ Constraint.Range (GTE, semVer); Constraint.Range (LT, max); - ] + ]) let rangeParser = parse { let! rangeType = rangeTypeParser @@ -227,7 +231,7 @@ module Constraint = let! elements = CharParsers.spaces1 |> Primitives.sepBy parser do! CharParsers.skipString ")" - return Any elements + return Any (Set elements) } let allParser = parse { @@ -235,7 +239,7 @@ module Constraint = let! elements = CharParsers.spaces1 |> Primitives.sepBy parser do! CharParsers.skipString ")" - return All elements + return All (Set elements) } return! choice [ diff --git a/buckaroo/Solver.fs b/buckaroo/Solver.fs index 24d979e..ff2eb8b 100644 --- a/buckaroo/Solver.fs +++ b/buckaroo/Solver.fs @@ -72,7 +72,7 @@ module Solver = loop Set.empty deps |> Map.ofSeq let isUnresolved (selections : Map) (constraints : Map>) (dep:Dependency) = - let c = constraints.[dep.Package] |> Seq.toList |> All |> Constraint.simplify + let c = constraints.[dep.Package] |> All |> Constraint.simplify selections |> Map.tryFind dep.Package |> Option.map (fun rv -> rv.Versions |> Constraint.satisfies c |> not) @@ -202,7 +202,7 @@ module Solver = let rec constraintToSet c = match c with - | All xs -> xs |> List.map constraintToSet |> Set.unionMany + | All xs -> xs | _ -> Set [c] let resolutionManger (sourceExplorer : ISourceExplorer) : MailboxProcessor = MailboxProcessor.Start(fun inbox -> async { @@ -237,14 +237,14 @@ module Solver = |> Set.map (fun core -> Set.difference core deps)) if isBad - then System.Console.WriteLine "BADDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD" + then System.Console.WriteLine "BADDDDDDDDDDDDDDDDDDDDDDDDDDDDDDddDDDDDDDDDDDDDDDDDDD" isBad let trackLocal locations (p, cs) = asyncSeq { let mutable hadCandidate = false - let c = cs |> Seq.toList |> All |> Constraint.simplify + let c = cs |> All |> Constraint.simplify let isBad = testIfBad (p, cs) @@ -405,7 +405,7 @@ module Solver = yield state else for (p, cs) in unresolved do - let c = cs |> Seq.toList |> All + let c = cs |> All let hints = state.Hints diff --git a/buckaroo/SourceExplorer.fs b/buckaroo/SourceExplorer.fs index f0d0769..8e46fcd 100644 --- a/buckaroo/SourceExplorer.fs +++ b/buckaroo/SourceExplorer.fs @@ -53,7 +53,7 @@ module SourceExplorer = |> AsyncSeq.fold (fun s x -> Set.add x s) Set.empty yield! - loop (Constraint.All []) + loop (Constraint.All Set.empty) |> AsyncSeq.filter (fun x -> match x with | Candidate (location, _) -> @@ -65,7 +65,7 @@ module SourceExplorer = | Any xs -> yield! xs - |> List.distinct + |> Set.toList |> List.sortDescending |> List.map loop |> AsyncSeq.mergeAll @@ -103,7 +103,7 @@ module SourceExplorer = ) else xs - |> List.distinct + |> Set.toList |> List.sort |> List.map (loop >> (AsyncSeq.scan (fun s x -> Set.add x s) Set.empty)) |> List.reduce (AsyncSeq.combineLatestWith (fun x y -> From 2e65b668f3d5cfed15088e0fe3d22cfd25ce9c2f Mon Sep 17 00:00:00 2001 From: Gaetano Checinski Date: Wed, 6 Mar 2019 12:20:51 +0000 Subject: [PATCH 07/25] WIP --- buckaroo/GitManager.fs | 26 ++-- buckaroo/Solver.fs | 316 +++++++++++++++++++---------------------- 2 files changed, 161 insertions(+), 181 deletions(-) diff --git a/buckaroo/GitManager.fs b/buckaroo/GitManager.fs index a7d52a2..c5dd18a 100644 --- a/buckaroo/GitManager.fs +++ b/buckaroo/GitManager.fs @@ -128,22 +128,22 @@ type GitManager (console : ConsoleManager, git : IGit, cacheDirectory : string) let cacheDir = cloneFolderName url let startTime = System.DateTime.Now let! refs = - Async.Parallel - ( - (git.RemoteRefs url - |> Async.Catch - |> Async.map(Choice.toOption >> Option.defaultValue([]))), + // Async.Parallel + // ( + // (git.RemoteRefs url + // |> Async.Catch + // |> Async.map(Choice.toOption >> Option.defaultValue([]))), (git.RemoteRefs cacheDir |> Async.Catch |> Async.map(Choice.toOption >> Option.defaultValue([]))) - ) - |> Async.map(fun (a, b) -> - if a.Length = 0 && b.Length = 0 then - raise <| new SystemException("No internet connection and the cache is empty") - else if a.Length > 0 - then a - else b - ) + // ) + // |> Async.map(fun (a, b) -> + // if a.Length = 0 && b.Length = 0 then + // raise <| new SystemException("No internet connection and the cache is empty") + // else if a.Length > 0 + // then a + // else b + // ) refsCache <- refsCache |> Map.add url refs let endTime = System.DateTime.Now log((success "success ") + diff --git a/buckaroo/Solver.fs b/buckaroo/Solver.fs index ff2eb8b..bb5c3cf 100644 --- a/buckaroo/Solver.fs +++ b/buckaroo/Solver.fs @@ -29,16 +29,42 @@ module Solver = Selections : Map } - let constraintsOf (ds: Set) = + type PackageConstraint = PackageIdentifier * Set + + + type LocatedVersionSet = PackageLocation * Set + + type SearchStrategyError = + | LimitReached of PackageConstraint + | Unresolvable of PackageConstraint + | TransitiveConflict of Set * SearchStrategyError + | Conflicts of Set + + type ResolutionRequest = + | MarkBadPath of List * PackageConstraint * Set * AsyncReplyChannel + | GetCandidates of Constraints * PackageConstraint * PackageSources * AsyncReplyChannel>> + + type SearchStrategy = ISourceExplorer -> SolverState -> AsyncSeq> + + + let toDnf c = + match c with + | All xs -> xs + | _ -> Set [c] + + let toPackageConstraint (dep : Dependency) : PackageConstraint = + (dep.Package, toDnf dep.Constraint) + + let constraintsOf (ds: seq) = ds - |> Seq.map (fun x -> (x.Package, x.Constraint)) |> Seq.groupBy fst - |> Seq.map (fun (k, xs) -> (k, xs |> Seq.map snd |> Set.ofSeq)) + |> Seq.map (fun (k, xs) -> (k, xs |> Seq.map snd |> Set.unionMany)) |> Map.ofSeq let constraintsOfSelection selections = Map.valueList selections |> List.map (fun m -> m.Manifest.Dependencies) + |> List.map (Set.map toPackageConstraint) |> List.fold Set.union Set.empty |> constraintsOf @@ -71,7 +97,7 @@ module Solver = loop Set.empty deps |> Map.ofSeq - let isUnresolved (selections : Map) (constraints : Map>) (dep:Dependency) = + let isUnresolved (selections : Map) (constraints : Map>) (dep : Dependency) = let c = constraints.[dep.Package] |> All |> Constraint.simplify selections |> Map.tryFind dep.Package @@ -82,7 +108,8 @@ module Solver = let constraints = Map.valueList selections |> List.map (fun m -> m.Manifest.Dependencies) - |> List.fold Set.union deps + |> List.map (Set.map toPackageConstraint) + |> List.fold Set.union (deps |> Set.map toPackageConstraint) |> constraintsOf let rec loop (visited: Set) (deps: Set) : seq> = seq { @@ -122,24 +149,6 @@ module Solver = yield! a }) - - - type LocatedVersionSet = PackageLocation * Set - - type PackageConstraint = PackageIdentifier * Set - - type SearchStrategyError = - | LimitReached of PackageConstraint - | Unsatisfiable of PackageConstraint - | IntroducesConflict of List - - type ResolutionRequest = - | MarkBadPath of List * PackageConstraint * PackageConstraint * AsyncReplyChannel - | GetCandidates of Constraints * PackageConstraint * PackageSources * AsyncReplyChannel>> - - - type SearchStrategy = ISourceExplorer -> SolverState -> AsyncSeq> - let fetchCandidatesForConstraint sourceExplorer locations p c = asyncSeq { let candidatesToExplore = SourceExplorer.fetchLocationsForConstraint sourceExplorer locations p c @@ -184,110 +193,93 @@ module Solver = } | FetchResult.Unsatisfiable (All xs) -> asyncSeq { let d = (p, Set xs) - yield d |> Unsatisfiable |> Result.Error + yield d |> Unresolvable |> Result.Error } | FetchResult.Unsatisfiable u -> asyncSeq { let d = (p, Set[u]) - yield d |> Unsatisfiable |> Result.Error + yield d |> Unresolvable |> Result.Error } if hasCandidates = false then let d = (p, Set [c]) yield - Unsatisfiable d + Unresolvable d |> Result.Error } - let rec constraintToSet c = - match c with - | All xs -> xs - | _ -> Set [c] - let resolutionManger (sourceExplorer : ISourceExplorer) : MailboxProcessor = MailboxProcessor.Start(fun inbox -> async { - let mutable badDeps : Map = Map.empty - let mutable badCores : Set> = Set.empty + let mutable unresolvableCores : Map, SearchStrategyError> = Map.empty + let mutable underconstraintDeps : Set = Set.empty let mutable world : Map>> = Map.empty - - let testIfBad (p, cs) = - badDeps - |> Map.tryFindKey (fun (q, bs) _ -> p = q && cs |> Set.isSubset bs) - |> Option.map (fun k -> badDeps.[k]) - - let testIfSelectionGood (constraints : Constraints) = - constraints - |> Map.toSeq - |> Seq.tryFind (fun (p, cs) -> - badDeps |> Map.containsKey (p, cs)) - |> Option.isNone - let testIfHasBadCore (constraints : Constraints) = let deps = constraints |> Map.toSeq |> Set - let isBad = - badCores - |> Set.exists (fun core -> Set.isSuperset deps core) - - System.Console.WriteLine (badCores - |> Set.map (fun core -> Set.difference core deps)) - - if isBad - then System.Console.WriteLine "BADDDDDDDDDDDDDDDDDDDDDDDDDDDDDDddDDDDDDDDDDDDDDDDDDD" - - isBad + unresolvableCores + |> Map.toSeq + |> Seq.filter (fun (core, _) -> + core + |> Set.forall (fun (p, bs) -> + constraints + |> Map.tryFind p + |> Option.map (Set.isSubset bs) + |> Option.defaultValue false + )) let trackLocal locations (p, cs) = asyncSeq { let mutable hadCandidate = false let c = cs |> All |> Constraint.simplify - let isBad = testIfBad (p, cs) + let conflicts = testIfHasBadCore (Map.ofSeq [(p, cs)]) |> Seq.tryHead - match isBad with - | Some e -> yield Result.Error e + match conflicts with + | Some (dep, _) -> + System.Console.WriteLine (string (p, cs)) + yield Result.Error (Unresolvable dep.MinimumElement) | None -> for candidate in fetchCandidatesForConstraint sourceExplorer locations p c do match candidate with - | Result.Error (IntroducesConflict _) -> () - | Result.Error (Unsatisfiable d) -> - badDeps <- (badDeps |> Map.add d (Unsatisfiable d)) - yield Result.Error <| Unsatisfiable d + | Result.Error (Unresolvable d) -> + unresolvableCores <- (unresolvableCores |> Map.add (Set [d]) (Unresolvable d)) + yield Result.Error <| Unresolvable d | Result.Error (LimitReached d) -> if hadCandidate <> false then - badDeps <- (badDeps |> Map.add d (LimitReached d)) + underconstraintDeps <- (underconstraintDeps |> Set.add d) yield Result.Error <| LimitReached d | Result.Ok (_, (location, versions)) -> let! lock = sourceExplorer.LockLocation location let! manifest = sourceExplorer.FetchManifest (lock, versions) - let packageConstraints = manifest.Dependencies |> Set.map (fun d -> (d.Package, d.Constraint |> constraintToSet)) + let packageConstraints = + manifest.Dependencies + |> Set.map (fun d -> (d.Package, d.Constraint |> toDnf)) world <- (world |> Map.insertWith Set.union (p, cs) (Set [packageConstraints])) let conflicts = manifest.Dependencies - |> Seq.choose (fun d -> badDeps |> Map.tryFind (d.Package, constraintToSet d.Constraint)) - |> Seq.toList + |> Set.map toPackageConstraint + |> constraintsOf + |> Map.insertWith Set.union p cs + |> testIfHasBadCore + |> Seq.map TransitiveConflict + |> Set + - if conflicts.IsEmpty + if conflicts |> Set.isEmpty then hadCandidate <- true yield candidate else - () - //ield Result.Error (IntroducesConflict conflicts) - - if hadCandidate - then () - else () - //badDeps <- (badDeps |> Map.add (p, cs) (IntroducesConflict[])) - - + System.Console.WriteLine "foo" + yield Result.Error (Conflicts conflicts) + | _ -> () } let trackGlobal (constraints: Constraints) (candidates: AsyncSeq>) = asyncSeq { @@ -300,19 +292,18 @@ module Solver = let! manifest = sourceExplorer.FetchManifest (lock, versions) let conflicts = manifest.Dependencies - |> Seq.filter (fun d -> constraints |> Map.containsKey d.Package) - |> Seq.map (fun d -> (d.Package, constraintToSet d.Constraint |> Set.union constraints.[d.Package])) - |> Seq.choose (fun (p, _) -> - badDeps - |> Map.tryFindKey (fun (q, bs) _ -> p = q && constraints.[p] |> Set.isSubset bs) - |> Option.map (fun k -> badDeps.[k])) - |> Seq.toList - - if conflicts.IsEmpty + |> Seq.map toPackageConstraint + |> constraintsOf + |> testIfHasBadCore + |> Seq.map TransitiveConflict + |> Set + + if conflicts |> Set.isEmpty then yield candidate else - yield Result.Error (IntroducesConflict conflicts) + System.Console.WriteLine "bar" + yield Result.Error (Conflicts conflicts) () () @@ -323,51 +314,64 @@ module Solver = match req with | GetCandidates (constraints, dep, locations, channel) -> trackLocal locations dep + |> AsyncSeq.takeWhile (fun _ -> testIfHasBadCore constraints |> Seq.isEmpty) |> trackGlobal constraints - |> AsyncSeq.takeWhile (fun _ -> testIfBad dep |> Option.isNone) - |> AsyncSeq.takeWhile (fun _ -> testIfSelectionGood constraints) - |> AsyncSeq.takeWhile (fun _ -> testIfHasBadCore constraints |> not) |> channel.Reply - | MarkBadPath (path, failedDep, (p, bs), channel) -> - //System.Console.WriteLine ("Marking " + string failedDep + " because " + string (p, bs) ) - - let groups = - world.[failedDep] - |> Set.map(fun xs -> - xs - |> Set.filter(fun (q, _) -> p = q ) - |> Set.map(fun (_, cs) -> cs ) - |> Set.unionMany) - - for contribution in groups do - - let core = - path - |> Seq.choose(fun x -> - match x with - | Root m -> Some m.Dependencies - | Node (q, rv) -> - if q <> fst failedDep && p <> q - then - Some rv.Manifest.Dependencies - else None) - |> Seq.map (fun deps -> - deps - |> Seq.map (fun x -> (x.Package, x.Constraint |> constraintToSet |> (fun c -> Set.difference c contribution))) - |> Seq.filter (fun (q, cs) -> cs.IsEmpty |> not) - |> Seq.filter (fun (q, cs) -> p = q && Set.isProperSubset cs bs) // should be an intersection - |> Set + | MarkBadPath (path, failedDep, errors, channel) -> + - ) - |> Set.unionMany - |> Set.add failedDep + let rec compute error = - badCores <- badCores |> Set.add core - // System.Console.WriteLine "bad core: " - //System.Console.WriteLine core - // System.Console.WriteLine "-------" + match error with + | LimitReached _-> () // TODO + | Unresolvable (p, bs) -> + System.Console.WriteLine "unresolvable..." + if failedDep <> (p, bs) + then + let groups = + world.[failedDep] + |> Set.map(fun xs -> + xs + |> Set.filter(fun (q, _) -> p = q ) + |> Set.map(fun (_, cs) -> cs ) + |> Set.unionMany) + + System.Console.WriteLine "xxx" + for contribution in groups do + let core = + path + |> Seq.choose(fun x -> + match x with + | Root m -> Some m.Dependencies + | Node (q, rv) -> + if q <> fst failedDep && p <> q + then + Some rv.Manifest.Dependencies + else None) + |> Seq.map (fun deps -> + deps + |> Seq.map (fun x -> (x.Package, x.Constraint |> toDnf |> (fun c -> Set.difference c contribution))) + |> Seq.filter (fun (q, cs) -> cs.IsEmpty |> not) + |> Seq.filter (fun (q, cs) -> p = q && Set.isProperSubset cs bs) // should be an intersection? + |> Set) + |> Set.unionMany + |> Set.add failedDep + unresolvableCores <- unresolvableCores |> Map.add core (SearchStrategyError.Unresolvable (p, bs)) + else + unresolvableCores <- unresolvableCores |> Map.add (Set[(p, bs)]) (SearchStrategyError.Unresolvable (p, bs)) + | TransitiveConflict (core, next) -> + System.Console.WriteLine (string (core, next)) + compute next + | Conflicts cs -> + for c in cs do compute c + + for error in errors do + System.Console.WriteLine "errors" + compute error channel.Reply () + System.Console.WriteLine "done" + }) @@ -382,6 +386,7 @@ module Solver = |> Map.valueList |> Seq.map (fun m -> m.Manifest.Dependencies) |> Seq.append [state.Root] + |> Seq.map (Set.map toPackageConstraint) |> Set.unionMany |> constraintsOf @@ -432,11 +437,10 @@ module Solver = let fetched = candidates - |> AsyncSeq.chooseAsync(fun candidate -> async { + |> AsyncSeq.mapAsync(fun candidate -> async { match candidate with | Result.Error e -> - //System.Console.WriteLine e - return None + return Result.Error e | Result.Ok (_, (location, versions)) -> let! lock = sourceExplorer.LockLocation location let! manifest = sourceExplorer.FetchManifest (lock, versions) @@ -445,57 +449,33 @@ module Solver = Versions = versions Manifest = manifest } - return Some {state with Selections = state.Selections |> Map.add p resolvedVersion}}) - |> AsyncSeq.distinctUntilChangedWith (fun prev next -> - prev.Selections.[p].Manifest = next.Selections.[p].Manifest - ) + return Result.Ok {state with Selections = state.Selections |> Map.add p resolvedVersion}}) + |> AsyncSeq.distinctUntilChangedWith (fun prev next -> + match prev, next with + | (Result.Ok prevS), (Result.Ok nextS) -> + prevS.Selections.[p].Manifest = nextS.Selections.[p].Manifest + | (_, _) -> prev = next) - for nextState in AsyncSeq.append hints fetched do + + for nextState in AsyncSeq.append hints (fetched |> AsyncSeq.choose (fun x -> match x with | Result.Ok v -> Some v | _ -> None)) do let node = Node (p, nextState.Selections.[p]) let visited = path |> List.contains node if visited <> true then yield! step context resolver nextState (node :: path) - - let! error = + let errors = candidates |> AsyncSeq.choose (fun candidate -> match candidate with - | Result.Error (IntroducesConflict [Unsatisfiable (p, cs)]) -> - //System.Console.WriteLine "####################################################################" - Some (p, cs) + | Result.Error e -> + Some e | _ -> None) - |> AsyncSeq.tryFirst - - match error with - | Some transitiveFailure -> - () - do! resolver.PostAndAsyncReply (fun ch -> MarkBadPath (path, (p, cs), transitiveFailure, ch)) - - constraints - |> Map.toSeq - |> Seq.map(fun x -> System.Console.WriteLine x) - |> Seq.toList - |> ignore - - - | None -> () - - + |> AsyncSeq.toBlockingSeq + |> Set - // System.Console.WriteLine (unresolved |> List.map (fun (p, cs) -> string p + (string cs) ) |> String.concat "\n") + do! resolver.PostAndAsyncReply (fun ch -> MarkBadPath (path, (p, cs), errors, ch)) - // System.Console.WriteLine ( - // path - // |> List.map( - // fun x -> - // match x with - // | Root _ -> "Root" - // | Node (p, r) -> (string p + "@" + string r.Versions)) - // |> String.concat "\n" - // ) - // () } let solutionCollector resolutions = From 935b5b895bdc6bebf90affe9e22ac6731b6b0042 Mon Sep 17 00:00:00 2001 From: Gaetano Checinski Date: Fri, 8 Mar 2019 10:05:01 +0000 Subject: [PATCH 08/25] feat: clause equivalence learning implemented --- buckaroo/Solver.fs | 198 +++++++++++++++++++++++++++------------------ 1 file changed, 120 insertions(+), 78 deletions(-) diff --git a/buckaroo/Solver.fs b/buckaroo/Solver.fs index bb5c3cf..e310050 100644 --- a/buckaroo/Solver.fs +++ b/buckaroo/Solver.fs @@ -20,7 +20,7 @@ module Solver = type ResolutionPath = | Root of Manifest - | Node of PackageIdentifier * ResolvedVersion + | Node of PackageIdentifier * Set * ResolvedVersion type SolverState = { Locations : Map @@ -41,7 +41,7 @@ module Solver = | Conflicts of Set type ResolutionRequest = - | MarkBadPath of List * PackageConstraint * Set * AsyncReplyChannel + | MarkBadPath of List * PackageConstraint * SearchStrategyError * AsyncReplyChannel | GetCandidates of Constraints * PackageConstraint * PackageSources * AsyncReplyChannel>> type SearchStrategy = ISourceExplorer -> SolverState -> AsyncSeq> @@ -240,18 +240,30 @@ module Solver = match conflicts with | Some (dep, _) -> - System.Console.WriteLine (string (p, cs)) yield Result.Error (Unresolvable dep.MinimumElement) | None -> for candidate in fetchCandidatesForConstraint sourceExplorer locations p c do match candidate with | Result.Error (Unresolvable d) -> unresolvableCores <- (unresolvableCores |> Map.add (Set [d]) (Unresolvable d)) + + System.Console.WriteLine "----------" + for cores in unresolvableCores |> Map.keySet do + cores |> Set |> System.Console.WriteLine + System.Console.WriteLine "&&&&&" + System.Console.WriteLine "----------" + yield Result.Error <| Unresolvable d | Result.Error (LimitReached d) -> if hadCandidate <> false then underconstraintDeps <- (underconstraintDeps |> Set.add d) + System.Console.WriteLine "----------" + for cores in unresolvableCores |> Map.keySet do + cores |> Set |> System.Console.WriteLine + System.Console.WriteLine "&&&&&" + System.Console.WriteLine "----------" + yield Result.Error <| LimitReached d | Result.Ok (_, (location, versions)) -> let! lock = sourceExplorer.LockLocation location @@ -277,7 +289,6 @@ module Solver = hadCandidate <- true yield candidate else - System.Console.WriteLine "foo" yield Result.Error (Conflicts conflicts) | _ -> () } @@ -293,6 +304,7 @@ module Solver = let conflicts = manifest.Dependencies |> Seq.map toPackageConstraint + |> Seq.append (constraints |> Map.toSeq) |> constraintsOf |> testIfHasBadCore |> Seq.map TransitiveConflict @@ -302,81 +314,86 @@ module Solver = then yield candidate else - System.Console.WriteLine "bar" yield Result.Error (Conflicts conflicts) () () } + let depsFromPath p = + match p with + | Root m -> m.Dependencies + | Node (_, _, rv) -> rv.Manifest.Dependencies + + while true do let! req = inbox.Receive() match req with | GetCandidates (constraints, dep, locations, channel) -> trackLocal locations dep - |> AsyncSeq.takeWhile (fun _ -> testIfHasBadCore constraints |> Seq.isEmpty) + |> AsyncSeq.takeWhile(fun e -> + match e with + | _ -> testIfHasBadCore constraints |> Seq.isEmpty) |> trackGlobal constraints |> channel.Reply - | MarkBadPath (path, failedDep, errors, channel) -> - - - let rec compute error = - + | MarkBadPath (path, failedDep, error, channel) -> match error with - | LimitReached _-> () // TODO - | Unresolvable (p, bs) -> - System.Console.WriteLine "unresolvable..." - - if failedDep <> (p, bs) - then - let groups = - world.[failedDep] - |> Set.map(fun xs -> - xs - |> Set.filter(fun (q, _) -> p = q ) - |> Set.map(fun (_, cs) -> cs ) - |> Set.unionMany) - - System.Console.WriteLine "xxx" - for contribution in groups do - let core = - path - |> Seq.choose(fun x -> - match x with - | Root m -> Some m.Dependencies - | Node (q, rv) -> - if q <> fst failedDep && p <> q - then - Some rv.Manifest.Dependencies - else None) - |> Seq.map (fun deps -> + | Conflicts conflicts -> + //System.Console.WriteLine error + + for (failedCore, p, bs) in conflicts + |> Seq.choose(fun x -> + match x with + | TransitiveConflict (failedCore , Unresolvable (p, cs)) -> Some (failedCore, p, cs) + | _ -> None) do + + let contributions = + match world |> Map.tryFind failedDep with + | None -> + Set.empty + | Some buckets -> + //System.Console.WriteLine failedDep + buckets + |> Set.map(fun deps -> deps - |> Seq.map (fun x -> (x.Package, x.Constraint |> toDnf |> (fun c -> Set.difference c contribution))) - |> Seq.filter (fun (q, cs) -> cs.IsEmpty |> not) - |> Seq.filter (fun (q, cs) -> p = q && Set.isProperSubset cs bs) // should be an intersection? - |> Set) - |> Set.unionMany - |> Set.add failedDep - unresolvableCores <- unresolvableCores |> Map.add core (SearchStrategyError.Unresolvable (p, bs)) - else - unresolvableCores <- unresolvableCores |> Map.add (Set[(p, bs)]) (SearchStrategyError.Unresolvable (p, bs)) - | TransitiveConflict (core, next) -> - System.Console.WriteLine (string (core, next)) - compute next - | Conflicts cs -> - for c in cs do compute c - - for error in errors do - System.Console.WriteLine "errors" - compute error - channel.Reply () - System.Console.WriteLine "done" + |> Seq.filter (fun (q, _) -> p = q) + |> Seq.map (fun (_, cs) -> cs) + |> Set.unionMany) + + + for contrib in contributions do + let core = + path + |> Seq.filter (fun x -> + match x with + | Node (q, _, _) -> p <> q + | _ -> true) + |> Seq.map depsFromPath + |> Seq.map (fun deps -> + deps + |> Seq.map (fun x -> (x.Package, x.Constraint |> toDnf)) + |> Seq.filter (fun (q, cs) -> p = q && cs <> contrib) + |> Seq.filter (fun (_, cs) -> Set.isProperSubset cs bs) // should be an intersection? + |> Seq.map (fun (q, cs) -> (q, Set.difference cs contrib)) + |> Seq.filter (fun (_, cs) -> cs.IsEmpty |> not) + |> Set) + |> Set.unionMany + |> Set.add failedDep + + unresolvableCores <- unresolvableCores |> Map.add core (SearchStrategyError.Unresolvable (p, bs)) + System.Console.WriteLine "----------" + for cores in unresolvableCores |> Map.keySet do + cores |> Set |> System.Console.WriteLine + System.Console.WriteLine "&&&&&" + System.Console.WriteLine "----------" + | _ -> () + channel.Reply () }) - let rec private step (context : TaskContext) (resolver : MailboxProcessor) (state : SolverState) (path: List): AsyncSeq = asyncSeq { + let rec private step (context : TaskContext) (resolver : MailboxProcessor) (state : SolverState) (path: List): AsyncSeq> = asyncSeq { let sourceExplorer = context.SourceExplorer let log = namespacedLogger context.Console ("solver") @@ -403,11 +420,11 @@ module Solver = |> Seq.fold Seq.append (state.Locations |> Map.toSeq) |> Map.ofSeq - let unresolved = depthFirst selections state.Root |> Seq.toList + let unresolved = breathFirst selections state.Root |> Seq.toList if (unresolved |> Seq.isEmpty) then - yield state + yield Result.Ok state else for (p, cs) in unresolved do let c = cs |> All @@ -433,10 +450,9 @@ module Solver = let! requested = resolver.PostAndAsyncReply (fun channel -> GetCandidates (constraints, (p, cs), locations, channel)) - let candidates = requested |> AsyncSeq.cache let fetched = - candidates + requested |> AsyncSeq.mapAsync(fun candidate -> async { match candidate with | Result.Error e -> @@ -455,26 +471,47 @@ module Solver = | (Result.Ok prevS), (Result.Ok nextS) -> prevS.Selections.[p].Manifest = nextS.Selections.[p].Manifest | (_, _) -> prev = next) + |> AsyncSeq.cache - for nextState in AsyncSeq.append hints (fetched |> AsyncSeq.choose (fun x -> match x with | Result.Ok v -> Some v | _ -> None)) do - let node = Node (p, nextState.Selections.[p]) - let visited = path |> List.contains node - if visited <> true - then - yield! step context resolver nextState (node :: path) + let results = + fetched + |> AsyncSeq.choose (fun x -> match x with | Result.Ok v -> Some v | _ -> None) + |> AsyncSeq.append hints + |> AsyncSeq.collect (fun nextState -> + let node = Node (p, cs , nextState.Selections.[p]) + let visited = path |> List.contains node + if visited <> true + then + step context resolver nextState (node :: path) + else AsyncSeq.empty) + + let solutions = + results + |> AsyncSeq.choose(fun x -> + match x with + | Result.Ok _ -> Some x + | _ -> None) + let errors = - candidates - |> AsyncSeq.choose (fun candidate -> - match candidate with - | Result.Error e -> - Some e + fetched + |> AsyncSeq.choose(fun x -> + match x with + | Result.Error e -> Some e | _ -> None) - |> AsyncSeq.toBlockingSeq - |> Set - - do! resolver.PostAndAsyncReply (fun ch -> MarkBadPath (path, (p, cs), errors, ch)) + |> AsyncSeq.distinctUntilChanged + + let! solution = solutions |> AsyncSeq.tryFirst + match solution with + | Some s -> + yield s + yield! solutions + | None -> + for error in errors do + do! resolver.PostAndAsyncReply (fun ch -> MarkBadPath (path, (p, cs), error, ch)) + yield Result.Error error + () } @@ -518,6 +555,11 @@ module Solver = let result = resolutions + |> AsyncSeq.choose (fun s -> + match s with + | Result.Ok s -> Some s + | _ -> None + ) |> AsyncSeq.map (fun s -> Resolution.Ok <| {Resolutions = s.Selections |> Map.map(fun k v -> (v, Solution.empty))} ) From 41b9dc27d418e0647649568d19198d5c58eb1d1a Mon Sep 17 00:00:00 2001 From: Gaetano Checinski Date: Fri, 8 Mar 2019 15:40:14 +0000 Subject: [PATCH 09/25] chore: refactoring --- buckaroo/Solver.fs | 210 ++++++++++++++++++++++----------------------- 1 file changed, 103 insertions(+), 107 deletions(-) diff --git a/buckaroo/Solver.fs b/buckaroo/Solver.fs index e310050..b951a17 100644 --- a/buckaroo/Solver.fs +++ b/buckaroo/Solver.fs @@ -14,7 +14,7 @@ module Solver = [] let MaxConsecutiveFailures = 10 - type LocatedAtom = Atom * PackageLocation + type LocatedAtom = Atom * PackageLock type Constraints = Map> @@ -31,7 +31,6 @@ module Solver = type PackageConstraint = PackageIdentifier * Set - type LocatedVersionSet = PackageLocation * Set type SearchStrategyError = @@ -39,6 +38,7 @@ module Solver = | Unresolvable of PackageConstraint | TransitiveConflict of Set * SearchStrategyError | Conflicts of Set + | NoManifest type ResolutionRequest = | MarkBadPath of List * PackageConstraint * SearchStrategyError * AsyncReplyChannel @@ -209,12 +209,12 @@ module Solver = } - let resolutionManger (sourceExplorer : ISourceExplorer) : MailboxProcessor = MailboxProcessor.Start(fun inbox -> async { + let resolutionManager (sourceExplorer : ISourceExplorer) : MailboxProcessor = MailboxProcessor.Start(fun inbox -> async { let mutable unresolvableCores : Map, SearchStrategyError> = Map.empty let mutable underconstraintDeps : Set = Set.empty let mutable world : Map>> = Map.empty - let testIfHasBadCore (constraints : Constraints) = + let findBadCores (constraints : Constraints) = let deps = constraints |> Map.toSeq @@ -231,12 +231,18 @@ module Solver = |> Option.defaultValue false )) + let printCores () = + System.Console.WriteLine "----------" + for cores in unresolvableCores |> Map.keySet do + cores |> Set |> System.Console.WriteLine + System.Console.WriteLine "&&&&&" + System.Console.WriteLine "----------" let trackLocal locations (p, cs) = asyncSeq { let mutable hadCandidate = false let c = cs |> All |> Constraint.simplify - let conflicts = testIfHasBadCore (Map.ofSeq [(p, cs)]) |> Seq.tryHead + let conflicts = findBadCores (Map.ofSeq [(p, cs)]) |> Seq.tryHead match conflicts with | Some (dep, _) -> @@ -246,23 +252,13 @@ module Solver = match candidate with | Result.Error (Unresolvable d) -> unresolvableCores <- (unresolvableCores |> Map.add (Set [d]) (Unresolvable d)) - - System.Console.WriteLine "----------" - for cores in unresolvableCores |> Map.keySet do - cores |> Set |> System.Console.WriteLine - System.Console.WriteLine "&&&&&" - System.Console.WriteLine "----------" - + printCores() yield Result.Error <| Unresolvable d | Result.Error (LimitReached d) -> if hadCandidate <> false then underconstraintDeps <- (underconstraintDeps |> Set.add d) - System.Console.WriteLine "----------" - for cores in unresolvableCores |> Map.keySet do - cores |> Set |> System.Console.WriteLine - System.Console.WriteLine "&&&&&" - System.Console.WriteLine "----------" + printCores() yield Result.Error <| LimitReached d | Result.Ok (_, (location, versions)) -> @@ -279,7 +275,7 @@ module Solver = |> Set.map toPackageConstraint |> constraintsOf |> Map.insertWith Set.union p cs - |> testIfHasBadCore + |> findBadCores |> Seq.map TransitiveConflict |> Set @@ -306,7 +302,7 @@ module Solver = |> Seq.map toPackageConstraint |> Seq.append (constraints |> Map.toSeq) |> constraintsOf - |> testIfHasBadCore + |> findBadCores |> Seq.map TransitiveConflict |> Set @@ -316,7 +312,6 @@ module Solver = else yield Result.Error (Conflicts conflicts) () - () } @@ -333,15 +328,13 @@ module Solver = trackLocal locations dep |> AsyncSeq.takeWhile(fun e -> match e with - | _ -> testIfHasBadCore constraints |> Seq.isEmpty) + | _ -> findBadCores constraints |> Seq.isEmpty) |> trackGlobal constraints |> channel.Reply | MarkBadPath (path, failedDep, error, channel) -> match error with | Conflicts conflicts -> - //System.Console.WriteLine error - - for (failedCore, p, bs) in conflicts + for (_, p, bs) in conflicts |> Seq.choose(fun x -> match x with | TransitiveConflict (failedCore , Unresolvable (p, cs)) -> Some (failedCore, p, cs) @@ -352,7 +345,6 @@ module Solver = | None -> Set.empty | Some buckets -> - //System.Console.WriteLine failedDep buckets |> Set.map(fun deps -> deps @@ -381,44 +373,91 @@ module Solver = |> Set.add failedDep unresolvableCores <- unresolvableCores |> Map.add core (SearchStrategyError.Unresolvable (p, bs)) - System.Console.WriteLine "----------" - for cores in unresolvableCores |> Map.keySet do - cores |> Set |> System.Console.WriteLine - System.Console.WriteLine "&&&&&" - System.Console.WriteLine "----------" + printCores() | _ -> () channel.Reply () }) + let getHints (sourceExplorer : ISourceExplorer) state p cs = + let c = cs |> All + state.Hints + |> Map.tryFind p + |> Option.defaultValue([]) + |> Seq.filter(fun (atom, _) -> atom.Versions |> Constraint.satisfies c) + |> AsyncSeq.ofSeq + |> AsyncSeq.mapAsync(fun (atom, lock) -> async { + try + let! manifest = sourceExplorer.FetchManifest (lock, atom.Versions) + let resolvedVersion = { + Lock = lock + Versions = atom.Versions + Manifest = manifest + } + return Result.Ok {state with Selections = state.Selections |> Map.add p resolvedVersion} + with _ -> return Result.Error NoManifest + }) + |> AsyncSeq.filter (fun x -> + match x with + | Result.Error NoManifest -> false + | _ -> true) + + let getCandidates (resolver: MailboxProcessor) (sourceExplorer: ISourceExplorer) state selections p cs = asyncSeq { + + let constraints = + selections + |> Map.valueList + |> Seq.map (fun m -> m.Manifest.Dependencies) + |> Seq.append [state.Root] + |> Seq.map (Set.map toPackageConstraint) + |> Set.unionMany + |> constraintsOf + + let manifests = + selections + |> Map.valueList + |> Seq.map (fun rv -> rv.Manifest) + |> Seq.toList + + let locations = + manifests + |> Seq.map (fun m -> m.Locations |> Map.toSeq) + |> Seq.fold Seq.append (state.Locations |> Map.toSeq) + |> Map.ofSeq + + + let! requested = + resolver.PostAndAsyncReply (fun channel -> GetCandidates (constraints, (p, cs), locations, channel)) + + yield! requested + |> AsyncSeq.mapAsync(fun candidate -> async { + match candidate with + | Result.Error e -> + return Result.Error e + | Result.Ok (_, (location, versions)) -> + let! lock = sourceExplorer.LockLocation location + let! manifest = sourceExplorer.FetchManifest (lock, versions) + let resolvedVersion = { + Lock = lock + Versions = versions + Manifest = manifest + } + + return Result.Ok {state with Selections = state.Selections |> Map.add p resolvedVersion}}) + |> AsyncSeq.distinctUntilChangedWith (fun prev next -> + match prev, next with + | (Result.Ok prevS), (Result.Ok nextS) -> + prevS.Selections.[p].Manifest = nextS.Selections.[p].Manifest + | (_, _) -> prev = next) + } + let rec private step (context : TaskContext) (resolver : MailboxProcessor) (state : SolverState) (path: List): AsyncSeq> = asyncSeq { let sourceExplorer = context.SourceExplorer let log = namespacedLogger context.Console ("solver") let selections = pruneSelections state.Selections state.Root - let constraints = - selections - |> Map.valueList - |> Seq.map (fun m -> m.Manifest.Dependencies) - |> Seq.append [state.Root] - |> Seq.map (Set.map toPackageConstraint) - |> Set.unionMany - |> constraintsOf - - - let manifests = - selections - |> Map.valueList - |> Seq.map (fun rv -> rv.Manifest) - |> Seq.toList - - let locations = - manifests - |> Seq.map (fun m -> m.Locations |> Map.toSeq) - |> Seq.fold Seq.append (state.Locations |> Map.toSeq) - |> Map.ofSeq let unresolved = breathFirst selections state.Root |> Seq.toList @@ -426,58 +465,17 @@ module Solver = then yield Result.Ok state else - for (p, cs) in unresolved do - let c = cs |> All - - let hints = - state.Hints - |> Map.tryFind p - |> Option.defaultValue([]) - |> Seq.filter(fun (atom, _) -> atom.Versions |> Constraint.satisfies c) - |> AsyncSeq.ofSeq - |> AsyncSeq.chooseAsync(fun (atom, location) -> async { - try - let! lock = sourceExplorer.LockLocation location - let! manifest = sourceExplorer.FetchManifest (lock, atom.Versions) - let resolvedVersion = { - Lock = lock - Versions = atom.Versions - Manifest = manifest - } - return Some {state with Selections = state.Selections |> Map.add p resolvedVersion} - with _ -> return None - }) - let! requested = - resolver.PostAndAsyncReply (fun channel -> GetCandidates (constraints, (p, cs), locations, channel)) - - let fetched = - requested - |> AsyncSeq.mapAsync(fun candidate -> async { - match candidate with - | Result.Error e -> - return Result.Error e - | Result.Ok (_, (location, versions)) -> - let! lock = sourceExplorer.LockLocation location - let! manifest = sourceExplorer.FetchManifest (lock, versions) - let resolvedVersion = { - Lock = lock - Versions = versions - Manifest = manifest - } - return Result.Ok {state with Selections = state.Selections |> Map.add p resolvedVersion}}) - |> AsyncSeq.distinctUntilChangedWith (fun prev next -> - match prev, next with - | (Result.Ok prevS), (Result.Ok nextS) -> - prevS.Selections.[p].Manifest = nextS.Selections.[p].Manifest - | (_, _) -> prev = next) + for (p, cs) in unresolved do + let candidates = + AsyncSeq.append + (getHints sourceExplorer state p cs) + (getCandidates resolver sourceExplorer state selections p cs) |> AsyncSeq.cache - let results = - fetched + candidates |> AsyncSeq.choose (fun x -> match x with | Result.Ok v -> Some v | _ -> None) - |> AsyncSeq.append hints |> AsyncSeq.collect (fun nextState -> let node = Node (p, cs , nextState.Selections.[p]) let visited = path |> List.contains node @@ -493,9 +491,8 @@ module Solver = | Result.Ok _ -> Some x | _ -> None) - let errors = - fetched + candidates |> AsyncSeq.choose(fun x -> match x with | Result.Error e -> Some e @@ -512,7 +509,6 @@ module Solver = do! resolver.PostAndAsyncReply (fun ch -> MarkBadPath (path, (p, cs), error, ch)) yield Result.Error error () - } let solutionCollector resolutions = @@ -533,11 +529,11 @@ module Solver = |> List.tryHead let solve (context : TaskContext) (partialSolution : Solution) (manifest : Manifest) (style : ResolutionStyle) (lock : Lock option) = async { - let hints = Map.empty - // lock - // |> Option.map (fun l -> - // l.Packages |> Map.map (fun p v -> [({Package = p; Versions = v.Versions}, v.Location)] ) ) - // |> Option.defaultValue Map.empty + let hints = + lock + |> Option.map (fun l -> + l.Packages |> Map.map (fun p v -> [({Package = p; Versions = v.Versions}, v.Location)] ) ) + |> Option.defaultValue Map.empty let state = { Root = Set.union @@ -548,7 +544,7 @@ module Solver = Locations = manifest.Locations } - let resolver = resolutionManger context.SourceExplorer + let resolver = resolutionManager context.SourceExplorer let resolutions = step context resolver state [Root manifest] From a240779218d55376e0b8d4b887c8ac390fba7501 Mon Sep 17 00:00:00 2001 From: Gaetano Checinski Date: Fri, 8 Mar 2019 17:55:45 +0000 Subject: [PATCH 10/25] chore: re-introduces private deps --- buckaroo/Solver.fs | 76 +++++++++++++++++++++++++++++++--------------- 1 file changed, 52 insertions(+), 24 deletions(-) diff --git a/buckaroo/Solver.fs b/buckaroo/Solver.fs index b951a17..0b5d986 100644 --- a/buckaroo/Solver.fs +++ b/buckaroo/Solver.fs @@ -26,7 +26,7 @@ module Solver = Locations : Map Root : Set Hints: Map> - Selections : Map + Selections : Map } type PackageConstraint = PackageIdentifier * Set @@ -39,6 +39,7 @@ module Solver = | TransitiveConflict of Set * SearchStrategyError | Conflicts of Set | NoManifest + | NoPrivateSolution type ResolutionRequest = | MarkBadPath of List * PackageConstraint * SearchStrategyError * AsyncReplyChannel @@ -69,7 +70,7 @@ module Solver = |> constraintsOf - let pruneSelections (selections: Map) (deps: Set) = + let pruneSelections (selections: Map) (deps: Set) = let rec loop (visited: Set) (deps: Set) : seq = seq { let notVisited = @@ -85,12 +86,12 @@ module Solver = yield! notVisited |> Seq.filter (fun d -> selections |> Map.containsKey d.Package) - |> Seq.map (fun d -> (d.Package, selections.[d.Package])) + |> Seq.map (fun d -> (d.Package, fst selections.[d.Package])) let next = notVisited |> Seq.choose (fun d -> selections |> Map.tryFind d.Package) - |> Seq.fold (fun deps m -> Set.union m.Manifest.Dependencies deps) Set.empty + |> Seq.fold (fun deps (rv, _) -> Set.union rv.Manifest.Dependencies deps) Set.empty yield! loop nextVisited next } @@ -395,8 +396,9 @@ module Solver = Versions = atom.Versions Manifest = manifest } - return Result.Ok {state with Selections = state.Selections |> Map.add p resolvedVersion} - with _ -> return Result.Error NoManifest + return Result.Ok resolvedVersion + with _ -> + return Result.Error NoManifest }) |> AsyncSeq.filter (fun x -> match x with @@ -444,16 +446,16 @@ module Solver = Manifest = manifest } - return Result.Ok {state with Selections = state.Selections |> Map.add p resolvedVersion}}) + return Result.Ok resolvedVersion + }) |> AsyncSeq.distinctUntilChangedWith (fun prev next -> match prev, next with - | (Result.Ok prevS), (Result.Ok nextS) -> - prevS.Selections.[p].Manifest = nextS.Selections.[p].Manifest + | (Result.Ok p), (Result.Ok n) -> + p.Manifest = n.Manifest | (_, _) -> prev = next) } - - let rec private step (context : TaskContext) (resolver : MailboxProcessor) (state : SolverState) (path: List): AsyncSeq> = asyncSeq { + let rec private step (context : TaskContext) (resolver : MailboxProcessor) (state : SolverState) (path: List): AsyncSeq> = asyncSeq { let sourceExplorer = context.SourceExplorer let log = namespacedLogger context.Console ("solver") @@ -463,7 +465,7 @@ module Solver = if (unresolved |> Seq.isEmpty) then - yield Result.Ok state + yield Result.Ok {Resolutions = state.Selections} else for (p, cs) in unresolved do @@ -476,23 +478,48 @@ module Solver = let results = candidates |> AsyncSeq.choose (fun x -> match x with | Result.Ok v -> Some v | _ -> None) - |> AsyncSeq.collect (fun nextState -> - let node = Node (p, cs , nextState.Selections.[p]) - let visited = path |> List.contains node - if visited <> true - then - step context resolver nextState (node :: path) - else AsyncSeq.empty) + |> AsyncSeq.filter(fun rv -> + let node = Node (p, cs, rv) + path |> List.contains node |> not) + |> AsyncSeq.mapAsync (fun rv -> async { + let m = rv.Manifest + let privateState : SolverState = { + Hints = state.Hints + Root = m.PrivateDependencies + Locations = state.Locations + Selections = Map.empty + } + + let! privateSolution = + (step context resolver privateState [Root m]) + |> AsyncSeq.choose(fun x -> + match x with + | Result.Ok x -> Some x + | _ -> None) + |> AsyncSeq.tryFirst + + return + match privateSolution with + | Some ps -> + let nextState = { + state with + Selections = state.Selections |> Map.add p (rv, ps) + } + let node = Node (p, cs, rv) + Result.Ok <| step context resolver nextState (node :: path) + | None -> Result.Error NoPrivateSolution + }) let solutions = results - |> AsyncSeq.choose(fun x -> + |> AsyncSeq.collect(fun x -> match x with - | Result.Ok _ -> Some x - | _ -> None) + | Result.Ok next -> next + | _ -> AsyncSeq.empty + ) let errors = - candidates + results |> AsyncSeq.choose(fun x -> match x with | Result.Error e -> Some e @@ -506,6 +533,7 @@ module Solver = yield! solutions | None -> for error in errors do + System.Console.WriteLine error do! resolver.PostAndAsyncReply (fun ch -> MarkBadPath (path, (p, cs), error, ch)) yield Result.Error error () @@ -557,7 +585,7 @@ module Solver = | _ -> None ) |> AsyncSeq.map (fun s -> - Resolution.Ok <| {Resolutions = s.Selections |> Map.map(fun k v -> (v, Solution.empty))} + Resolution.Ok s ) |> solutionCollector |> Option.defaultValue (Set.empty |> Resolution.Conflict) From 54d0fed9673f59958ef69bee8d5d723d3358bba3 Mon Sep 17 00:00:00 2001 From: Gaetano Checinski Date: Fri, 8 Mar 2019 18:36:13 +0000 Subject: [PATCH 11/25] chore: more cleanup --- buckaroo/Solver.fs | 36 +++++++++++++++--------------------- 1 file changed, 15 insertions(+), 21 deletions(-) diff --git a/buckaroo/Solver.fs b/buckaroo/Solver.fs index 0b5d986..015d9b0 100644 --- a/buckaroo/Solver.fs +++ b/buckaroo/Solver.fs @@ -47,7 +47,6 @@ module Solver = type SearchStrategy = ISourceExplorer -> SolverState -> AsyncSeq> - let toDnf c = match c with | All xs -> xs @@ -71,7 +70,6 @@ module Solver = let pruneSelections (selections: Map) (deps: Set) = - let rec loop (visited: Set) (deps: Set) : seq = seq { let notVisited = deps @@ -318,7 +316,7 @@ module Solver = let depsFromPath p = match p with - | Root m -> m.Dependencies + | Root m -> Set.union m.Dependencies m.PrivateDependencies | Node (_, _, rv) -> rv.Manifest.Dependencies @@ -353,7 +351,6 @@ module Solver = |> Seq.map (fun (_, cs) -> cs) |> Set.unionMany) - for contrib in contributions do let core = path @@ -473,7 +470,6 @@ module Solver = AsyncSeq.append (getHints sourceExplorer state p cs) (getCandidates resolver sourceExplorer state selections p cs) - |> AsyncSeq.cache let results = candidates @@ -507,15 +503,23 @@ module Solver = } let node = Node (p, cs, rv) Result.Ok <| step context resolver nextState (node :: path) - | None -> Result.Error NoPrivateSolution + | None -> Result.Error NoPrivateSolution // TODO: propagate error }) + |> AsyncSeq.collect(fun x -> + match x with + | Result.Ok next -> next + | Result.Error e -> AsyncSeq.ofSeq [Result.Error e] + ) + |> AsyncSeq.cache + + yield! results let solutions = results - |> AsyncSeq.collect(fun x -> + |> AsyncSeq.choose(fun x -> match x with - | Result.Ok next -> next - | _ -> AsyncSeq.empty + | Result.Ok s -> Some s + | _ -> None ) let errors = @@ -528,28 +532,19 @@ module Solver = let! solution = solutions |> AsyncSeq.tryFirst match solution with - | Some s -> - yield s - yield! solutions + | Some _ -> () | None -> for error in errors do - System.Console.WriteLine error do! resolver.PostAndAsyncReply (fun ch -> MarkBadPath (path, (p, cs), error, ch)) - yield Result.Error error () } let solutionCollector resolutions = resolutions |> AsyncSeq.take (1024) - |> AsyncSeq.takeWhileInclusive (fun x -> - match x with - | Backtrack _ -> false - | _ -> true) |> AsyncSeq.filter (fun x -> match x with | Ok _ -> true - | Backtrack _ -> true | _ -> false) |> AsyncSeq.take 1 |> AsyncSeq.toListAsync @@ -560,7 +555,7 @@ module Solver = let hints = lock |> Option.map (fun l -> - l.Packages |> Map.map (fun p v -> [({Package = p; Versions = v.Versions}, v.Location)] ) ) + l.Packages |> Map.map (fun p v -> [({Package = p; Versions = v.Versions}, v.Location)])) |> Option.defaultValue Map.empty let state = { @@ -595,7 +590,6 @@ module Solver = return result } - let rec fromLock (sourceExplorer : ISourceExplorer) (lock : Lock) : Async = async { let rec packageLockToSolution (locked : LockedPackage) : Async = async { let! manifest = sourceExplorer.FetchManifest (locked.Location, locked.Versions) From 5bd9b01fca879d0b26378ecaaa47d0f32a477ef6 Mon Sep 17 00:00:00 2001 From: Gaetano Checinski Date: Sat, 9 Mar 2019 22:38:14 +0000 Subject: [PATCH 12/25] chore: more cleanup --- buckaroo/GitManager.fs | 26 ++--- buckaroo/Solver.fs | 257 ++++++++++++++++++++++++++--------------- 2 files changed, 175 insertions(+), 108 deletions(-) diff --git a/buckaroo/GitManager.fs b/buckaroo/GitManager.fs index c5dd18a..02ce0c9 100644 --- a/buckaroo/GitManager.fs +++ b/buckaroo/GitManager.fs @@ -128,22 +128,22 @@ type GitManager (console : ConsoleManager, git : IGit, cacheDirectory : string) let cacheDir = cloneFolderName url let startTime = System.DateTime.Now let! refs = - // Async.Parallel - // ( - // (git.RemoteRefs url - // |> Async.Catch - // |> Async.map(Choice.toOption >> Option.defaultValue([]))), + Async.Parallel + ( + (git.RemoteRefs url + |> Async.Catch + |> Async.map(Choice.toOption >> Option.defaultValue([]))), (git.RemoteRefs cacheDir |> Async.Catch |> Async.map(Choice.toOption >> Option.defaultValue([]))) - // ) - // |> Async.map(fun (a, b) -> - // if a.Length = 0 && b.Length = 0 then - // raise <| new SystemException("No internet connection and the cache is empty") - // else if a.Length > 0 - // then a - // else b - // ) + ) + |> Async.map(fun (a, b) -> + if a.Length = 0 && b.Length = 0 then + raise <| new SystemException("No internet connection and the cache is empty") + else if a.Length > 0 + then a + else b + ) refsCache <- refsCache |> Map.add url refs let endTime = System.DateTime.Now log((success "success ") + diff --git a/buckaroo/Solver.fs b/buckaroo/Solver.fs index 015d9b0..33a4aea 100644 --- a/buckaroo/Solver.fs +++ b/buckaroo/Solver.fs @@ -5,6 +5,7 @@ open Buckaroo.Tasks open Buckaroo.Console open RichOutput open FSharp.Control +open Buckaroo.Constraint module Solver = @@ -25,8 +26,8 @@ module Solver = type SolverState = { Locations : Map Root : Set - Hints: Map> Selections : Map + Hints : Map> } type PackageConstraint = PackageIdentifier * Set @@ -70,7 +71,7 @@ module Solver = let pruneSelections (selections: Map) (deps: Set) = - let rec loop (visited: Set) (deps: Set) : seq = seq { + let rec loop (visited: Set) (deps: Set) : seq = seq { let notVisited = deps |> Seq.filter (fun d -> visited |> Set.contains d.Package |> not) @@ -84,7 +85,7 @@ module Solver = yield! notVisited |> Seq.filter (fun d -> selections |> Map.containsKey d.Package) - |> Seq.map (fun d -> (d.Package, fst selections.[d.Package])) + |> Seq.map (fun d -> (d.Package, selections.[d.Package])) let next = notVisited @@ -96,16 +97,18 @@ module Solver = loop Set.empty deps |> Map.ofSeq - let isUnresolved (selections : Map) (constraints : Map>) (dep : Dependency) = + let isUnresolved (selections : Map) (constraints : Map>) (dep : Dependency) = let c = constraints.[dep.Package] |> All |> Constraint.simplify selections |> Map.tryFind dep.Package + |> Option.map fst |> Option.map (fun rv -> rv.Versions |> Constraint.satisfies c |> not) |> Option.defaultValue true - let findUnresolved pick (selections: Map) (deps: Set) = + let findUnresolved pick (selections: Map) (deps: Set) = let constraints = Map.valueList selections + |> List.map fst |> List.map (fun m -> m.Manifest.Dependencies) |> List.map (Set.map toPackageConstraint) |> List.fold Set.union (deps |> Set.map toPackageConstraint) @@ -125,6 +128,7 @@ module Solver = let next = notVisited |> Seq.choose (fun d -> selections |> Map.tryFind d.Package) + |> Seq.map fst |> Seq.fold (fun deps m -> Set.union m.Manifest.Dependencies deps) Set.empty yield! @@ -383,14 +387,15 @@ module Solver = state.Hints |> Map.tryFind p |> Option.defaultValue([]) - |> Seq.filter(fun (atom, _) -> atom.Versions |> Constraint.satisfies c) + |> Seq.filter(fun lp -> lp.Versions |> Constraint.satisfies c) + |> Seq.distinct |> AsyncSeq.ofSeq - |> AsyncSeq.mapAsync(fun (atom, lock) -> async { + |> AsyncSeq.mapAsync(fun lp -> async { try - let! manifest = sourceExplorer.FetchManifest (lock, atom.Versions) + let! manifest = sourceExplorer.FetchManifest (lp.Location, lp.Versions) let resolvedVersion = { - Lock = lock - Versions = atom.Versions + Lock = lp.Location + Versions = lp.Versions Manifest = manifest } return Result.Ok resolvedVersion @@ -402,11 +407,43 @@ module Solver = | Result.Error NoManifest -> false | _ -> true) + let fetchHints (sourceExplorer : ISourceExplorer) (state: SolverState) (resolvedVersion : ResolvedVersion) : Async = async { + try + let! lock = sourceExplorer.FetchLock (resolvedVersion.Lock, resolvedVersion.Versions) + let hints = + Seq.append + (state.Hints |> Map.toSeq) + (lock.Packages + |> Map.toSeq + |> Seq.map (fun (k, v) -> (k, [v]))) + |> Seq.groupBy fst + |> Seq.map (fun (k, vs) -> (k, vs |> Seq.map snd |> Seq.distinct |> List.concat)) + |> Map.ofSeq + + return { + state with Hints = hints + } + with _ -> + return state + } + + let collectPrivateHints (state : SolverState) (p : PackageIdentifier) = + state.Hints + |> Map.tryFind p + |> Option.defaultValue [] + |> List.map (fun l -> l.PrivatePackages |> Map.toSeq) + |> Seq.collect id + |> Seq.groupBy fst + |> Seq.map (fun (k, vs) -> (k, vs |> Seq.map snd |> Seq.distinct |> Seq.map List.singleton |> List.concat)) + |> Map.ofSeq + + let getCandidates (resolver: MailboxProcessor) (sourceExplorer: ISourceExplorer) state selections p cs = asyncSeq { let constraints = selections |> Map.valueList + |> Seq.map fst |> Seq.map (fun m -> m.Manifest.Dependencies) |> Seq.append [state.Root] |> Seq.map (Set.map toPackageConstraint) @@ -416,6 +453,7 @@ module Solver = let manifests = selections |> Map.valueList + |> Seq.map fst |> Seq.map (fun rv -> rv.Manifest) |> Seq.toList @@ -452,91 +490,115 @@ module Solver = | (_, _) -> prev = next) } - let rec private step (context : TaskContext) (resolver : MailboxProcessor) (state : SolverState) (path: List): AsyncSeq> = asyncSeq { + let zipState state clause = + Result.map (fun candidate -> (clause, state, candidate)) + >> Result.mapError(fun e -> (clause, e)) + + let mergeHint sourceExplorer next = async { + match next with + | Result.Ok (clause, state, rv) -> + let! nextState = fetchHints sourceExplorer state rv + return Result.Ok (clause, nextState, rv) + | Result.Error e -> return Result.Error e + } + + let quickStrategy resolver sourceExplorer state selections = asyncSeq { + let unresolved = breathFirst selections state.Root + + for (p, cs) in unresolved do + yield! + (AsyncSeq.append + (getHints sourceExplorer state p cs) + (getCandidates resolver sourceExplorer state selections p cs)) + |> AsyncSeq.map (zipState state (p, cs)) + |> AsyncSeq.mapAsync (mergeHint sourceExplorer) + } + + let upgradeStrategy resolver sourceExplorer state selections = asyncSeq { + let unresolved = breathFirst selections state.Root + + for (p, cs) in unresolved do + yield! + getCandidates resolver sourceExplorer state selections p cs + |> AsyncSeq.map (zipState state (p, cs)) + } + + let rec private step (context : TaskContext) (resolver : MailboxProcessor) strategy (state : SolverState) (path: List): AsyncSeq> = asyncSeq { let sourceExplorer = context.SourceExplorer let log = namespacedLogger context.Console ("solver") let selections = pruneSelections state.Selections state.Root - let unresolved = breathFirst selections state.Root |> Seq.toList - - if (unresolved |> Seq.isEmpty) + if breathFirst selections state.Root |> Seq.isEmpty then - yield Result.Ok {Resolutions = state.Selections} + yield Result.Ok {Resolutions = selections} else + let candidates = strategy state selections |> AsyncSeq.cache + + let results = + candidates + |> AsyncSeq.choose (fun x -> match x with | Result.Ok v -> Some v | _ -> None) + |> AsyncSeq.filter(fun ((p, cs), _, rv) -> path |> List.contains (Node (p, cs, rv)) |> not) + |> AsyncSeq.mapAsync (fun ((p, cs), state, rv) -> async { + let m = rv.Manifest + let privateState : SolverState = { + Hints = collectPrivateHints state p + Root = m.PrivateDependencies + Locations = state.Locations + Selections = Map.empty + } + + let! privateSolution = + (step context resolver strategy privateState [Root m]) + |> AsyncSeq.choose(fun x -> + match x with + | Result.Ok x -> Some x + | _ -> None) + |> AsyncSeq.tryFirst + + return + match privateSolution with + | Some ps -> + let nextState = { + state with + Selections = selections |> Map.add p (rv, ps) + } + let node = Node (p, cs, rv) + Result.Ok <| step context resolver strategy nextState (node :: path) + | None -> Result.Error ((p, cs), NoPrivateSolution) // TODO: propagate error + }) + |> AsyncSeq.collect(fun x -> + match x with + | Result.Ok next -> next + | Result.Error e -> AsyncSeq.ofSeq [Result.Error e] + ) + |> AsyncSeq.cache - for (p, cs) in unresolved do - let candidates = - AsyncSeq.append - (getHints sourceExplorer state p cs) - (getCandidates resolver sourceExplorer state selections p cs) - - let results = - candidates - |> AsyncSeq.choose (fun x -> match x with | Result.Ok v -> Some v | _ -> None) - |> AsyncSeq.filter(fun rv -> - let node = Node (p, cs, rv) - path |> List.contains node |> not) - |> AsyncSeq.mapAsync (fun rv -> async { - let m = rv.Manifest - let privateState : SolverState = { - Hints = state.Hints - Root = m.PrivateDependencies - Locations = state.Locations - Selections = Map.empty - } + yield! results - let! privateSolution = - (step context resolver privateState [Root m]) - |> AsyncSeq.choose(fun x -> - match x with - | Result.Ok x -> Some x - | _ -> None) - |> AsyncSeq.tryFirst - - return - match privateSolution with - | Some ps -> - let nextState = { - state with - Selections = state.Selections |> Map.add p (rv, ps) - } - let node = Node (p, cs, rv) - Result.Ok <| step context resolver nextState (node :: path) - | None -> Result.Error NoPrivateSolution // TODO: propagate error - }) - |> AsyncSeq.collect(fun x -> - match x with - | Result.Ok next -> next - | Result.Error e -> AsyncSeq.ofSeq [Result.Error e] - ) - |> AsyncSeq.cache - - yield! results - - let solutions = - results - |> AsyncSeq.choose(fun x -> - match x with - | Result.Ok s -> Some s - | _ -> None - ) - - let errors = - results - |> AsyncSeq.choose(fun x -> - match x with - | Result.Error e -> Some e - | _ -> None) - |> AsyncSeq.distinctUntilChanged - - let! solution = solutions |> AsyncSeq.tryFirst - match solution with - | Some _ -> () - | None -> - for error in errors do - do! resolver.PostAndAsyncReply (fun ch -> MarkBadPath (path, (p, cs), error, ch)) - () + let solutions = + results + |> AsyncSeq.choose(fun x -> + match x with + | Result.Ok s -> Some s + | _ -> None + ) + + let errors = + results + |> AsyncSeq.choose(fun x -> + match x with + | Result.Error e -> Some e + | _ -> None) + |> AsyncSeq.distinctUntilChanged + + let! solution = solutions |> AsyncSeq.tryFirst + match solution with + | Some _ -> () + | None -> + for ((p, cs), error) in errors do + do! resolver.PostAndAsyncReply (fun ch -> MarkBadPath (path, (p, cs), error, ch)) + () } let solutionCollector resolutions = @@ -554,8 +616,7 @@ module Solver = let solve (context : TaskContext) (partialSolution : Solution) (manifest : Manifest) (style : ResolutionStyle) (lock : Lock option) = async { let hints = lock - |> Option.map (fun l -> - l.Packages |> Map.map (fun p v -> [({Package = p; Versions = v.Versions}, v.Location)])) + |> Option.map (fun l -> l.Packages |> (Map.map (fun _ v -> [v]))) |> Option.defaultValue Map.empty let state = { @@ -563,25 +624,31 @@ module Solver = manifest.Dependencies manifest.PrivateDependencies Hints = hints - Selections = Map.empty + Selections = partialSolution.Resolutions Locations = manifest.Locations } let resolver = resolutionManager context.SourceExplorer + let strategy = + match style with + | Quick -> quickStrategy resolver context.SourceExplorer + | Upgrading -> upgradeStrategy resolver context.SourceExplorer + let resolutions = - step context resolver state [Root manifest] + step context resolver strategy state [Root manifest] + let result = resolutions |> AsyncSeq.choose (fun s -> match s with | Result.Ok s -> Some s - | _ -> None - ) - |> AsyncSeq.map (fun s -> - Resolution.Ok s - ) + | Result.Error e -> + System.Console.WriteLine e + None + ) + |> AsyncSeq.map Resolution.Ok |> solutionCollector |> Option.defaultValue (Set.empty |> Resolution.Conflict) From 5557468c6dde17f10b2c472ecdde606de8e86a57 Mon Sep 17 00:00:00 2001 From: Gaetano Checinski Date: Sun, 10 Mar 2019 16:32:05 +0000 Subject: [PATCH 13/25] feat: filter hints that contain unresolvable cores --- buckaroo/Solver.fs | 202 ++++++++++++++++++++++++++++----------------- 1 file changed, 124 insertions(+), 78 deletions(-) diff --git a/buckaroo/Solver.fs b/buckaroo/Solver.fs index 33a4aea..d3746af 100644 --- a/buckaroo/Solver.fs +++ b/buckaroo/Solver.fs @@ -44,10 +44,26 @@ module Solver = type ResolutionRequest = | MarkBadPath of List * PackageConstraint * SearchStrategyError * AsyncReplyChannel + | ProposeCandidates of Constraints * PackageConstraint * seq * AsyncReplyChannel>> | GetCandidates of Constraints * PackageConstraint * PackageSources * AsyncReplyChannel>> type SearchStrategy = ISourceExplorer -> SolverState -> AsyncSeq> + let private ifError x = + match x with + | Result.Error e -> Some e + | _ -> None + + let private ifOk x = + match x with + | Result.Ok v -> Some v + | _ -> None + + let private resultOrDefaultWith f x = + match x with + | Result.Ok v -> v + | Result.Error e -> f e + let toDnf c = match c with | All xs -> xs @@ -64,9 +80,9 @@ module Solver = let constraintsOfSelection selections = Map.valueList selections - |> List.map (fun m -> m.Manifest.Dependencies) - |> List.map (Set.map toPackageConstraint) - |> List.fold Set.union Set.empty + |> Seq.map (fun m -> m.Manifest.Dependencies) + |> Seq.map (Set.map toPackageConstraint) + |> Seq.fold Set.union Set.empty |> constraintsOf @@ -108,10 +124,10 @@ module Solver = let findUnresolved pick (selections: Map) (deps: Set) = let constraints = Map.valueList selections - |> List.map fst - |> List.map (fun m -> m.Manifest.Dependencies) - |> List.map (Set.map toPackageConstraint) - |> List.fold Set.union (deps |> Set.map toPackageConstraint) + |> Seq.map fst + |> Seq.map (fun m -> m.Manifest.Dependencies) + |> Seq.map (Set.map toPackageConstraint) + |> Seq.fold Set.union (deps |> Set.map toPackageConstraint) |> constraintsOf let rec loop (visited: Set) (deps: Set) : seq> = seq { @@ -327,6 +343,43 @@ module Solver = while true do let! req = inbox.Receive() match req with + | ProposeCandidates (constraints, (p, cs), lockedPackages, channel) -> + lockedPackages + |> AsyncSeq.ofSeq + |> AsyncSeq.mapAsync(fun lp -> async { + try + let! manifest = sourceExplorer.FetchManifest (lp.Location, lp.Versions) + + let conflicts = + manifest.Dependencies + |> Set.map toPackageConstraint + |> constraintsOf + |> Map.insertWith Set.union p cs + |> findBadCores + |> Seq.map TransitiveConflict + + if conflicts |> Seq.isEmpty + then + return Result.Error NoManifest // TODO ... + else + let rv: ResolvedVersion = { + Manifest = manifest + Lock = lp.Location + Versions = lp.Versions + } + return Result.Ok rv + with _ -> + return Result.Error NoManifest + }) + |> AsyncSeq.filter (fun x -> + match x with + | Result.Error _ -> false + | _ -> true) + |> AsyncSeq.takeWhile(fun e -> + match e with + | _ -> findBadCores constraints |> Seq.isEmpty) + |> channel.Reply + | GetCandidates (constraints, dep, locations, channel) -> trackLocal locations dep |> AsyncSeq.takeWhile(fun e -> @@ -382,30 +435,30 @@ module Solver = channel.Reply () }) - let getHints (sourceExplorer : ISourceExplorer) state p cs = + let getHints (resolver: MailboxProcessor) state selections p cs = asyncSeq { + + let constraints = + selections + |> Map.valueList + |> Seq.map fst + |> Seq.map (fun m -> m.Manifest.Dependencies) + |> Seq.append [state.Root] + |> Seq.map (Set.map toPackageConstraint) + |> Set.unionMany + |> constraintsOf + let c = cs |> All - state.Hints - |> Map.tryFind p - |> Option.defaultValue([]) - |> Seq.filter(fun lp -> lp.Versions |> Constraint.satisfies c) - |> Seq.distinct - |> AsyncSeq.ofSeq - |> AsyncSeq.mapAsync(fun lp -> async { - try - let! manifest = sourceExplorer.FetchManifest (lp.Location, lp.Versions) - let resolvedVersion = { - Lock = lp.Location - Versions = lp.Versions - Manifest = manifest - } - return Result.Ok resolvedVersion - with _ -> - return Result.Error NoManifest - }) - |> AsyncSeq.filter (fun x -> - match x with - | Result.Error NoManifest -> false - | _ -> true) + let candidates = + state.Hints + |> Map.tryFind p + |> Option.defaultValue([]) + |> Seq.filter(fun lp -> lp.Versions |> Constraint.satisfies c) + |> Seq.distinct + + + let! request = resolver.PostAndAsyncReply (fun channel -> ProposeCandidates (constraints, (p, cs), candidates, channel)) + yield! request + } let fetchHints (sourceExplorer : ISourceExplorer) (state: SolverState) (resolvedVersion : ResolvedVersion) : Async = async { try @@ -431,7 +484,7 @@ module Solver = state.Hints |> Map.tryFind p |> Option.defaultValue [] - |> List.map (fun l -> l.PrivatePackages |> Map.toSeq) + |> Seq.map (fun l -> l.PrivatePackages |> Map.toSeq) |> Seq.collect id |> Seq.groupBy fst |> Seq.map (fun (k, vs) -> (k, vs |> Seq.map snd |> Seq.distinct |> Seq.map List.singleton |> List.concat)) @@ -471,6 +524,7 @@ module Solver = |> AsyncSeq.mapAsync(fun candidate -> async { match candidate with | Result.Error e -> + System.Console.WriteLine e return Result.Error e | Result.Ok (_, (location, versions)) -> let! lock = sourceExplorer.LockLocation location @@ -486,12 +540,13 @@ module Solver = |> AsyncSeq.distinctUntilChangedWith (fun prev next -> match prev, next with | (Result.Ok p), (Result.Ok n) -> - p.Manifest = n.Manifest + p.Manifest = n.Manifest // All revisions with an identical manifest will have the same outcome | (_, _) -> prev = next) } let zipState state clause = - Result.map (fun candidate -> (clause, state, candidate)) + id + >> Result.map (fun candidate -> (clause, state, candidate)) >> Result.mapError(fun e -> (clause, e)) let mergeHint sourceExplorer next = async { @@ -508,7 +563,7 @@ module Solver = for (p, cs) in unresolved do yield! (AsyncSeq.append - (getHints sourceExplorer state p cs) + (getHints resolver state selections p cs) (getCandidates resolver sourceExplorer state selections p cs)) |> AsyncSeq.map (zipState state (p, cs)) |> AsyncSeq.mapAsync (mergeHint sourceExplorer) @@ -523,82 +578,73 @@ module Solver = |> AsyncSeq.map (zipState state (p, cs)) } + let private privateStep step ((p, _), state, rv) = + let m = rv.Manifest + let privateState : SolverState = { + Hints = collectPrivateHints state p + Root = m.PrivateDependencies + Locations = state.Locations + Selections = Map.empty + } + + (step privateState [Root m]) + |> AsyncSeq.choose ifOk + |> AsyncSeq.tryFirst + + let rec private step (context : TaskContext) (resolver : MailboxProcessor) strategy (state : SolverState) (path: List): AsyncSeq> = asyncSeq { let sourceExplorer = context.SourceExplorer let log = namespacedLogger context.Console ("solver") + let nextStep = step context resolver strategy let selections = pruneSelections state.Selections state.Root + System.Console.WriteLine ("path: ") + for (p, v) in path |> Seq.choose(fun x -> match x with | Node (p, cs, rv) -> Some (p, rv.Versions) | Root _-> None) do + context.Console.Write ( + (PackageIdentifier.showRich p) + subtle "@" + + (Version.showRichSet v) + + subtle " -> " + ) + if breathFirst selections state.Root |> Seq.isEmpty then yield Result.Ok {Resolutions = selections} else - let candidates = strategy state selections |> AsyncSeq.cache - let results = - candidates - |> AsyncSeq.choose (fun x -> match x with | Result.Ok v -> Some v | _ -> None) + strategy state selections + |> AsyncSeq.choose ifOk |> AsyncSeq.filter(fun ((p, cs), _, rv) -> path |> List.contains (Node (p, cs, rv)) |> not) |> AsyncSeq.mapAsync (fun ((p, cs), state, rv) -> async { - let m = rv.Manifest - let privateState : SolverState = { - Hints = collectPrivateHints state p - Root = m.PrivateDependencies - Locations = state.Locations - Selections = Map.empty - } - - let! privateSolution = - (step context resolver strategy privateState [Root m]) - |> AsyncSeq.choose(fun x -> - match x with - | Result.Ok x -> Some x - | _ -> None) - |> AsyncSeq.tryFirst - + let! privateSolution = privateStep nextStep ((p, cs), state, rv) return match privateSolution with + | None -> Result.Error ((p, cs), NoPrivateSolution) // TODO: propagate error | Some ps -> + let node = Node (p, cs, rv) let nextState = { state with Selections = selections |> Map.add p (rv, ps) } - let node = Node (p, cs, rv) - Result.Ok <| step context resolver strategy nextState (node :: path) - | None -> Result.Error ((p, cs), NoPrivateSolution) // TODO: propagate error + Result.Ok <| nextStep nextState (node :: path) }) - |> AsyncSeq.collect(fun x -> - match x with - | Result.Ok next -> next - | Result.Error e -> AsyncSeq.ofSeq [Result.Error e] - ) + |> AsyncSeq.collect (resultOrDefaultWith (AsyncSeq.singleton << Result.Error)) |> AsyncSeq.cache - yield! results - - let solutions = - results - |> AsyncSeq.choose(fun x -> - match x with - | Result.Ok s -> Some s - | _ -> None - ) - let errors = results - |> AsyncSeq.choose(fun x -> - match x with - | Result.Error e -> Some e - | _ -> None) + |> AsyncSeq.choose ifError |> AsyncSeq.distinctUntilChanged - let! solution = solutions |> AsyncSeq.tryFirst + let! solution = results |> AsyncSeq.choose ifOk |> AsyncSeq.tryFirst match solution with | Some _ -> () | None -> for ((p, cs), error) in errors do + System.Console.WriteLine error do! resolver.PostAndAsyncReply (fun ch -> MarkBadPath (path, (p, cs), error, ch)) - () + + yield! results } let solutionCollector resolutions = From 16a7f161c29ee80249ec884503d23e9e44e7bcb1 Mon Sep 17 00:00:00 2001 From: Gaetano Checinski Date: Sun, 10 Mar 2019 16:36:23 +0000 Subject: [PATCH 14/25] chore: fixes constraints tests --- buckaroo-tests/Constraint.fs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/buckaroo-tests/Constraint.fs b/buckaroo-tests/Constraint.fs index 677dcd8..52c5645 100644 --- a/buckaroo-tests/Constraint.fs +++ b/buckaroo-tests/Constraint.fs @@ -16,21 +16,21 @@ let ``Constraint.parse works correctly`` () = ("*", Constraint.wildcard |> Some); ("revision=aabbccddee", Version.Git(GitVersion.Revision "aabbccddee") |> Exactly |> Some); ("!*", Constraint.wildcard |> Constraint.Complement |> Some); - ("any(branch=master)", Some(Any [Exactly (Version.Git(GitVersion.Branch "master"))])); - ("any(any(branch=master))", Some(Any [ Any [Exactly (Version.Git(GitVersion.Branch "master"))]])); - ("any(revision=aabbccddee branch=master)", Some (Any [ + ("any(branch=master)", Some(Any <| Set[Exactly (Version.Git(GitVersion.Branch "master"))])); + ("any(any(branch=master))", Some(Any <|Set[ Any <|Set[Exactly (Version.Git(GitVersion.Branch "master"))]])); + ("any(revision=aabbccddee branch=master)", Some (Any <|Set[ Exactly (Version.Git(GitVersion.Revision "aabbccddee")); Exactly (Version.Git(GitVersion.Branch "master"))])); - ("all(*)", Some(All [Constraint.wildcard])); + ("all(*)", Some(All <| Set[Constraint.wildcard])); ( "all(branch=master !revision=aabbccddee)", - Some (All [Exactly (Version.Git(GitVersion.Branch "master")); Complement (Exactly (Version.Git(GitVersion.Revision "aabbccddee")))]) + Some (All <| Set[Exactly (Version.Git(GitVersion.Branch "master")); Complement (Exactly (Version.Git(GitVersion.Revision "aabbccddee")))]) ); ( "all(branch=master !any(revision=aabbccddee branch=develop))", - Some (All [ + Some (All <| Set[ Exactly (Version.Git(GitVersion.Branch "master")); - Complement (Any([ + Complement (Any(Set[ Exactly (Version.Git(GitVersion.Revision "aabbccddee")); Exactly (Version.Git(GitVersion.Branch "develop")); ])) @@ -52,12 +52,12 @@ let ``Constraint.parse works correctly`` () = "+1.0.0", Some (Constraint.rangeToConstraint RangeType.Patch (SemVer.create (1, 0, 0, 0))) ); - ("all(branch=master ^1.0.0)", Some (All [ + ("all(branch=master ^1.0.0)", Some (All <| Set[ Exactly (Git (GitVersion.Branch "master")); Constraint.rangeToConstraint RangeType.Major (SemVer.create (1, 0, 0, 0)) ] )); - ("all(^1.0.0 branch=master)", Some (All [ + ("all(^1.0.0 branch=master)", Some (All <| Set[ Constraint.rangeToConstraint RangeType.Major (SemVer.create (1, 0, 0, 0)); Exactly (Git (GitVersion.Branch "master")) ])) From 72d5139e2ec47d93d55e494735d3763865640d60 Mon Sep 17 00:00:00 2001 From: Gaetano Checinski Date: Sun, 10 Mar 2019 17:22:22 +0000 Subject: [PATCH 15/25] chore: fixes constraints related tests --- buckaroo-tests/Manifest.fs | 6 +++--- buckaroo-tests/Solver.fs | 4 ++-- buckaroo/Constraint.fs | 4 +++- 3 files changed, 8 insertions(+), 6 deletions(-) diff --git a/buckaroo-tests/Manifest.fs b/buckaroo-tests/Manifest.fs index 7c8ac1f..0240f26 100644 --- a/buckaroo-tests/Manifest.fs +++ b/buckaroo-tests/Manifest.fs @@ -87,7 +87,7 @@ let ``Manifest.toToml roundtrip 1`` () = ] Dependencies = Set [{ Targets = Some ([{Folders=["foo"; "bar"]; Name = "xxx"}]) - Constraint = All [Constraint.Exactly (Version.SemVer SemVer.zero)] + Constraint = All <| Set[Constraint.Exactly (Version.SemVer SemVer.zero)] Package = PackageIdentifier.GitHub { Owner = "abc"; Project = "def" } }] } @@ -123,12 +123,12 @@ let ``Manifest.toToml roundtrip 2`` () = ] Dependencies = Set [{ Targets = Some ([{Folders=["foo"; "bar"]; Name = "xxx"}]) - Constraint = All [Constraint.Exactly (Version.SemVer SemVer.zero)] + Constraint = All <| Set[Constraint.Exactly (Version.SemVer SemVer.zero)] Package = PackageIdentifier.GitHub { Owner = "abc"; Project = "def" } }] PrivateDependencies = Set [{ Targets = Some ([{Folders=["foo"; "bar"]; Name = "yyy"}]) - Constraint = Any [Constraint.Exactly (Version.SemVer SemVer.zero)] + Constraint = Any <|Set[Constraint.Exactly (Version.SemVer SemVer.zero)] Package = PackageIdentifier.GitHub { Owner = "abc"; Project = "def" } }] } diff --git a/buckaroo-tests/Solver.fs b/buckaroo-tests/Solver.fs index 23fe763..75e9699 100644 --- a/buckaroo-tests/Solver.fs +++ b/buckaroo-tests/Solver.fs @@ -228,7 +228,7 @@ let ``Solver can compute version intersections`` () = let ``Solver can compute intersection of branches`` () = let root = manifest [ - ("a", All [Exactly (br "b"); Exactly (br "a")]) + ("a", All <| Set[Exactly (br "b"); Exactly (br "a")]) ] let spec = [ @@ -346,7 +346,7 @@ let ``Solver handles negated constraints also`` () = let root = manifest [ ("a", Exactly (br "a")) - ("b", Any [Exactly (br "a"); Exactly (br "b")]) + ("b", Any <|Set[Exactly (br "a"); Exactly (br "b")]) ] let spec = [ diff --git a/buckaroo/Constraint.fs b/buckaroo/Constraint.fs index 0d1f4a7..f42b33c 100644 --- a/buckaroo/Constraint.fs +++ b/buckaroo/Constraint.fs @@ -67,6 +67,8 @@ module Constraint = | SemVer semVer -> semVer |> isWithinRange (op, v) | _ -> false ) + + // TODO: Better Sorting!!!!! let rec compare (x : Constraint) (y : Constraint) : int = match (x, y) with | (Exactly u, Exactly v) -> Version.compare u v @@ -86,7 +88,7 @@ module Constraint = | (All xs, y) -> xs |> Seq.map (fun x -> compare x y) - |> Seq.append [ 1 ] + |> Seq.append [ -1 ] |> Seq.min | (y, All xs) -> (compare (All xs) y) * -1 From 6b513742681a2f516e4adb2d99664bb14bcbb844 Mon Sep 17 00:00:00 2001 From: Gaetano Checinski Date: Mon, 11 Mar 2019 11:01:54 +0000 Subject: [PATCH 16/25] chore: fixes tests --- buckaroo/Constraint.fs | 2 +- buckaroo/Solver.fs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/buckaroo/Constraint.fs b/buckaroo/Constraint.fs index f42b33c..460ff5a 100644 --- a/buckaroo/Constraint.fs +++ b/buckaroo/Constraint.fs @@ -88,7 +88,7 @@ module Constraint = | (All xs, y) -> xs |> Seq.map (fun x -> compare x y) - |> Seq.append [ -1 ] + |> Seq.append [ 1 ] |> Seq.min | (y, All xs) -> (compare (All xs) y) * -1 diff --git a/buckaroo/Solver.fs b/buckaroo/Solver.fs index d3746af..a7d825f 100644 --- a/buckaroo/Solver.fs +++ b/buckaroo/Solver.fs @@ -358,7 +358,7 @@ module Solver = |> findBadCores |> Seq.map TransitiveConflict - if conflicts |> Seq.isEmpty + if conflicts |> Seq.isEmpty |> not then return Result.Error NoManifest // TODO ... else From 765c98a3f030411228a015e53a4af9484dd5f7a7 Mon Sep 17 00:00:00 2001 From: njlr Date: Tue, 12 Mar 2019 12:29:04 +0000 Subject: [PATCH 17/25] * Improves CLI * Passes solver error messages back to user --- buckaroo-tests/Constraint.fs | 6 +- buckaroo-tests/Solver.fs | 17 +- buckaroo/AddCommand.fs | 22 +- buckaroo/Command.fs | 8 +- buckaroo/ConsoleManager.fs | 24 +- buckaroo/Constants.fs | 5 +- buckaroo/Constraint.fs | 1 + buckaroo/DefaultSourceExplorer.fs | 32 +- buckaroo/Dependency.fs | 21 +- buckaroo/GitCli.fs | 13 +- buckaroo/GitLabApi.fs | 4 +- buckaroo/GitManager.fs | 121 ++-- buckaroo/InstallCommand.fs | 62 +- buckaroo/Logger.fs | 83 +++ buckaroo/Resolution.fs | 50 +- buckaroo/ResolveCommand.fs | 56 +- buckaroo/RichOutput.fs | 13 + buckaroo/SearchStrategy.fs | 54 ++ buckaroo/Solver.fs | 1107 ++++++++++++++--------------- buckaroo/Tasks.fs | 8 +- buckaroo/buckaroo.fsproj | 2 + 21 files changed, 882 insertions(+), 827 deletions(-) create mode 100644 buckaroo/Logger.fs create mode 100644 buckaroo/SearchStrategy.fs diff --git a/buckaroo-tests/Constraint.fs b/buckaroo-tests/Constraint.fs index 52c5645..b4c1e4a 100644 --- a/buckaroo-tests/Constraint.fs +++ b/buckaroo-tests/Constraint.fs @@ -16,9 +16,9 @@ let ``Constraint.parse works correctly`` () = ("*", Constraint.wildcard |> Some); ("revision=aabbccddee", Version.Git(GitVersion.Revision "aabbccddee") |> Exactly |> Some); ("!*", Constraint.wildcard |> Constraint.Complement |> Some); - ("any(branch=master)", Some(Any <| Set[Exactly (Version.Git(GitVersion.Branch "master"))])); - ("any(any(branch=master))", Some(Any <|Set[ Any <|Set[Exactly (Version.Git(GitVersion.Branch "master"))]])); - ("any(revision=aabbccddee branch=master)", Some (Any <|Set[ + ("any(branch=master)", Some(Any <| Set [ Exactly (Version.Git(GitVersion.Branch "master"))])); + ("any(any(branch=master))", Some(Any <| Set[ Any <| Set [ Exactly (Version.Git(GitVersion.Branch "master"))]])); + ("any(revision=aabbccddee branch=master)", Some (Any <| Set[ Exactly (Version.Git(GitVersion.Revision "aabbccddee")); Exactly (Version.Git(GitVersion.Branch "master"))])); ("all(*)", Some(All <| Set[Constraint.wildcard])); diff --git a/buckaroo-tests/Solver.fs b/buckaroo-tests/Solver.fs index 75e9699..747f6b2 100644 --- a/buckaroo-tests/Solver.fs +++ b/buckaroo-tests/Solver.fs @@ -11,8 +11,9 @@ open Buckaroo.Tests type CookBook = List * Manifest> type LockBookEntries = List<(string*int) * List>> type LockBook = Map + let package name = PackageIdentifier.Adhoc { - Owner = "test"; + Owner = "test" Project = name } @@ -89,7 +90,7 @@ type TestingSourceExplorer (cookBook : CookBook, lockBook : LockBook) = Revision = r }) |> AsyncSeq.ofSeq - | _ -> raise <| new System.SystemException "package not found" + | _ -> raise <| System.SystemException "Package not found" } member this.LockLocation (location : PackageLocation) : Async = async { @@ -120,11 +121,11 @@ type TestingSourceExplorer (cookBook : CookBook, lockBook : LockBook) = let solve (partial : Solution) (cookBook : CookBook) (lockBookEntries : LockBookEntries) root style = let lockBook = lockBookOf lockBookEntries - let console = new ConsoleManager(LoggingLevel.Silent); + let console = ConsoleManager (LoggingLevel.Silent) let context : TaskContext = { - Console = console; - DownloadManager = DownloadManager(console, "/tmp"); - GitManager = new GitManager(console, new GitCli(console), "/tmp"); + Console = console + DownloadManager = DownloadManager(console, "/tmp") + GitManager = new GitManager(console, new GitCli(console), "/tmp") SourceExplorer = TestingSourceExplorer(cookBook, lockBook) } @@ -133,7 +134,7 @@ let solve (partial : Solution) (cookBook : CookBook) (lockBookEntries : LockBook root style (lockBook |> Map.tryFind (packageLock ("root", 0))) -let getLockedRev (p : string) (r: Resolution) = +let getLockedRev (p : string) (r : _) = match r with | Ok solution -> let (resolved, _) = solution.Resolutions.[package p] @@ -143,7 +144,7 @@ let getLockedRev (p : string) (r: Resolution) = | _ -> "" () -let isOk (r: Resolution) = +let isOk (r : _) = match r with | Ok _ -> true | _ -> false diff --git a/buckaroo/AddCommand.fs b/buckaroo/AddCommand.fs index 2fdb7be..2b5f1e6 100644 --- a/buckaroo/AddCommand.fs +++ b/buckaroo/AddCommand.fs @@ -1,13 +1,14 @@ module Buckaroo.AddCommand -open System open System.IO open Buckaroo.RichOutput -open Buckaroo +open Buckaroo.Logger let task (context : Tasks.TaskContext) dependencies = async { - context.Console.Write ( - (text "Adding ") + + let logger = createLogger context.Console None + + logger.RichInfo ( + (text "Adding dependency on ") + ( dependencies |> Seq.map Dependency.showRich @@ -16,6 +17,7 @@ let task (context : Tasks.TaskContext) dependencies = async { ) let! manifest = Tasks.readManifest "." + let newManifest = { manifest with Dependencies = @@ -26,6 +28,7 @@ let task (context : Tasks.TaskContext) dependencies = async { if manifest = newManifest then + logger.Warning ("The dependency already exists in the manifest") return () else let! maybeLock = async { @@ -37,15 +40,16 @@ let task (context : Tasks.TaskContext) dependencies = async { return None } - let! resolution = Solver.solve context Solution.empty newManifest ResolutionStyle.Quick maybeLock + let! resolution = + Solver.solve context Solution.empty newManifest ResolutionStyle.Quick maybeLock match resolution with - | Resolution.Ok solution -> + | Result.Ok solution -> do! Tasks.writeManifest newManifest do! Tasks.writeLock (Lock.fromManifestAndSolution newManifest solution) do! InstallCommand.task context - | _ -> - () - context.Console.Write ("Success. " |> text |> foreground ConsoleColor.Green) + logger.Success ("The dependency was added to the manifest and installed") + | _ -> + logger.Error ("Failed to add the dependency") } diff --git a/buckaroo/Command.fs b/buckaroo/Command.fs index 642de92..27dd2c3 100644 --- a/buckaroo/Command.fs +++ b/buckaroo/Command.fs @@ -210,15 +210,13 @@ module Command = let! resolution = Solver.solve context Solution.empty newManifest ResolutionStyle.Quick maybeLock match resolution with - | Resolution.Ok solution -> + | Result.Ok solution -> do! Tasks.writeManifest newManifest do! Tasks.writeLock (Lock.fromManifestAndSolution newManifest solution) do! InstallCommand.task context - | _ -> () - - System.Console.WriteLine ("Success. ") - return () + System.Console.WriteLine ("Success. ") + | _ -> () } let init context = async { diff --git a/buckaroo/ConsoleManager.fs b/buckaroo/ConsoleManager.fs index 6bee310..faa397a 100644 --- a/buckaroo/ConsoleManager.fs +++ b/buckaroo/ConsoleManager.fs @@ -113,19 +113,11 @@ type ConsoleManager (minimumLoggingLevel : LoggingLevel) = member this.Error (message, loggingLevel) = actor.Post (Output (message, loggingLevel, OutputCategory.Error)) - member this.Read() = - actor.PostAndAsyncReply(fun channel -> Input channel) - - member this.ReadSecret() = - actor.PostAndAsyncReply(fun channel -> InputSecret channel) - - member this.Flush() = - actor.PostAndAsyncReply(fun channel -> Flush channel) - -let namespacedLogger (console : ConsoleManager) (componentName : string) (x : RichOutput, logLevel : LoggingLevel) = - ( - "[" + componentName + "] " - |> RichOutput.text - |> RichOutput.foreground System.ConsoleColor.DarkGray - ) + - x |> fun x -> console.Write (x, logLevel) \ No newline at end of file + member this.Read () = + actor.PostAndAsyncReply Input + + member this.ReadSecret () = + actor.PostAndAsyncReply InputSecret + + member this.Flush () = + actor.PostAndAsyncReply Flush diff --git a/buckaroo/Constants.fs b/buckaroo/Constants.fs index ceb6457..2f6eecc 100644 --- a/buckaroo/Constants.fs +++ b/buckaroo/Constants.fs @@ -1,7 +1,7 @@ module Buckaroo.Constants [] -let Version = "2.0.2" +let Version = "2.2.0" [] let PackagesDirectory = "buckaroo" @@ -20,3 +20,6 @@ let BuckarooMacrosFileName = "buckaroo_macros.bzl" [] let BuckarooDepsFileName = "BUCKAROO_DEPS" + +[] +let MaxConsecutiveFailures = 10 diff --git a/buckaroo/Constraint.fs b/buckaroo/Constraint.fs index 460ff5a..449d7cd 100644 --- a/buckaroo/Constraint.fs +++ b/buckaroo/Constraint.fs @@ -254,6 +254,7 @@ module Constraint = allParser ] } + let parse (x : string) : Result = match run (parser .>> CharParsers.eof) x with | Success(result, _, _) -> Result.Ok result diff --git a/buckaroo/DefaultSourceExplorer.fs b/buckaroo/DefaultSourceExplorer.fs index 4e702e3..c27c7f3 100644 --- a/buckaroo/DefaultSourceExplorer.fs +++ b/buckaroo/DefaultSourceExplorer.fs @@ -1,16 +1,17 @@ namespace Buckaroo open FSharp.Control -open Buckaroo.Console open FSharpx -open RichOutput +open Buckaroo.Console +open Buckaroo.RichOutput +open Buckaroo.Logger type DefaultSourceExplorer (console : ConsoleManager, downloadManager : DownloadManager, gitManager : GitManager) = - let log = namespacedLogger console "explorer" + let logger = createLogger console (Some "explorer") let toOptional = Async.Catch >> (Async.map Choice.toOption) let fromFileCache url revision path = - gitManager.getFile url revision path |> toOptional + gitManager.GetFile url revision path |> toOptional let cacheOrApi (api, url : string, rev : string, path : string) = async { let! cached = fromFileCache url rev path @@ -22,7 +23,7 @@ type DefaultSourceExplorer (console : ConsoleManager, downloadManager : Download let extractFileFromHttp (source : HttpLocation) (filePath : string) = async { if Option.defaultValue ArchiveType.Zip source.Type <> ArchiveType.Zip then - return raise (new System.Exception("Only zip is currently supported")) + return raise (System.Exception("Only zip is currently supported")) let! pathToZip = downloadManager.DownloadToCache source.Url use file = System.IO.File.OpenRead pathToZip @@ -72,7 +73,7 @@ type DefaultSourceExplorer (console : ConsoleManager, downloadManager : Download cacheOrApi (GitLabApi.fetchFile gitLab.Package, url, gitLab.Revision, path) | PackageLock.Git git -> let url = git.Url - cacheOrApi(gitManager.getFile git.Url, url, git.Revision, path) + cacheOrApi(gitManager.GetFile git.Url, url, git.Revision, path) | PackageLock.Http (http, _) -> extractFileFromHttp http path @@ -299,8 +300,7 @@ type DefaultSourceExplorer (console : ConsoleManager, downloadManager : Download let errorMessage = "Invalid " + Constants.ManifestFileName + " file. \n" + (Manifest.ManifestParseError.show error) - new System.Exception(errorMessage) - |> raise + raise <| System.Exception errorMessage } member this.FetchLock (location, versions) = @@ -309,16 +309,16 @@ type DefaultSourceExplorer (console : ConsoleManager, downloadManager : Download return match maybeContent with | None -> - log( - (warn "warning ") + (text "Could not fetch ") + (highlight Constants.LockFileName) + (text " from ") + - (PackageLock.show location |> highlight) + (warn " 404"), LoggingLevel.Info) - raise <| new System.Exception("Could not fetch " + Constants.LockFileName + " file") + logger.RichWarning ( + (text "Could not fetch ") + (highlight Constants.LockFileName) + (text " from ") + + (PackageLock.show location |> highlight) + (warn " 404")) + raise <| System.Exception("Could not fetch " + Constants.LockFileName + " file") | Some content -> match Lock.parse content with | Result.Ok manifest -> manifest | Result.Error errorMessage -> - log( - (warn "warning ") + (text "Could not parse ") + (highlight Constants.LockFileName) + (text " from ") + - (PackageLock.show location |> highlight) + (text " ") + (warn errorMessage), LoggingLevel.Info) - new System.Exception("Invalid " + Constants.LockFileName + " file") |> raise + logger.RichWarning( + (text "Could not parse ") + (highlight Constants.LockFileName) + (text " from ") + + (PackageLock.show location |> highlight) + (text " ") + (warn errorMessage)) + System.Exception("Invalid " + Constants.LockFileName + " file") |> raise } diff --git a/buckaroo/Dependency.fs b/buckaroo/Dependency.fs index 24bfbc5..50d4ce8 100644 --- a/buckaroo/Dependency.fs +++ b/buckaroo/Dependency.fs @@ -9,6 +9,7 @@ type Dependency = { module Dependency = open FParsec + open Buckaroo.RichOutput let satisfies (dependency : Dependency) (atom : Atom) = atom.Package = dependency.Package && atom.Versions |> Constraint.satisfies dependency.Constraint @@ -23,15 +24,17 @@ module Dependency = let showRich (x : Dependency) = ( - PackageIdentifier.show x.Package - |> RichOutput.text - |> RichOutput.foreground System.ConsoleColor.Cyan - ) + - "@" + - ( - Constraint.show x.Constraint - |> RichOutput.text - |> RichOutput.foreground System.ConsoleColor.DarkRed + ( + PackageIdentifier.show x.Package + |> text + |> foreground System.ConsoleColor.Magenta + ) + + " at " + + ( + Constraint.show x.Constraint + |> text + |> foreground System.ConsoleColor.Magenta + ) ) + ( x.Targets diff --git a/buckaroo/GitCli.fs b/buckaroo/GitCli.fs index b840cdd..133d525 100644 --- a/buckaroo/GitCli.fs +++ b/buckaroo/GitCli.fs @@ -2,15 +2,16 @@ namespace Buckaroo open System open System.Text -open Buckaroo.Console -open RichOutput open FSharp.Control open FSharpx -open Bash +open Buckaroo.Console +open Buckaroo.RichOutput +open Buckaroo.Bash +open Buckaroo.Logger type GitCli (console : ConsoleManager) = - let log = namespacedLogger console "git" + let logger = createLogger console (Some "git") let nl = System.Environment.NewLine @@ -29,7 +30,7 @@ type GitCli (console : ConsoleManager) = console.Write (rt, LoggingLevel.Debug) - let stdout = new StringBuilder() + let stdout = StringBuilder () do! Bash.runBashSync exe args (stdout.Append >> ignore) ignore @@ -161,7 +162,7 @@ type GitCli (console : ConsoleManager) = } member this.ShallowClone (url : String) (directory : string) = async { - log((text "Shallow cloning ") + (highlight url), LoggingLevel.Info) + logger.RichInfo ((text "Shallow cloning ") + (highlight url)) do! runBash "git" ("clone --bare --depth=1 " + url + " " + directory) |> Async.Ignore diff --git a/buckaroo/GitLabApi.fs b/buckaroo/GitLabApi.fs index 0953f01..ee32c88 100644 --- a/buckaroo/GitLabApi.fs +++ b/buckaroo/GitLabApi.fs @@ -6,9 +6,9 @@ open FSharp.Data let fetchFile (package : AdhocPackageIdentifier) (commit : Revision) (file : string) = async { if commit.Length <> 40 then - return raise <| new ArgumentException("GitLab API requires full length commit hashes") + return raise <| ArgumentException("GitLab API requires full length commit hashes") else - let url = + let url = "https://gitlab.com/" + package.Owner + "/" + package.Project + "/raw/" + commit + "/" + file return! Http.AsyncRequestString(url) } diff --git a/buckaroo/GitManager.fs b/buckaroo/GitManager.fs index 02ce0c9..63d0b93 100644 --- a/buckaroo/GitManager.fs +++ b/buckaroo/GitManager.fs @@ -4,18 +4,20 @@ open System open System.IO open System.Security.Cryptography open System.Text.RegularExpressions -open FSharpx.Control open FSharp.Control open FSharpx -open Console -open RichOutput +open FSharpx.Control +open Buckaroo.Console +open Buckaroo.Logger +open Buckaroo.RichOutput -type CloneRequest = +type GitManagerRequest = | CloneRequest of string * AsyncReplyChannel> +| FetchRefs of string * AsyncReplyChannel> type GitManager (console : ConsoleManager, git : IGit, cacheDirectory : string) = - let log = namespacedLogger console "git" + let logger = createLogger console (Some "git") let mutable refsCache = Map.empty @@ -28,8 +30,10 @@ type GitManager (console : ConsoleManager, git : IGit, cacheDirectory : string) let regexSearch = new string(Path.GetInvalidFileNameChars()) + new string(Path.GetInvalidPathChars()) + - "@.:\\/"; - let r = new Regex(String.Format("[{0}]", Regex.Escape(regexSearch))) + "@.:\\/" + + let r = Regex(String.Format("[{0}]", Regex.Escape(regexSearch))) + Regex.Replace(r.Replace(x, "-"), "-{2,}", "-") let cloneFolderName (url : string) = @@ -62,6 +66,57 @@ type GitManager (console : ConsoleManager, git : IGit, cacheDirectory : string) |> Async.Cache cloneCache <- cloneCache |> Map.add url task replyChannel.Reply(task) + | FetchRefs (url, replyChannel) -> + match refsCache |> Map.tryFind url with + | Some task -> replyChannel.Reply (task) + | None -> + let task = + async { + logger.RichInfo ((text "Fetching refs from ") + (highlight url)) + + let cacheDir = cloneFolderName url + let startTime = System.DateTime.Now + + let! refs = + Async.Parallel + ( + ( + git.RemoteRefs url + |> Async.Catch + |> Async.map (Choice.toOption >> Option.defaultValue([])) + ), + ( + git.RemoteRefs cacheDir + |> Async.Catch + |> Async.map (Choice.toOption >> Option.defaultValue([])) + ) + ) + |> Async.map(fun (a, b) -> + if a.Length = 0 && b.Length = 0 + then + raise <| SystemException("No internet connection and the cache is empty") + else if a.Length > 0 + then + a + else + b + ) + + let endTime = System.DateTime.Now + + logger.RichSuccess( + (text "Fetched ") + + (refs |> List.length |> string |> info) + + (text " refs in ") + + ((endTime - startTime).TotalSeconds.ToString("N3"))) + + return refs + } + |> Async.Cache + + refsCache <- refsCache |> Map.add url task + + replyChannel.Reply (task) }) member this.Clone (url : string) : Async = async { @@ -70,8 +125,11 @@ type GitManager (console : ConsoleManager, git : IGit, cacheDirectory : string) } member this.CopyFromCache (gitUrl : string) (revision : Revision) (installPath : string) : Async = async { - let! hasGit = Files.directoryExists (Path.Combine (installPath, ".git/")) - if hasGit then + let! hasGit = + Files.directoryExists (Path.Combine (installPath, ".git/")) + + if hasGit + then do! git.UpdateRefs installPath return! git.Checkout installPath revision else @@ -116,47 +174,20 @@ type GitManager (console : ConsoleManager, git : IGit, cacheDirectory : string) |> AsyncSeq.take 1 |> AsyncSeq.lastOrDefault false - if not success then - raise <| new Exception("Failed to fetch: " + url + " " + commit) + if not success + then + raise <| Exception("Failed to fetch: " + url + " " + commit) } member this.FetchRefs (url : string) = async { - match refsCache |> Map.tryFind url with - | Some refs -> return refs - | None -> - log( (text "Fetching refs from ") + (highlight url), LoggingLevel.Info) - let cacheDir = cloneFolderName url - let startTime = System.DateTime.Now - let! refs = - Async.Parallel - ( - (git.RemoteRefs url - |> Async.Catch - |> Async.map(Choice.toOption >> Option.defaultValue([]))), - (git.RemoteRefs cacheDir - |> Async.Catch - |> Async.map(Choice.toOption >> Option.defaultValue([]))) - ) - |> Async.map(fun (a, b) -> - if a.Length = 0 && b.Length = 0 then - raise <| new SystemException("No internet connection and the cache is empty") - else if a.Length > 0 - then a - else b - ) - refsCache <- refsCache |> Map.add url refs - let endTime = System.DateTime.Now - log((success "success ") + - (text "fetched ") + - ((refs|>List.length).ToString() |> info) + - (text " refs in ") + - ((endTime-startTime).TotalSeconds.ToString("N3")|>info), LoggingLevel.Info) - return refs + let! res = mailboxCloneProcessor.PostAndAsyncReply(fun ch -> FetchRefs(url, ch)) + return! res } - member this.getFile (url : string) (revision : Revision) (file : string) : Async = + + member this.GetFile (url : string) (revision : Revision) (file : string) : Async = async { - let targetDirectory = cloneFolderName(url) - // TODO: preemptivly clone and fetch + let targetDirectory = cloneFolderName url + // TODO: Preemptively clone and fetch return! git.ReadFile targetDirectory revision file } diff --git a/buckaroo/InstallCommand.fs b/buckaroo/InstallCommand.fs index 24a7d66..930d4df 100644 --- a/buckaroo/InstallCommand.fs +++ b/buckaroo/InstallCommand.fs @@ -7,67 +7,15 @@ open Buckaroo open Buckaroo.BuckConfig open Buckaroo.Tasks open Buckaroo.Console +open Buckaroo.Logger open Buckaroo.RichOutput -type Logger = - { - Info : string -> Unit - Success : string -> Unit - Trace : string -> Unit - Warning : string -> Unit - Error : string -> Unit - } - -let private createLogger (console : ConsoleManager) = - let prefix = - "info " - |> text - |> foreground ConsoleColor.Blue - - let info (x : string) = - console.Write (prefix + x, LoggingLevel.Info) - - let prefix = - "success " - |> text - |> foreground ConsoleColor.Green - - let success (x : string) = - console.Write (prefix + x, LoggingLevel.Info) - - let trace (x : string) = - console.Write (x, LoggingLevel.Trace) - - let prefix = - "warning " - |> text - |> foreground ConsoleColor.Yellow - - let warning (x : string) = - console.Write (prefix + x, LoggingLevel.Info) - - let prefix = - "error " - |> text - |> foreground ConsoleColor.Red - - let error (x : string) = - console.Write (prefix + x, LoggingLevel.Info) - - { - Info = info; - Success = success; - Trace = trace; - Warning = warning; - Error = error; - } - let private fetchManifestFromLock (lock : Lock) (sourceExplorer : ISourceExplorer) (package : PackageIdentifier) = async { let location = match lock.Packages |> Map.tryFind package with | Some lockedPackage -> (lockedPackage.Location, lockedPackage.Versions) | None -> - new Exception("Lock file does not contain " + (PackageIdentifier.show package)) + Exception ("Lock file does not contain " + (PackageIdentifier.show package)) |> raise return! sourceExplorer.FetchManifest location @@ -230,7 +178,7 @@ let private compareReceipt logger installPath location = async { } let installPackageSources (context : Tasks.TaskContext) (installPath : string) (location : PackageLock) (versions : Set) = async { - let logger = createLogger context.Console + let logger = createLogger context.Console None let downloadManager = context.DownloadManager let gitManager = context.GitManager @@ -274,7 +222,7 @@ let installPackageSources (context : Tasks.TaskContext) (installPath : string) ( if discoveredHash <> sha256 then return - new Exception("Hash mismatch for " + http.Url + "! Expected " + sha256 + "but found " + discoveredHash) + Exception("Hash mismatch for " + http.Url + "! Expected " + sha256 + "but found " + discoveredHash) |> raise do! Files.deleteDirectoryIfExists installPath |> Async.Ignore do! Files.mkdirp installPath @@ -468,7 +416,7 @@ let writeTopLevelFiles (context : Tasks.TaskContext) (root : string) (lock : Loc } let task (context : Tasks.TaskContext) = async { - let logger = createLogger context.Console + let logger = createLogger context.Console None logger.Info "Installing packages..." diff --git a/buckaroo/Logger.fs b/buckaroo/Logger.fs new file mode 100644 index 0000000..eb4f02a --- /dev/null +++ b/buckaroo/Logger.fs @@ -0,0 +1,83 @@ +module Buckaroo.Logger + +open System +open Buckaroo.Console +open Buckaroo.RichOutput + +type Logger = + { + Info : string -> Unit + RichInfo : RichOutput -> Unit + Success : string -> Unit + RichSuccess : RichOutput -> Unit + Trace : string -> Unit + Warning : string -> Unit + RichWarning : RichOutput -> Unit + Error : string -> Unit + RichError : RichOutput -> Unit + } + +let createLogger (console : ConsoleManager) (componentName : string option) = + let componentPrefix = + componentName + |> Option.map (fun x -> "[" + x + "] " |> text |> foreground ConsoleColor.DarkGray) + |> Option.defaultValue (text "") + + let prefix = + "info " + |> text + |> foreground ConsoleColor.Blue + + let info (x : string) = + console.Write (componentPrefix + prefix + x, LoggingLevel.Info) + + let richInfo (x : RichOutput) = + console.Write (componentPrefix + prefix + x, LoggingLevel.Info) + + let prefix = + "success " + |> text + |> foreground ConsoleColor.Green + + let success (x : string) = + console.Write (componentPrefix + prefix + x, LoggingLevel.Info) + + let richSuccess (x : RichOutput) = + console.Write (componentPrefix + prefix + x, LoggingLevel.Info) + + let trace (x : string) = + console.Write (componentPrefix + x, LoggingLevel.Trace) + + let prefix = + "warning " + |> text + |> foreground ConsoleColor.Yellow + + let warning (x : string) = + console.Write (componentPrefix + prefix + x, LoggingLevel.Info) + + let richWarning (x : RichOutput) = + console.Write (componentPrefix + prefix + x, LoggingLevel.Info) + + let prefix = + "error " + |> text + |> foreground ConsoleColor.Red + + let error (x : string) = + console.Write (componentPrefix + prefix + x, LoggingLevel.Info) + + let richError (x : RichOutput) = + console.Write (componentPrefix + prefix + x, LoggingLevel.Info) + + { + Info = info + RichInfo = richInfo + Success = success + RichSuccess = richSuccess + Trace = trace + Warning = warning + RichWarning = richWarning + Error = error + RichError = richError + } diff --git a/buckaroo/Resolution.fs b/buckaroo/Resolution.fs index 6b658a4..3d0676f 100644 --- a/buckaroo/Resolution.fs +++ b/buckaroo/Resolution.fs @@ -8,28 +8,10 @@ type ResolutionStyle = | Quick | Upgrading -type NotSatisfiable = { - Package : PackageIdentifier - Constraint : Constraint - Msg : string -} with - override this.ToString () = - (string this.Constraint) + - " cannot be satisfied for " + (string this.Package) + - " because: " + this.Msg - - -type Resolution = -| Conflict of Set -| Backtrack of Solution * NotSatisfiable -| Avoid of Solution * NotSatisfiable -| Error of System.Exception -| Ok of Solution - module Solution = let empty = { - Resolutions = Map.empty; + Resolutions = Map.empty } type SolutionMergeError = @@ -66,33 +48,3 @@ module Solution = ) |> String.concat "\n" f solution 0 - -module Resolution = - let show resolution = - match resolution with - | Conflict xs -> - "Conflict! " + - ( - xs - |> Seq.map (fun (d, v) -> (Dependency.show d) + "->" + (Version.show v)) - |> String.concat " " - ) - | Backtrack (_, f) -> f.ToString() - | Avoid (_, e) -> "Error! " + e.ToString() - | Error e -> "Error! " + e.Message - | Ok solution -> "Success! " + (Solution.show solution) - - let merge (a : Resolution) (b : Resolution) : Resolution = - match (a, b) with - | (Backtrack _, _) -> a - | (_, Backtrack _) -> b - | (Avoid _, _) -> a - | (_, Avoid _) -> b - | (Conflict _, _) -> a - | (_, Conflict _) -> b - | (Error _, _) -> a - | (_, Error _) -> b - | (Ok x, Ok y) -> - match Solution.merge x y with - | Result.Ok z -> Ok z - | Result.Error _ -> Resolution.Conflict (set []) // TODO \ No newline at end of file diff --git a/buckaroo/ResolveCommand.fs b/buckaroo/ResolveCommand.fs index e0b0673..bd1a630 100644 --- a/buckaroo/ResolveCommand.fs +++ b/buckaroo/ResolveCommand.fs @@ -2,25 +2,19 @@ module Buckaroo.ResolveCommand open System open Buckaroo.RichOutput +open Buckaroo.Logger +open Buckaroo.SearchStrategy let task (context : Tasks.TaskContext) partialSolution resolutionStyle = async { - let log (x : RichOutput) = context.Console.Write x - - let logInfo (x : RichOutput) = - ("info " |> text |> foreground ConsoleColor.Blue) + x - |> log - - let logError (x : RichOutput) = - ("error " |> text |> foreground ConsoleColor.Red) + x - |> log + let logger = createLogger context.Console None let! maybeLock = async { try return! Tasks.readLockIfPresent with error -> - logError ("The existing lock-file is invalid. " |> text) - logInfo ( + logger.Error "The existing lock-file is invalid. " + logger.RichInfo ( (text "Perhaps you want to delete ") + (text "buckaroo.lock.toml" |> foreground ConsoleColor.Magenta) + (text " and try again?") @@ -35,7 +29,7 @@ let task (context : Tasks.TaskContext) partialSolution resolutionStyle = async { let resolve = async { let resolveStart = DateTime.Now - logInfo <| (text "Resolve start: ") + (resolveStart |> Toml.formatDateTime |> text |> foreground ConsoleColor.Cyan) + logger.RichInfo <| (text "Resolve start: ") + (resolveStart |> Toml.formatDateTime |> text |> foreground ConsoleColor.Cyan) let styleName = match resolutionStyle with @@ -44,46 +38,34 @@ let task (context : Tasks.TaskContext) partialSolution resolutionStyle = async { |> text |> foreground ConsoleColor.Cyan - (text "Resolving dependencies using ") + (styleName) + " strategy... " |> logInfo + (text "Resolving dependencies using ") + (styleName) + " strategy... " |> logger.RichInfo - let! resolution = Solver.solve context partialSolution manifest resolutionStyle maybeLock + let! resolution = + Solver.solve context partialSolution manifest resolutionStyle maybeLock let resolveEnd = DateTime.Now - logInfo <| (text "Resolve end: ") + (resolveEnd |> Toml.formatDateTime |> text |> foreground ConsoleColor.Cyan) - logInfo <| (text "Resolve time: ") + (resolveEnd - resolveStart |> string |> text |> foreground ConsoleColor.Cyan) + logger.RichInfo <| (text "Resolve end: ") + (resolveEnd |> Toml.formatDateTime |> text |> foreground ConsoleColor.Cyan) + logger.RichInfo <| (text "Resolve time: ") + (resolveEnd - resolveStart |> string |> text |> foreground ConsoleColor.Cyan) match resolution with - | Resolution.Backtrack (_, f) -> - "Error! " |> text |> foreground ConsoleColor.Red |> log - f.Constraint.ToString() + " for " + f.Package.ToString() + " coudn't be satisfied because: " + f.Msg - |> string |> text |> log - | Resolution.Avoid (_, f) -> - "Error! " |> text |> foreground ConsoleColor.Red |> log - f.Constraint.ToString() + " for " + f.Package.ToString() + " coudn't be satisfied because: " + f.Msg - |> string |> text |> log - | Resolution.Conflict x -> - "Conflict! " |> text |> foreground ConsoleColor.Red |> log - x |> string |> text |> log - - return () - | Resolution.Error e -> - "Error! " |> text |> foreground ConsoleColor.Red |> log - e |> string |> text |> log - return () - | Resolution.Ok solution -> - "Success! " |> text |> foreground ConsoleColor.Green |> log + | Result.Error e -> + (SearchStrategyError.show e) |> logger.RichError + | Result.Ok solution -> + "A solution to the constraints was found" |> text |> logger.RichSuccess let lock = Lock.fromManifestAndSolution manifest solution try let! previousLock = Tasks.readLock let diff = Lock.showDiff previousLock lock - diff |> text |> log + diff |> text |> logger.RichInfo with _ -> () do! Tasks.writeLock lock + "The lock-file was updated" |> text |> logger.RichSuccess + return () } @@ -91,7 +73,7 @@ let task (context : Tasks.TaskContext) partialSolution resolutionStyle = async { | (Quick, Some lock) -> if lock.ManifestHash = Manifest.hash manifest then - logInfo <| (text "The existing lock-file is already up-to-date! ") + logger.RichInfo <| (text "The existing lock-file is already up-to-date! ") return () else diff --git a/buckaroo/RichOutput.fs b/buckaroo/RichOutput.fs index a161cf8..b8973f6 100644 --- a/buckaroo/RichOutput.fs +++ b/buckaroo/RichOutput.fs @@ -39,6 +39,19 @@ type RichOutput = Segments = a.Segments @ b.Segments } + static member (+) (a : string, b : RichOutput) = + { + b with + Segments = + [ + { + Foreground = None + Background = None + Text = a + } + ] @ b.Segments + } + let zero = [] let length richOutput = diff --git a/buckaroo/SearchStrategy.fs b/buckaroo/SearchStrategy.fs new file mode 100644 index 0000000..cf01df0 --- /dev/null +++ b/buckaroo/SearchStrategy.fs @@ -0,0 +1,54 @@ +module Buckaroo.SearchStrategy + +type PackageConstraint = PackageIdentifier * Set + +type LocatedVersionSet = PackageLocation * Set + +type SearchStrategyError = +| LimitReached of PackageConstraint * int +| Unresolvable of PackageConstraint +| NoManifest of PackageIdentifier +| NoPrivateSolution of PackageIdentifier +| TransitiveConflict of Set * SearchStrategyError> + +module SearchStrategyError = + + open System + open Buckaroo.RichOutput + + let private showPackage p = + p + |> PackageIdentifier.show + |> text + |> foreground ConsoleColor.Blue + + let private showConstraint c = + c + |> Constraint.simplify + |> Constraint.show + |> text + |> foreground ConsoleColor.Blue + + let rec show (e : SearchStrategyError) = + match e with + | LimitReached ((p, c), l) -> + "We reached the limit of " + (string l) + " consecutive failures for " + + (showPackage p) + " at " + + (showConstraint (All c)) + ". " + | Unresolvable (p, c) -> + "The package " + (showPackage p) + " at " + (showConstraint (All c)) + " is unresolvable. " + | NoManifest p -> "We could not find any manifests for " + (showPackage p) + ". " + | NoPrivateSolution p -> + "We could not resolve a private dependency for " + (showPackage p) + "." + | TransitiveConflict xs -> + (text "We had the following conflicts: ") + + ( + xs + |> Seq.collect (fun (cores, reason) -> + cores + |> Seq.map (fun core -> + ("<" + (core |> string) + "> because " |> text) + (show reason) + ) + ) + |> RichOutput.concat (text ", ") + ) \ No newline at end of file diff --git a/buckaroo/Solver.fs b/buckaroo/Solver.fs index a7d825f..3830dc6 100644 --- a/buckaroo/Solver.fs +++ b/buckaroo/Solver.fs @@ -1,244 +1,225 @@ -namespace Buckaroo +module Buckaroo.Solver +open FSharp.Control open FSharpx.Collections open Buckaroo.Tasks open Buckaroo.Console -open RichOutput -open FSharp.Control +open Buckaroo.RichOutput +open Buckaroo.Logger +open Buckaroo.Constants open Buckaroo.Constraint +open Buckaroo.Result +open Buckaroo.SearchStrategy + +type LocatedAtom = Atom * PackageLock + +type Constraints = Map> + +type ResolutionPath = +| Root of Manifest +| Node of PackageIdentifier * Set * ResolvedVersion + +type SolverState = { + Locations : Map + Root : Set + Selections : Map + Hints : Map> +} + +type ResolutionRequest = +| MarkBadPath of List * PackageConstraint * SearchStrategyError * AsyncReplyChannel +| ProposeCandidates of Constraints * PackageConstraint * seq * AsyncReplyChannel>> +| GetCandidates of Constraints * PackageConstraint * PackageSources * AsyncReplyChannel>> + + +let private ifError x = + match x with + | Result.Error e -> Some e + | _ -> None + +let private ifOk x = + match x with + | Result.Ok v -> Some v + | _ -> None + +let private resultOrDefaultWith f x = + match x with + | Result.Ok v -> v + | Result.Error e -> f e + +let toDnf c = + let d = simplify c + match d with + | All xs -> xs + | _ -> Set [ d ] + +let toPackageConstraint (dep : Dependency) : PackageConstraint = + (dep.Package, toDnf dep.Constraint) + +let constraintsOf (ds: seq) = + ds + |> Seq.groupBy fst + |> Seq.map (fun (k, xs) -> (k, xs |> Seq.map snd |> Set.unionMany)) + |> Map.ofSeq + +let constraintsOfSelection selections = + Map.valueList selections + |> Seq.map ( + (fun m -> m.Manifest.Dependencies) >> + (Set.map toPackageConstraint) + ) + |> Seq.fold Set.union Set.empty + |> constraintsOf + +let pruneSelections (selections: Map) (deps: Set) = + let rec loop (visited: Set) (deps: Set) : seq = seq { + let notVisited = + deps + |> Seq.filter (fun d -> visited |> Set.contains d.Package |> not) + |> Seq.toList + + if notVisited |> List.isEmpty + then () + else + let nextVisited = deps |> Seq.map (fun d -> d.Package) |> Set |> Set.union visited -module Solver = - - open FSharp.Control - open Buckaroo.Result - - [] - let MaxConsecutiveFailures = 10 - - type LocatedAtom = Atom * PackageLock - - type Constraints = Map> + yield! + notVisited + |> Seq.filter (fun d -> selections |> Map.containsKey d.Package) + |> Seq.map (fun d -> (d.Package, selections.[d.Package])) - type ResolutionPath = - | Root of Manifest - | Node of PackageIdentifier * Set * ResolvedVersion + let next = + notVisited + |> Seq.choose (fun d -> selections |> Map.tryFind d.Package) + |> Seq.fold (fun deps (rv, _) -> Set.union rv.Manifest.Dependencies deps) Set.empty - type SolverState = { - Locations : Map - Root : Set - Selections : Map - Hints : Map> + yield! loop nextVisited next } - type PackageConstraint = PackageIdentifier * Set - - type LocatedVersionSet = PackageLocation * Set - - type SearchStrategyError = - | LimitReached of PackageConstraint - | Unresolvable of PackageConstraint - | TransitiveConflict of Set * SearchStrategyError - | Conflicts of Set - | NoManifest - | NoPrivateSolution - - type ResolutionRequest = - | MarkBadPath of List * PackageConstraint * SearchStrategyError * AsyncReplyChannel - | ProposeCandidates of Constraints * PackageConstraint * seq * AsyncReplyChannel>> - | GetCandidates of Constraints * PackageConstraint * PackageSources * AsyncReplyChannel>> + loop Set.empty deps |> Map.ofSeq - type SearchStrategy = ISourceExplorer -> SolverState -> AsyncSeq> +let isUnresolved (selections : Map) (constraints : Map>) (dep : Dependency) = + let c = constraints.[dep.Package] |> All |> Constraint.simplify + selections + |> Map.tryFind dep.Package + |> Option.map fst + |> Option.map (fun rv -> rv.Versions |> Constraint.satisfies c |> not) + |> Option.defaultValue true - let private ifError x = - match x with - | Result.Error e -> Some e - | _ -> None - - let private ifOk x = - match x with - | Result.Ok v -> Some v - | _ -> None - - let private resultOrDefaultWith f x = - match x with - | Result.Ok v -> v - | Result.Error e -> f e - - let toDnf c = - match c with - | All xs -> xs - | _ -> Set [c] - - let toPackageConstraint (dep : Dependency) : PackageConstraint = - (dep.Package, toDnf dep.Constraint) - - let constraintsOf (ds: seq) = - ds - |> Seq.groupBy fst - |> Seq.map (fun (k, xs) -> (k, xs |> Seq.map snd |> Set.unionMany)) - |> Map.ofSeq - - let constraintsOfSelection selections = +let findUnresolved pick (selections: Map) (deps: Set) = + let constraints = Map.valueList selections - |> Seq.map (fun m -> m.Manifest.Dependencies) - |> Seq.map (Set.map toPackageConstraint) - |> Seq.fold Set.union Set.empty - |> constraintsOf - - - let pruneSelections (selections: Map) (deps: Set) = - let rec loop (visited: Set) (deps: Set) : seq = seq { - let notVisited = - deps - |> Seq.filter (fun d -> visited |> Set.contains d.Package |> not) - |> Seq.toList - - if notVisited |> List.isEmpty - then () - else - let nextVisited = deps |> Seq.map (fun d -> d.Package) |> Set |> Set.union visited - - yield! - notVisited - |> Seq.filter (fun d -> selections |> Map.containsKey d.Package) - |> Seq.map (fun d -> (d.Package, selections.[d.Package])) - - let next = - notVisited - |> Seq.choose (fun d -> selections |> Map.tryFind d.Package) - |> Seq.fold (fun deps (rv, _) -> Set.union rv.Manifest.Dependencies deps) Set.empty - - yield! loop nextVisited next - } - - loop Set.empty deps |> Map.ofSeq - - let isUnresolved (selections : Map) (constraints : Map>) (dep : Dependency) = - let c = constraints.[dep.Package] |> All |> Constraint.simplify - selections - |> Map.tryFind dep.Package - |> Option.map fst - |> Option.map (fun rv -> rv.Versions |> Constraint.satisfies c |> not) - |> Option.defaultValue true + |> Seq.map fst + |> Seq.map (fun m -> m.Manifest.Dependencies) + |> Seq.map (Set.map toPackageConstraint) + |> Seq.fold Set.union (deps |> Set.map toPackageConstraint) + |> constraintsOf + + let rec loop (visited: Set) (deps: Set) : seq> = seq { + let notVisited = + deps + |> Seq.filter (fun d -> visited |> Set.contains d.Package |> not) + |> Seq.toList + + if notVisited |> List.isEmpty + then () + else + let nextVisited = deps |> Seq.map (fun d -> d.Package) |> Set |> Set.union visited - let findUnresolved pick (selections: Map) (deps: Set) = - let constraints = - Map.valueList selections - |> Seq.map fst - |> Seq.map (fun m -> m.Manifest.Dependencies) - |> Seq.map (Set.map toPackageConstraint) - |> Seq.fold Set.union (deps |> Set.map toPackageConstraint) - |> constraintsOf + let next = + notVisited + |> Seq.choose (fun d -> selections |> Map.tryFind d.Package) + |> Seq.map fst + |> Seq.fold (fun deps m -> Set.union m.Manifest.Dependencies deps) Set.empty - let rec loop (visited: Set) (deps: Set) : seq> = seq { - let notVisited = - deps - |> Seq.filter (fun d -> visited |> Set.contains d.Package |> not) - |> Seq.toList - - if notVisited |> List.isEmpty - then () - else - let nextVisited = deps |> Seq.map (fun d -> d.Package) |> Set |> Set.union visited - - let next = - notVisited - |> Seq.choose (fun d -> selections |> Map.tryFind d.Package) - |> Seq.map fst - |> Seq.fold (fun deps m -> Set.union m.Manifest.Dependencies deps) Set.empty - - yield! - pick - (notVisited - |> Seq.filter (isUnresolved selections constraints) - |> Seq.map (fun d -> (d.Package, constraints.[d.Package]))) - (loop nextVisited next) - } + yield! + pick + (notVisited + |> Seq.filter (isUnresolved selections constraints) + |> Seq.map (fun d -> (d.Package, constraints.[d.Package]))) + (loop nextVisited next) + } - loop Set.empty deps + loop Set.empty deps - let breathFirst = findUnresolved (fun a b -> seq { - yield! a - yield! b - }) +let breathFirst = findUnresolved (fun a b -> seq { + yield! a + yield! b +}) - let depthFirst = findUnresolved (fun a b -> seq { - yield! b - yield! a - }) +let depthFirst = findUnresolved (fun a b -> seq { + yield! b + yield! a +}) - let fetchCandidatesForConstraint sourceExplorer locations p c = asyncSeq { - let candidatesToExplore = SourceExplorer.fetchLocationsForConstraint sourceExplorer locations p c +let fetchCandidatesForConstraint sourceExplorer locations p c = asyncSeq { + let candidatesToExplore = SourceExplorer.fetchLocationsForConstraint sourceExplorer locations p c - let mutable hasCandidates = false - let mutable branchFailures = Map.empty + let mutable hasCandidates = false + let mutable branchFailures = Map.empty - for x in candidatesToExplore do - if branchFailures |> Map.exists (fun _ v -> v > MaxConsecutiveFailures) then - let d = (p, Set [c]) - yield - LimitReached d - |> Result.Error - else - yield! - match x with - | Candidate (packageLocation, c) -> asyncSeq { - let branches = - c - |> Seq.choose (fun v -> - match v with - | Version.Git (Branch b) -> Some b - | _ -> None - ) - - try - let! lock = sourceExplorer.LockLocation packageLocation - do! sourceExplorer.FetchManifest (lock, c) |> Async.Ignore - yield Result.Ok (p, (packageLocation, c)) - - hasCandidates <- true - - for branch in branches do - branchFailures <- - branchFailures - |> Map.add branch 0 - - with _ -> - for branch in branches do - branchFailures <- - branchFailures - |> Map.insertWith (fun i j -> i + j + 1) branch 0 - } - | FetchResult.Unsatisfiable (All xs) -> asyncSeq { - let d = (p, Set xs) - yield d |> Unresolvable |> Result.Error - } - | FetchResult.Unsatisfiable u -> asyncSeq { - let d = (p, Set[u]) - yield d |> Unresolvable |> Result.Error - } - - if hasCandidates = false - then - let d = (p, Set [c]) + for x in candidatesToExplore do + if branchFailures |> Map.exists (fun _ v -> v > MaxConsecutiveFailures) then + let d = (p, Set [ c ]) yield - Unresolvable d + LimitReached (d, MaxConsecutiveFailures) |> Result.Error - } - - - let resolutionManager (sourceExplorer : ISourceExplorer) : MailboxProcessor = MailboxProcessor.Start(fun inbox -> async { + else + yield! + match x with + | Candidate (packageLocation, c) -> asyncSeq { + let branches = + c + |> Seq.choose (fun v -> + match v with + | Version.Git (Branch b) -> Some b + | _ -> None + ) + + try + let! lock = sourceExplorer.LockLocation packageLocation + do! sourceExplorer.FetchManifest (lock, c) |> Async.Ignore + yield Result.Ok (p, (packageLocation, c)) + + hasCandidates <- true + + for branch in branches do + branchFailures <- + branchFailures + |> Map.add branch 0 + + with _ -> + for branch in branches do + branchFailures <- + branchFailures + |> Map.insertWith (fun i j -> i + j + 1) branch 0 + } + | FetchResult.Unsatisfiable (All xs) -> asyncSeq { + let d = (p, Set xs) + yield d |> Unresolvable |> Result.Error + } + | FetchResult.Unsatisfiable u -> asyncSeq { + let d = (p, Set[u]) + yield d |> Unresolvable |> Result.Error + } + + if not hasCandidates + then + let d = (p, Set [c]) + yield + Unresolvable d + |> Result.Error +} + + +let resolutionManager (sourceExplorer : ISourceExplorer) : MailboxProcessor = + MailboxProcessor.Start(fun inbox -> async { let mutable unresolvableCores : Map, SearchStrategyError> = Map.empty let mutable underconstraintDeps : Set = Set.empty let mutable world : Map>> = Map.empty let findBadCores (constraints : Constraints) = - let deps = - constraints - |> Map.toSeq - |> Set - unresolvableCores |> Map.toSeq |> Seq.filter (fun (core, _) -> @@ -257,29 +238,35 @@ module Solver = System.Console.WriteLine "&&&&&" System.Console.WriteLine "----------" - let trackLocal locations (p, cs) = asyncSeq { + let trackLocal locations (p, cs) constraintsContext = asyncSeq { let mutable hadCandidate = false - let c = cs |> All |> Constraint.simplify + let c = cs |> All |> Constraint.simplify - let conflicts = findBadCores (Map.ofSeq [(p, cs)]) |> Seq.tryHead + let conflicts = findBadCores (Map.ofSeq [ (p, cs) ]) |> Seq.tryHead match conflicts with | Some (dep, _) -> yield Result.Error (Unresolvable dep.MinimumElement) | None -> - for candidate in fetchCandidatesForConstraint sourceExplorer locations p c do + let candidates = + fetchCandidatesForConstraint sourceExplorer locations p c + |> AsyncSeq.takeWhile (fun _ -> + findBadCores constraintsContext |> Seq.isEmpty + ) + + for candidate in candidates do match candidate with | Result.Error (Unresolvable d) -> unresolvableCores <- (unresolvableCores |> Map.add (Set [d]) (Unresolvable d)) printCores() yield Result.Error <| Unresolvable d - | Result.Error (LimitReached d) -> - if hadCandidate <> false + | Result.Error (LimitReached (d, MaxConsecutiveFailures)) -> + if hadCandidate then underconstraintDeps <- (underconstraintDeps |> Set.add d) printCores() - yield Result.Error <| LimitReached d + yield Result.Error <| LimitReached (d, MaxConsecutiveFailures) | Result.Ok (_, (location, versions)) -> let! lock = sourceExplorer.LockLocation location let! manifest = sourceExplorer.FetchManifest (lock, versions) @@ -287,7 +274,10 @@ module Solver = manifest.Dependencies |> Set.map (fun d -> (d.Package, d.Constraint |> toDnf)) - world <- (world |> Map.insertWith Set.union (p, cs) (Set [packageConstraints])) + world <- ( + world + |> Map.insertWith Set.union (p, cs) (Set [packageConstraints]) + ) let conflicts = manifest.Dependencies @@ -295,51 +285,50 @@ module Solver = |> constraintsOf |> Map.insertWith Set.union p cs |> findBadCores - |> Seq.map TransitiveConflict |> Set - if conflicts |> Set.isEmpty then hadCandidate <- true yield candidate else - yield Result.Error (Conflicts conflicts) + yield Result.Error (TransitiveConflict conflicts) | _ -> () + + } - let trackGlobal (constraints: Constraints) (candidates: AsyncSeq>) = asyncSeq { - for candidate in candidates do - match candidate with - | Result.Error e -> - yield Result.Error e - | Result.Ok (_, (location, versions)) -> - let! lock = sourceExplorer.LockLocation location - let! manifest = sourceExplorer.FetchManifest (lock, versions) - let conflicts = - manifest.Dependencies - |> Seq.map toPackageConstraint - |> Seq.append (constraints |> Map.toSeq) - |> constraintsOf - |> findBadCores - |> Seq.map TransitiveConflict - |> Set - - if conflicts |> Set.isEmpty - then - yield candidate - else - yield Result.Error (Conflicts conflicts) + let trackGlobal (constraints : Constraints) (candidates : AsyncSeq>) = + asyncSeq { + for candidate in candidates do + match candidate with + | Result.Error e -> + yield Result.Error e + | Result.Ok (_, (location, versions)) -> + let! lock = sourceExplorer.LockLocation location + let! manifest = sourceExplorer.FetchManifest (lock, versions) + let conflicts = + manifest.Dependencies + |> Seq.map toPackageConstraint + |> Seq.append (constraints |> Map.toSeq) + |> constraintsOf + |> findBadCores + |> Set + + if Set.isEmpty conflicts + then + yield candidate + else + yield Result.Error (TransitiveConflict conflicts) + () () - () - } + } let depsFromPath p = match p with | Root m -> Set.union m.Dependencies m.PrivateDependencies | Node (_, _, rv) -> rv.Manifest.Dependencies - while true do let! req = inbox.Receive() match req with @@ -356,11 +345,11 @@ module Solver = |> constraintsOf |> Map.insertWith Set.union p cs |> findBadCores - |> Seq.map TransitiveConflict + |> Seq.map (Set.singleton >> TransitiveConflict) if conflicts |> Seq.isEmpty |> not then - return Result.Error NoManifest // TODO ... + return Result.Error (NoManifest p) // TODO ... else let rv: ResolvedVersion = { Manifest = manifest @@ -369,373 +358,371 @@ module Solver = } return Result.Ok rv with _ -> - return Result.Error NoManifest + return Result.Error (NoManifest p) }) |> AsyncSeq.filter (fun x -> match x with | Result.Error _ -> false - | _ -> true) - |> AsyncSeq.takeWhile(fun e -> - match e with - | _ -> findBadCores constraints |> Seq.isEmpty) + | _ -> true + ) + |> AsyncSeq.takeWhile (fun _ -> + findBadCores constraints |> Seq.isEmpty + ) |> channel.Reply - | GetCandidates (constraints, dep, locations, channel) -> - trackLocal locations dep - |> AsyncSeq.takeWhile(fun e -> - match e with - | _ -> findBadCores constraints |> Seq.isEmpty) + trackLocal locations dep constraints |> trackGlobal constraints |> channel.Reply | MarkBadPath (path, failedDep, error, channel) -> match error with - | Conflicts conflicts -> - for (_, p, bs) in conflicts - |> Seq.choose(fun x -> - match x with - | TransitiveConflict (failedCore , Unresolvable (p, cs)) -> Some (failedCore, p, cs) - | _ -> None) do - - let contributions = - match world |> Map.tryFind failedDep with - | None -> - Set.empty - | Some buckets -> - buckets - |> Set.map(fun deps -> - deps - |> Seq.filter (fun (q, _) -> p = q) - |> Seq.map (fun (_, cs) -> cs) - |> Set.unionMany) - - for contrib in contributions do - let core = - path - |> Seq.filter (fun x -> - match x with - | Node (q, _, _) -> p <> q - | _ -> true) - |> Seq.map depsFromPath - |> Seq.map (fun deps -> - deps - |> Seq.map (fun x -> (x.Package, x.Constraint |> toDnf)) - |> Seq.filter (fun (q, cs) -> p = q && cs <> contrib) - |> Seq.filter (fun (_, cs) -> Set.isProperSubset cs bs) // should be an intersection? - |> Seq.map (fun (q, cs) -> (q, Set.difference cs contrib)) - |> Seq.filter (fun (_, cs) -> cs.IsEmpty |> not) - |> Set) - |> Set.unionMany - |> Set.add failedDep - - unresolvableCores <- unresolvableCores |> Map.add core (SearchStrategyError.Unresolvable (p, bs)) - printCores() + | TransitiveConflict conflicts -> + let unresolvables = + conflicts + |> Seq.choose (fun (_, e) -> + match e with + | Unresolvable (p, bs) -> Some (p, bs) + | _ -> None + ) + + for (p, bs) in unresolvables do + let contributions = + match world |> Map.tryFind failedDep with + | None -> + Set.empty + | Some buckets -> + buckets + |> Set.map(fun deps -> + deps + |> Seq.filter (fun (q, _) -> p = q) + |> Seq.map (fun (_, cs) -> cs) + |> Set.unionMany) + + for contrib in contributions do + let core = + path + |> Seq.filter (fun x -> + match x with + | Node (q, _, _) -> p <> q + | _ -> true) + |> Seq.map (depsFromPath >> + ( + fun deps -> + deps + |> Seq.map (fun x -> (x.Package, x.Constraint |> toDnf)) + |> Seq.filter (fun (q, cs) -> p = q && cs <> contrib) + |> Seq.filter (fun (_, cs) -> Set.isProperSubset cs bs) // TODO: should be an intersection? + |> Seq.map (fun (q, cs) -> (q, Set.difference cs contrib)) + |> Seq.filter (fun (_, cs) -> cs.IsEmpty |> not) + |> Set + ) + ) + |> Set.unionMany + |> Set.add failedDep + + unresolvableCores <- unresolvableCores |> Map.add core (SearchStrategyError.Unresolvable (p, bs)) + printCores() | _ -> () channel.Reply () }) - let getHints (resolver: MailboxProcessor) state selections p cs = asyncSeq { - - let constraints = - selections - |> Map.valueList - |> Seq.map fst - |> Seq.map (fun m -> m.Manifest.Dependencies) - |> Seq.append [state.Root] - |> Seq.map (Set.map toPackageConstraint) - |> Set.unionMany - |> constraintsOf - - let c = cs |> All - let candidates = - state.Hints - |> Map.tryFind p - |> Option.defaultValue([]) - |> Seq.filter(fun lp -> lp.Versions |> Constraint.satisfies c) - |> Seq.distinct - +let getHints (resolver: MailboxProcessor) state selections p cs = asyncSeq { - let! request = resolver.PostAndAsyncReply (fun channel -> ProposeCandidates (constraints, (p, cs), candidates, channel)) - yield! request - } - - let fetchHints (sourceExplorer : ISourceExplorer) (state: SolverState) (resolvedVersion : ResolvedVersion) : Async = async { - try - let! lock = sourceExplorer.FetchLock (resolvedVersion.Lock, resolvedVersion.Versions) - let hints = - Seq.append - (state.Hints |> Map.toSeq) - (lock.Packages - |> Map.toSeq - |> Seq.map (fun (k, v) -> (k, [v]))) - |> Seq.groupBy fst - |> Seq.map (fun (k, vs) -> (k, vs |> Seq.map snd |> Seq.distinct |> List.concat)) - |> Map.ofSeq - - return { - state with Hints = hints - } - with _ -> - return state - } - - let collectPrivateHints (state : SolverState) (p : PackageIdentifier) = + let constraints = + selections + |> Map.valueList + |> Seq.map (fst >> (fun m -> m.Manifest.Dependencies)) + |> Seq.append [ state.Root ] + |> Seq.map (Set.map toPackageConstraint) + |> Set.unionMany + |> constraintsOf + + let c = All cs + let candidates = state.Hints |> Map.tryFind p |> Option.defaultValue [] - |> Seq.map (fun l -> l.PrivatePackages |> Map.toSeq) - |> Seq.collect id - |> Seq.groupBy fst - |> Seq.map (fun (k, vs) -> (k, vs |> Seq.map snd |> Seq.distinct |> Seq.map List.singleton |> List.concat)) - |> Map.ofSeq + |> Seq.filter (fun lp -> lp.Versions |> Constraint.satisfies c) + |> Seq.distinct + let! request = + resolver.PostAndAsyncReply + (fun channel -> + ProposeCandidates (constraints, (p, cs), candidates, channel)) - let getCandidates (resolver: MailboxProcessor) (sourceExplorer: ISourceExplorer) state selections p cs = asyncSeq { + yield! request +} - let constraints = - selections - |> Map.valueList - |> Seq.map fst - |> Seq.map (fun m -> m.Manifest.Dependencies) - |> Seq.append [state.Root] - |> Seq.map (Set.map toPackageConstraint) - |> Set.unionMany - |> constraintsOf - - let manifests = - selections - |> Map.valueList - |> Seq.map fst - |> Seq.map (fun rv -> rv.Manifest) - |> Seq.toList +let fetchHints (sourceExplorer : ISourceExplorer) (state: SolverState) (resolvedVersion : ResolvedVersion) : Async = async { + try + let! lock = + sourceExplorer.FetchLock + (resolvedVersion.Lock, resolvedVersion.Versions) - let locations = - manifests - |> Seq.map (fun m -> m.Locations |> Map.toSeq) - |> Seq.fold Seq.append (state.Locations |> Map.toSeq) - |> Map.ofSeq + let hints = + Seq.append + (state.Hints |> Map.toSeq) + (lock.Packages + |> Map.toSeq + |> Seq.map (fun (k, v) -> (k, [v]))) + |> Seq.groupBy fst + |> Seq.map (fun (k, vs) -> (k, vs |> Seq.map snd |> Seq.distinct |> List.concat)) + |> Map.ofSeq + return { + state with Hints = hints + } + with _ -> + return state +} + +let collectPrivateHints (state : SolverState) (p : PackageIdentifier) = + state.Hints + |> Map.tryFind p + |> Option.defaultValue [] + |> Seq.map (fun l -> l.PrivatePackages |> Map.toSeq) + |> Seq.collect id + |> Seq.groupBy fst + |> Seq.map (fun (k, vs) -> (k, vs |> Seq.map snd |> Seq.distinct |> Seq.map List.singleton |> List.concat)) + |> Map.ofSeq + +let getCandidates (resolver: MailboxProcessor) (sourceExplorer: ISourceExplorer) state selections p cs = asyncSeq { - let! requested = - resolver.PostAndAsyncReply (fun channel -> GetCandidates (constraints, (p, cs), locations, channel)) + let constraints = + selections + |> Map.valueList + |> Seq.map (fst >> (fun m -> m.Manifest.Dependencies)) + |> Seq.append [ state.Root ] + |> Seq.map (Set.map toPackageConstraint) + |> Set.unionMany + |> constraintsOf - yield! requested - |> AsyncSeq.mapAsync(fun candidate -> async { - match candidate with - | Result.Error e -> - System.Console.WriteLine e - return Result.Error e - | Result.Ok (_, (location, versions)) -> - let! lock = sourceExplorer.LockLocation location - let! manifest = sourceExplorer.FetchManifest (lock, versions) - let resolvedVersion = { - Lock = lock - Versions = versions - Manifest = manifest - } + let manifests = + selections + |> Map.valueList + |> Seq.map (fst >> (fun rv -> rv.Manifest)) + |> Seq.toList + + let locations = + manifests + |> Seq.map (fun m -> m.Locations |> Map.toSeq) + |> Seq.fold Seq.append (state.Locations |> Map.toSeq) + |> Map.ofSeq + + let! requested = + resolver.PostAndAsyncReply + (fun channel -> + GetCandidates (constraints, (p, cs), locations, channel)) + + yield! + requested + |> AsyncSeq.mapAsync(fun candidate -> async { + match candidate with + | Result.Error e -> + return Result.Error e + | Result.Ok (_, (location, versions)) -> + let! lock = sourceExplorer.LockLocation location + let! manifest = sourceExplorer.FetchManifest (lock, versions) + let resolvedVersion = { + Lock = lock + Versions = versions + Manifest = manifest + } - return Result.Ok resolvedVersion - }) - |> AsyncSeq.distinctUntilChangedWith (fun prev next -> - match prev, next with - | (Result.Ok p), (Result.Ok n) -> - p.Manifest = n.Manifest // All revisions with an identical manifest will have the same outcome - | (_, _) -> prev = next) + return Result.Ok resolvedVersion + }) + |> AsyncSeq.distinctUntilChangedWith (fun prev next -> + match prev, next with + | (Result.Ok p), (Result.Ok n) -> + p.Manifest = n.Manifest // All revisions with an identical manifest will have the same outcome + | (_, _) -> prev = next + ) +} + +let zipState state clause = + Result.map (fun candidate -> (clause, state, candidate)) + >> Result.mapError(fun e -> (clause, e)) + +let mergeHint sourceExplorer next = async { + match next with + | Result.Ok (clause, state, rv) -> + let! nextState = fetchHints sourceExplorer state rv + return Result.Ok (clause, nextState, rv) + | Result.Error e -> return Result.Error e +} + +let quickStrategy resolver sourceExplorer state selections = asyncSeq { + let unresolved = breathFirst selections state.Root + + for (p, cs) in unresolved do + yield! + (AsyncSeq.append + (getHints resolver state selections p cs) + (getCandidates resolver sourceExplorer state selections p cs)) + |> AsyncSeq.map (zipState state (p, cs)) + |> AsyncSeq.mapAsync (mergeHint sourceExplorer) +} + +let upgradeStrategy resolver sourceExplorer state selections = asyncSeq { + let unresolved = breathFirst selections state.Root + + for (p, cs) in unresolved do + yield! + getCandidates resolver sourceExplorer state selections p cs + |> AsyncSeq.map (zipState state (p, cs)) +} + +let private privateStep step ((p, _), state, rv) = + let m = rv.Manifest + let privateState : SolverState = { + Hints = collectPrivateHints state p + Root = m.PrivateDependencies + Locations = state.Locations + Selections = Map.empty } - let zipState state clause = - id - >> Result.map (fun candidate -> (clause, state, candidate)) - >> Result.mapError(fun e -> (clause, e)) - - let mergeHint sourceExplorer next = async { - match next with - | Result.Ok (clause, state, rv) -> - let! nextState = fetchHints sourceExplorer state rv - return Result.Ok (clause, nextState, rv) - | Result.Error e -> return Result.Error e - } + (step privateState [ Root m ]) + |> AsyncSeq.choose ifOk + |> AsyncSeq.tryFirst - let quickStrategy resolver sourceExplorer state selections = asyncSeq { - let unresolved = breathFirst selections state.Root +let rec private step (context : TaskContext) (resolver : MailboxProcessor) strategy (state : SolverState) (path: List): AsyncSeq> = asyncSeq { + let log = createLogger context.Console (Some "solver") + let nextStep = step context resolver strategy - for (p, cs) in unresolved do - yield! - (AsyncSeq.append - (getHints resolver state selections p cs) - (getCandidates resolver sourceExplorer state selections p cs)) - |> AsyncSeq.map (zipState state (p, cs)) - |> AsyncSeq.mapAsync (mergeHint sourceExplorer) - } + let selections = pruneSelections state.Selections state.Root - let upgradeStrategy resolver sourceExplorer state selections = asyncSeq { - let unresolved = breathFirst selections state.Root + if breathFirst selections state.Root |> Seq.isEmpty + then + yield Result.Ok { Resolutions = selections } + else + let results = + asyncSeq { + let xs : AsyncSeq> = strategy state selections - for (p, cs) in unresolved do - yield! - getCandidates resolver sourceExplorer state selections p cs - |> AsyncSeq.map (zipState state (p, cs)) - } + for x in xs do + match x with + | Result.Ok ((p, cs), state, rv) -> + if path |> List.contains (Node (p, cs, rv)) |> not + then + let! privateSolution = privateStep nextStep ((p, cs), state, rv) - let private privateStep step ((p, _), state, rv) = - let m = rv.Manifest - let privateState : SolverState = { - Hints = collectPrivateHints state p - Root = m.PrivateDependencies - Locations = state.Locations - Selections = Map.empty - } + match privateSolution with + | None -> + yield Result.Error ((p, cs), NoPrivateSolution p) // TODO: propagate error + | Some ps -> + let node = Node (p, cs, rv) + let nextState = { + state with + Selections = selections |> Map.add p (rv, ps) + } + yield! nextStep nextState (node :: path) + | Result.Error e -> yield Result.Error e + } + |> AsyncSeq.cache + + yield! results - (step privateState [Root m]) + // Record bad path when no solution is found + let! solution = + results |> AsyncSeq.choose ifOk |> AsyncSeq.tryFirst - - let rec private step (context : TaskContext) (resolver : MailboxProcessor) strategy (state : SolverState) (path: List): AsyncSeq> = asyncSeq { - let sourceExplorer = context.SourceExplorer - let log = namespacedLogger context.Console ("solver") - let nextStep = step context resolver strategy - - let selections = pruneSelections state.Selections state.Root - System.Console.WriteLine ("path: ") - for (p, v) in path |> Seq.choose(fun x -> match x with | Node (p, cs, rv) -> Some (p, rv.Versions) | Root _-> None) do - context.Console.Write ( - (PackageIdentifier.showRich p) + subtle "@" - + (Version.showRichSet v) - + subtle " -> " - ) - - - if breathFirst selections state.Root |> Seq.isEmpty - then - yield Result.Ok {Resolutions = selections} - else - let results = - strategy state selections - |> AsyncSeq.choose ifOk - |> AsyncSeq.filter(fun ((p, cs), _, rv) -> path |> List.contains (Node (p, cs, rv)) |> not) - |> AsyncSeq.mapAsync (fun ((p, cs), state, rv) -> async { - let! privateSolution = privateStep nextStep ((p, cs), state, rv) - return - match privateSolution with - | None -> Result.Error ((p, cs), NoPrivateSolution) // TODO: propagate error - | Some ps -> - let node = Node (p, cs, rv) - let nextState = { - state with - Selections = selections |> Map.add p (rv, ps) - } - Result.Ok <| nextStep nextState (node :: path) - }) - |> AsyncSeq.collect (resultOrDefaultWith (AsyncSeq.singleton << Result.Error)) - |> AsyncSeq.cache - + match solution with + | Some _ -> () + | None -> let errors = results |> AsyncSeq.choose ifError |> AsyncSeq.distinctUntilChanged - let! solution = results |> AsyncSeq.choose ifOk |> AsyncSeq.tryFirst - match solution with - | Some _ -> () - | None -> - for ((p, cs), error) in errors do - System.Console.WriteLine error - do! resolver.PostAndAsyncReply (fun ch -> MarkBadPath (path, (p, cs), error, ch)) + for ((p, cs), error) in errors do + System.Console.WriteLine error + do! resolver.PostAndAsyncReply (fun ch -> MarkBadPath (path, (p, cs), error, ch)) +} - yield! results - } - - let solutionCollector resolutions = +let solutionCollector resolutions = async { + let! xs = resolutions - |> AsyncSeq.take (1024) - |> AsyncSeq.filter (fun x -> - match x with - | Ok _ -> true - | _ -> false) - |> AsyncSeq.take 1 + |> AsyncSeq.take 2048 + |> AsyncSeq.takeWhileInclusive (Result.isOk >> not) |> AsyncSeq.toListAsync - |> Async.RunSynchronously - |> List.tryHead - let solve (context : TaskContext) (partialSolution : Solution) (manifest : Manifest) (style : ResolutionStyle) (lock : Lock option) = async { - let hints = - lock - |> Option.map (fun l -> l.Packages |> (Map.map (fun _ v -> [v]))) - |> Option.defaultValue Map.empty - - let state = { - Root = Set.union - manifest.Dependencies - manifest.PrivateDependencies - Hints = hints - Selections = partialSolution.Resolutions - Locations = manifest.Locations - } - - let resolver = resolutionManager context.SourceExplorer + return + xs + |> List.tryLast + |> Option.defaultValue (Result.Error (TransitiveConflict Set.empty)) +} + +let solve (context : TaskContext) (partialSolution : Solution) (manifest : Manifest) (style : ResolutionStyle) (lock : Lock option) = async { + let hints = + lock + |> Option.map (fun l -> l.Packages |> (Map.map (fun _ v -> [ v ]))) + |> Option.defaultValue Map.empty + + let state = { + Root = Set.union + manifest.Dependencies + manifest.PrivateDependencies + Hints = hints + Selections = partialSolution.Resolutions + Locations = manifest.Locations + } - let strategy = - match style with - | Quick -> quickStrategy resolver context.SourceExplorer - | Upgrading -> upgradeStrategy resolver context.SourceExplorer + let resolver = resolutionManager context.SourceExplorer - let resolutions = - step context resolver strategy state [Root manifest] + let strategy = + match style with + | Quick -> quickStrategy resolver context.SourceExplorer + | Upgrading -> upgradeStrategy resolver context.SourceExplorer + let resolutions = + step context resolver strategy state [ Root manifest ] - let result = - resolutions - |> AsyncSeq.choose (fun s -> - match s with - | Result.Ok s -> Some s - | Result.Error e -> - System.Console.WriteLine e - None - ) - |> AsyncSeq.map Resolution.Ok - |> solutionCollector - |> Option.defaultValue (Set.empty |> Resolution.Conflict) + let! result = + resolutions + |> AsyncSeq.map (Result.mapError snd) + |> solutionCollector - context.Console.Write(string result, LoggingLevel.Trace) + context.Console.Write(string result, LoggingLevel.Trace) - return result - } + return result +} - let rec fromLock (sourceExplorer : ISourceExplorer) (lock : Lock) : Async = async { - let rec packageLockToSolution (locked : LockedPackage) : Async = async { - let! manifest = sourceExplorer.FetchManifest (locked.Location, locked.Versions) - let! resolutions = - locked.PrivatePackages - |> Map.toSeq - |> AsyncSeq.ofSeq - |> AsyncSeq.mapAsync (fun (k, lock) -> async { - let! solution = packageLockToSolution lock - return (k, solution) - }) - |> AsyncSeq.toListAsync - - let resolvedVersion : ResolvedVersion = { - Versions = locked.Versions; - Lock = locked.Location; - Manifest = manifest; - } +let rec fromLock (sourceExplorer : ISourceExplorer) (lock : Lock) : Async = async { + let rec packageLockToSolution (locked : LockedPackage) : Async = async { + let! manifest = sourceExplorer.FetchManifest (locked.Location, locked.Versions) + let! resolutions = + locked.PrivatePackages + |> Map.toSeq + |> AsyncSeq.ofSeq + |> AsyncSeq.mapAsync (fun (k, lock) -> async { + let! solution = packageLockToSolution lock + return (k, solution) + }) + |> AsyncSeq.toListAsync - return (resolvedVersion, { Resolutions = resolutions |> Map.ofSeq }) + let resolvedVersion : ResolvedVersion = { + Versions = locked.Versions; + Lock = locked.Location; + Manifest = manifest; } - let! resolutions = - lock.Packages - |> Map.toSeq - |> AsyncSeq.ofSeq - |> AsyncSeq.mapAsync(fun (package, lockedPakckage) -> async { - let! solution = lockedPakckage |> packageLockToSolution - return (package, solution) - }) - |> AsyncSeq.toListAsync + return (resolvedVersion, { Resolutions = resolutions |> Map.ofSeq }) + } - return { - Resolutions = resolutions |> Map.ofSeq - } + let! resolutions = + lock.Packages + |> Map.toSeq + |> AsyncSeq.ofSeq + |> AsyncSeq.mapAsync(fun (package, lockedPakckage) -> async { + let! solution = lockedPakckage |> packageLockToSolution + return (package, solution) + }) + |> AsyncSeq.toListAsync + + return { + Resolutions = resolutions |> Map.ofSeq } +} diff --git a/buckaroo/Tasks.fs b/buckaroo/Tasks.fs index c3bf969..9cd0593 100644 --- a/buckaroo/Tasks.fs +++ b/buckaroo/Tasks.fs @@ -31,10 +31,10 @@ let private getCachePath = async { } let getContext loggingLevel = async { - let consoleManager = new ConsoleManager(loggingLevel) + let consoleManager = ConsoleManager(loggingLevel) let! cachePath = getCachePath - let downloadManager = new DownloadManager(consoleManager, cachePath) + let downloadManager = DownloadManager(consoleManager, cachePath) let! hasGit = Bash.runBashSync "git" "version" ignore ignore @@ -92,9 +92,9 @@ let readLock = async { match Lock.parse content with | Result.Ok lock -> lock | Result.Error error -> - new Exception("Error reading lock file. " + error) |> raise + Exception("Error reading lock file. " + error) |> raise else - return new Exception("No lock file was found. Perhaps you need to run 'buckaroo resolve'?") |> raise + return Exception("No lock file was found. Perhaps you need to run 'buckaroo resolve'?") |> raise } let readLockIfPresent = async { diff --git a/buckaroo/buckaroo.fsproj b/buckaroo/buckaroo.fsproj index 180f80a..078e335 100644 --- a/buckaroo/buckaroo.fsproj +++ b/buckaroo/buckaroo.fsproj @@ -20,6 +20,7 @@ + @@ -43,6 +44,7 @@ + From a1d5847a64fb2689ef361c67fc0e943184132b8e Mon Sep 17 00:00:00 2001 From: njlr Date: Tue, 12 Mar 2019 17:06:52 +0000 Subject: [PATCH 18/25] * Improves CLI output * Adds prefetcher actor --- buckaroo-tests/Constraint.fs | 1 + buckaroo/Command.fs | 2 +- buckaroo/Constraint.fs | 25 ++++++++-- buckaroo/DefaultSourceExplorer.fs | 5 +- buckaroo/Manifest.fs | 1 - buckaroo/Prefetch.fs | 48 ++++++++++++++++++ buckaroo/QuickstartCommand.fs | 4 +- buckaroo/ResolveCommand.fs | 6 ++- buckaroo/SearchStrategy.fs | 11 +++-- buckaroo/Solver.fs | 57 +++++++++++----------- buckaroo/UpgradeCommand.fs | 81 ++++++++++++++----------------- buckaroo/buckaroo.fsproj | 1 + 12 files changed, 154 insertions(+), 88 deletions(-) create mode 100644 buckaroo/Prefetch.fs diff --git a/buckaroo-tests/Constraint.fs b/buckaroo-tests/Constraint.fs index b4c1e4a..83bf32d 100644 --- a/buckaroo-tests/Constraint.fs +++ b/buckaroo-tests/Constraint.fs @@ -100,6 +100,7 @@ let ``Constraint.simplify works correctly`` () = ("any(all(revision=aabbccddee))", "revision=aabbccddee"); ("all(any(revision=aabbccddee))", "revision=aabbccddee"); ("any(branch=master any(revision=aabbccddee))", "any(revision=aabbccddee branch=master)"); + ("any(all() revision=aabbccddee)", "any(revision=aabbccddee all())"); ] for (input, expected) in cases do let actual = diff --git a/buckaroo/Command.fs b/buckaroo/Command.fs index 27dd2c3..7e6c9c3 100644 --- a/buckaroo/Command.fs +++ b/buckaroo/Command.fs @@ -239,7 +239,7 @@ module Command = | Init -> init context | Help -> HelpCommand.task context | Version -> VersionCommand.task context - | Resolve style -> ResolveCommand.task context Solution.empty style + | Resolve style -> ResolveCommand.task context Solution.empty style |> Async.Ignore | Install -> InstallCommand.task context | Quickstart -> QuickstartCommand.task context | UpgradeDependencies dependencies -> UpgradeCommand.task context dependencies diff --git a/buckaroo/Constraint.fs b/buckaroo/Constraint.fs index 449d7cd..fa2c65a 100644 --- a/buckaroo/Constraint.fs +++ b/buckaroo/Constraint.fs @@ -68,6 +68,22 @@ module Constraint = | _ -> false ) + [] + let private MaxChanceOfSuccess = 1024 + + let rec chanceOfSuccess (x : Constraint) : int = + match x with + | Exactly (Version.Git (Revision _)) -> 1 + | Exactly (Version.Git (Tag _)) -> 2 + | Exactly (Version.SemVer _) -> 3 + | Range _ -> 4 + | Exactly (Version.Git (Branch _)) -> 5 + | Any xs -> xs |> Seq.map chanceOfSuccess |> Seq.append [ 0 ] |> Seq.sum + | All xs -> + (xs |> Seq.map chanceOfSuccess |> Seq.append [ 0 ] |> Seq.max) - + (xs |> Seq.map chanceOfSuccess |> Seq.append [ 0 ] |> Seq.sum) + | Complement x -> MaxChanceOfSuccess - (chanceOfSuccess x) + // TODO: Better Sorting!!!!! let rec compare (x : Constraint) (y : Constraint) : int = match (x, y) with @@ -124,7 +140,7 @@ module Constraint = | Complement (Complement x) -> x | Constraint.All xs -> match xs |> Set.toList with - | [x] -> x + | [ x ] -> x | xs -> xs |> Seq.collect (fun x -> @@ -132,13 +148,13 @@ module Constraint = | All xs -> xs | _ -> Set[ x ] ) - |> Seq.sort + |> Seq.sortDescending |> Seq.distinct |> Set |> Constraint.All | Constraint.Any xs -> match xs |> Set.toList with - | [x] -> x + | [ x ] -> x | xs -> xs |> Seq.collect (fun x -> @@ -146,11 +162,12 @@ module Constraint = | Any xs -> xs | _ -> Set[ x ] ) - |> Seq.sort + |> Seq.sortDescending |> Seq.distinct |> Set |> Constraint.Any | _ -> c + let next = iterate c if next = c then diff --git a/buckaroo/DefaultSourceExplorer.fs b/buckaroo/DefaultSourceExplorer.fs index 80de47a..cb75dfe 100644 --- a/buckaroo/DefaultSourceExplorer.fs +++ b/buckaroo/DefaultSourceExplorer.fs @@ -45,10 +45,10 @@ type DefaultSourceExplorer (console : ConsoleManager, downloadManager : Download | [ root ] -> return root | [] -> return - raise (new System.Exception("Strip prefix " + stripPrefix + " did not match any paths! ")) + raise (System.Exception("Strip prefix " + stripPrefix + " did not match any paths! ")) | _ -> return - raise (new System.Exception("Strip prefix " + stripPrefix + " matched multiple paths: " + (string roots))) + raise (System.Exception("Strip prefix " + stripPrefix + " matched multiple paths: " + (string roots))) | None -> return "" } @@ -189,7 +189,6 @@ type DefaultSourceExplorer (console : ConsoleManager, downloadManager : Download // TODO: Revisions? } - interface ISourceExplorer with member this.FetchVersions locations package = asyncSeq { diff --git a/buckaroo/Manifest.fs b/buckaroo/Manifest.fs index 8a6af0e..37a0655 100644 --- a/buckaroo/Manifest.fs +++ b/buckaroo/Manifest.fs @@ -29,7 +29,6 @@ type ManifestParseError = | Location of LocationParseError | ConflictingLocations of AdhocPackageIdentifier * PackageSource * PackageSource - module Manifest = open Buckaroo.Result diff --git a/buckaroo/Prefetch.fs b/buckaroo/Prefetch.fs new file mode 100644 index 0000000..d151df3 --- /dev/null +++ b/buckaroo/Prefetch.fs @@ -0,0 +1,48 @@ +module Buckaroo.Prefetch + +open FSharp.Control + +type private PrefetcherMessage = +| Completed +| Prefetch of PackageIdentifier + +type Prefetcher (sourceExplorer : ISourceExplorer, limit : int) = + let agent = MailboxProcessor.Start(fun inbox -> + let rec waiting () = + inbox.Scan (fun x -> + match x with + | Completed -> Some (working (limit - 1)) + | _ -> None + ) + and working inFlightCount = async { + while true do + let! message = inbox.Receive () + + return! + match message with + | Completed -> working (inFlightCount - 1) + | Prefetch package -> + async { + try + do! + sourceExplorer.FetchVersions Map.empty package + |> AsyncSeq.tryFirst + |> Async.Catch + |> Async.Ignore + + finally + inbox.Post (Completed) + } + |> Async.Start + + if inFlightCount < limit + then + working (inFlightCount + 1) + else + waiting () + } + + working 0 + ) + + member this.Prefetch (package) = agent.Post (Prefetch package) diff --git a/buckaroo/QuickstartCommand.fs b/buckaroo/QuickstartCommand.fs index 4fbe499..fa9a60d 100644 --- a/buckaroo/QuickstartCommand.fs +++ b/buckaroo/QuickstartCommand.fs @@ -66,7 +66,7 @@ let private defaultMain = |> String.concat "\n" let isValidProjectName (candidate : string) = - (new Regex(@"^[A-Za-z0-9\-_]{2,32}$")).IsMatch(candidate) + (Regex(@"^[A-Za-z0-9\-_]{2,32}$")).IsMatch(candidate) let requestProjectName (context : TaskContext) = async { let mutable candidate = "" @@ -92,7 +92,7 @@ let task (context : Tasks.TaskContext) = async { do! Files.writeFile "BUCK" (defaultBuck projectName) do! Files.writeFile "main.cpp" defaultMain - do! ResolveCommand.task context Solution.empty ResolutionStyle.Quick + do! ResolveCommand.task context Solution.empty ResolutionStyle.Quick |> Async.Ignore do! InstallCommand.task context context.Console.Write("To start your app: ") diff --git a/buckaroo/ResolveCommand.fs b/buckaroo/ResolveCommand.fs index bd1a630..4afd9f1 100644 --- a/buckaroo/ResolveCommand.fs +++ b/buckaroo/ResolveCommand.fs @@ -51,6 +51,8 @@ let task (context : Tasks.TaskContext) partialSolution resolutionStyle = async { match resolution with | Result.Error e -> (SearchStrategyError.show e) |> logger.RichError + + return false | Result.Ok solution -> "A solution to the constraints was found" |> text |> logger.RichSuccess let lock = Lock.fromManifestAndSolution manifest solution @@ -66,7 +68,7 @@ let task (context : Tasks.TaskContext) partialSolution resolutionStyle = async { "The lock-file was updated" |> text |> logger.RichSuccess - return () + return true } match (resolutionStyle, maybeLock) with @@ -75,7 +77,7 @@ let task (context : Tasks.TaskContext) partialSolution resolutionStyle = async { then logger.RichInfo <| (text "The existing lock-file is already up-to-date! ") - return () + return true else return! resolve | (_, _) -> diff --git a/buckaroo/SearchStrategy.fs b/buckaroo/SearchStrategy.fs index cf01df0..92e7d62 100644 --- a/buckaroo/SearchStrategy.fs +++ b/buckaroo/SearchStrategy.fs @@ -29,6 +29,9 @@ module SearchStrategyError = |> text |> foreground ConsoleColor.Blue + let private showCore (p, cs) = + (showPackage p) + " at " + (showConstraint (All cs)) + let rec show (e : SearchStrategyError) = match e with | LimitReached ((p, c), l) -> @@ -41,14 +44,14 @@ module SearchStrategyError = | NoPrivateSolution p -> "We could not resolve a private dependency for " + (showPackage p) + "." | TransitiveConflict xs -> - (text "We had the following conflicts: ") + + (text "We had the following conflicts: \n") + ( xs |> Seq.collect (fun (cores, reason) -> cores |> Seq.map (fun core -> - ("<" + (core |> string) + "> because " |> text) + (show reason) + (" " + (core |> showCore) + ": ") + (show reason) ) ) - |> RichOutput.concat (text ", ") - ) \ No newline at end of file + |> RichOutput.concat (text "\n") + ) diff --git a/buckaroo/Solver.fs b/buckaroo/Solver.fs index 3830dc6..af00048 100644 --- a/buckaroo/Solver.fs +++ b/buckaroo/Solver.fs @@ -6,10 +6,10 @@ open Buckaroo.Tasks open Buckaroo.Console open Buckaroo.RichOutput open Buckaroo.Logger -open Buckaroo.Constants open Buckaroo.Constraint open Buckaroo.Result open Buckaroo.SearchStrategy +open Buckaroo.Prefetch type LocatedAtom = Atom * PackageLock @@ -143,7 +143,7 @@ let findUnresolved pick (selections: Map seq { +let breadthFirst = findUnresolved (fun a b -> seq { yield! a yield! b }) @@ -160,10 +160,10 @@ let fetchCandidatesForConstraint sourceExplorer locations p c = asyncSeq { let mutable branchFailures = Map.empty for x in candidatesToExplore do - if branchFailures |> Map.exists (fun _ v -> v > MaxConsecutiveFailures) then + if branchFailures |> Map.exists (fun _ v -> v > Constants.MaxConsecutiveFailures) then let d = (p, Set [ c ]) yield - LimitReached (d, MaxConsecutiveFailures) + LimitReached (d, Constants.MaxConsecutiveFailures) |> Result.Error else yield! @@ -212,7 +212,6 @@ let fetchCandidatesForConstraint sourceExplorer locations p c = asyncSeq { |> Result.Error } - let resolutionManager (sourceExplorer : ISourceExplorer) : MailboxProcessor = MailboxProcessor.Start(fun inbox -> async { let mutable unresolvableCores : Map, SearchStrategyError> = Map.empty @@ -231,13 +230,6 @@ let resolutionManager (sourceExplorer : ISourceExplorer) : MailboxProcessor Option.defaultValue false )) - let printCores () = - System.Console.WriteLine "----------" - for cores in unresolvableCores |> Map.keySet do - cores |> Set |> System.Console.WriteLine - System.Console.WriteLine "&&&&&" - System.Console.WriteLine "----------" - let trackLocal locations (p, cs) constraintsContext = asyncSeq { let mutable hadCandidate = false let c = cs |> All |> Constraint.simplify @@ -258,15 +250,13 @@ let resolutionManager (sourceExplorer : ISourceExplorer) : MailboxProcessor unresolvableCores <- (unresolvableCores |> Map.add (Set [d]) (Unresolvable d)) - printCores() yield Result.Error <| Unresolvable d - | Result.Error (LimitReached (d, MaxConsecutiveFailures)) -> + | Result.Error (LimitReached (d, Constants.MaxConsecutiveFailures)) -> if hadCandidate then underconstraintDeps <- (underconstraintDeps |> Set.add d) - printCores() - yield Result.Error <| LimitReached (d, MaxConsecutiveFailures) + yield Result.Error <| LimitReached (d, Constants.MaxConsecutiveFailures) | Result.Ok (_, (location, versions)) -> let! lock = sourceExplorer.LockLocation location let! manifest = sourceExplorer.FetchManifest (lock, versions) @@ -419,8 +409,9 @@ let resolutionManager (sourceExplorer : ISourceExplorer) : MailboxProcessor Set.unionMany |> Set.add failedDep - unresolvableCores <- unresolvableCores |> Map.add core (SearchStrategyError.Unresolvable (p, bs)) - printCores() + unresolvableCores <- + unresolvableCores + |> Map.add core (SearchStrategyError.Unresolvable (p, bs)) | _ -> () @@ -553,7 +544,9 @@ let mergeHint sourceExplorer next = async { } let quickStrategy resolver sourceExplorer state selections = asyncSeq { - let unresolved = breathFirst selections state.Root + let unresolved = + breadthFirst selections state.Root + |> Seq.sortBy (snd >> All >> simplify >> Constraint.chanceOfSuccess) for (p, cs) in unresolved do yield! @@ -565,7 +558,9 @@ let quickStrategy resolver sourceExplorer state selections = asyncSeq { } let upgradeStrategy resolver sourceExplorer state selections = asyncSeq { - let unresolved = breathFirst selections state.Root + let unresolved = + breadthFirst selections state.Root + |> Seq.sortBy (snd >> All >> simplify >> Constraint.chanceOfSuccess) for (p, cs) in unresolved do yield! @@ -581,18 +576,17 @@ let private privateStep step ((p, _), state, rv) = Locations = state.Locations Selections = Map.empty } - (step privateState [ Root m ]) |> AsyncSeq.choose ifOk |> AsyncSeq.tryFirst -let rec private step (context : TaskContext) (resolver : MailboxProcessor) strategy (state : SolverState) (path: List): AsyncSeq> = asyncSeq { - let log = createLogger context.Console (Some "solver") - let nextStep = step context resolver strategy +let rec private step (context : TaskContext) (resolver : MailboxProcessor) (prefetcher : Prefetcher) strategy (state : SolverState) (path: List): AsyncSeq> = asyncSeq { + let logger = createLogger context.Console (Some "solver") + let nextStep = step context resolver prefetcher strategy let selections = pruneSelections state.Selections state.Root - if breathFirst selections state.Root |> Seq.isEmpty + if breadthFirst selections state.Root |> Seq.isEmpty then yield Result.Ok { Resolutions = selections } else @@ -605,6 +599,13 @@ let rec private step (context : TaskContext) (resolver : MailboxProcessor if path |> List.contains (Node (p, cs, rv)) |> not then + logger.Info ( + "Trying " + (PackageIdentifier.show p) + " at " + + (rv.Versions |> Seq.map Version.show |> String.concat ", ")) + + for p in rv.Manifest.Dependencies |> Seq.map (fun d -> d.Package) |> Seq.distinct do + prefetcher.Prefetch p + let! privateSolution = privateStep nextStep ((p, cs), state, rv) match privateSolution with @@ -638,7 +639,7 @@ let rec private step (context : TaskContext) (resolver : MailboxProcessor AsyncSeq.distinctUntilChanged for ((p, cs), error) in errors do - System.Console.WriteLine error + context.Console.Write(string error, LoggingLevel.Trace) do! resolver.PostAndAsyncReply (fun ch -> MarkBadPath (path, (p, cs), error, ch)) } @@ -672,13 +673,15 @@ let solve (context : TaskContext) (partialSolution : Solution) (manifest : Manif let resolver = resolutionManager context.SourceExplorer + let prefetcher = Prefetcher (context.SourceExplorer, 10) + let strategy = match style with | Quick -> quickStrategy resolver context.SourceExplorer | Upgrading -> upgradeStrategy resolver context.SourceExplorer let resolutions = - step context resolver strategy state [ Root manifest ] + step context resolver prefetcher strategy state [ Root manifest ] let! result = resolutions diff --git a/buckaroo/UpgradeCommand.fs b/buckaroo/UpgradeCommand.fs index cdfdcc8..94e8575 100644 --- a/buckaroo/UpgradeCommand.fs +++ b/buckaroo/UpgradeCommand.fs @@ -5,59 +5,52 @@ open System.IO open Buckaroo open Buckaroo.Tasks open Buckaroo.RichOutput +open Buckaroo.Logger +open Buckaroo let task context (packages : List) = async { + let logger = createLogger context.Console None + if Seq.isEmpty packages then - context.Console.Write ( - ( - "info " - |> text - |> foreground ConsoleColor.Blue - ) + - "Upgrading all packages... " - ) + logger.Info "Upgrading all packages... " else - context.Console.Write ( - ( - "info " - |> text - |> foreground ConsoleColor.Blue - ) + - "Upgrading [ " + (packages |> Seq.map PackageIdentifier.show |> String.concat " ") + " ]... " - ) - - if File.Exists (Constants.LockFileName) - then - let! lock = Tasks.readLock - let! partial = - if packages |> Seq.isEmpty - then async { return Solution.empty } + logger.Info + <| "Upgrading [ " + (packages |> Seq.map PackageIdentifier.show |> String.concat " ") + " ]... " + + let extractPartialSolution = + async { + if File.Exists (Constants.LockFileName) + then + let! lock = Tasks.readLock + let! partial = + if packages |> Seq.isEmpty + then async { return Solution.empty } + else + async { + let! solution = Solver.fromLock context.SourceExplorer lock + + return solution + } + + return partial else - async { - let! solution = Solver.fromLock context.SourceExplorer lock + logger.Warning + "There is no lock-file to upgrade. A fresh lock-file will be generated. " - return solution - // |> Set.ofList - // |> Solver.unlock solution - } + return Solution.empty + } - do! ResolveCommand.task context partial ResolutionStyle.Upgrading - do! InstallCommand.task context + let! partial = extractPartialSolution - return () - else - context.Console.Write ( - ( - "warning " - |> text - |> foreground ConsoleColor.Yellow - ) + - "There is no lock-file to upgrade. A fresh lock-file will be generated. " - ) - - do! ResolveCommand.task context Solution.empty ResolutionStyle.Upgrading + let! resolveSucceeded = + ResolveCommand.task context partial ResolutionStyle.Upgrading + + if resolveSucceeded + then do! InstallCommand.task context + else + logger.Error "The upgrade failed. No packages were changed. " - return () + return () } \ No newline at end of file diff --git a/buckaroo/buckaroo.fsproj b/buckaroo/buckaroo.fsproj index cc23833..9172b2c 100644 --- a/buckaroo/buckaroo.fsproj +++ b/buckaroo/buckaroo.fsproj @@ -45,6 +45,7 @@ + From 37465c52fd292c308c5bec38c69d1aefb78cb7f7 Mon Sep 17 00:00:00 2001 From: Gaetano Checinski Date: Wed, 13 Mar 2019 12:50:04 +0000 Subject: [PATCH 19/25] feat: implements cache first option for remoterefs fetching --- buckaroo-cli/Program.fs | 4 +-- buckaroo-tests/Command.fs | 33 ++++++++++++++---------- buckaroo-tests/Solver.fs | 2 +- buckaroo/Command.fs | 16 +++++++++--- buckaroo/GitManager.fs | 54 ++++++++++++++++++++++----------------- buckaroo/Solver.fs | 6 ++--- buckaroo/Tasks.fs | 4 +-- 7 files changed, 70 insertions(+), 49 deletions(-) diff --git a/buckaroo-cli/Program.fs b/buckaroo-cli/Program.fs index d418ed1..c12d593 100644 --- a/buckaroo-cli/Program.fs +++ b/buckaroo-cli/Program.fs @@ -15,10 +15,10 @@ let main argv = let! exitCode = async { try match Buckaroo.Command.parse input with - | Result.Ok (command, loggingLevel) -> + | Result.Ok (command, loggingLevel, fetchStyle) -> do! command - |> Buckaroo.Command.runCommand loggingLevel + |> Buckaroo.Command.runCommand loggingLevel fetchStyle return 0 | Result.Error error -> Console.WriteLine error diff --git a/buckaroo-tests/Command.fs b/buckaroo-tests/Command.fs index 0351926..849edd0 100644 --- a/buckaroo-tests/Command.fs +++ b/buckaroo-tests/Command.fs @@ -15,32 +15,37 @@ let private ijkXyz = GitHub { Owner = "ijk"; Project = "xyz" } [] let ``Command.parse works correctly`` () = let cases = [ - (Result.Ok (Command.Init, defaultLoggingLevel), "init"); + (Result.Ok (Command.Init, defaultLoggingLevel, RemoteFirst), "init"); - (Result.Ok (Command.Install, defaultLoggingLevel), " install "); + (Result.Ok (Command.Install, defaultLoggingLevel, RemoteFirst), " install "); - (Result.Ok (Command.Resolve Quick, defaultLoggingLevel), "resolve"); - (Result.Ok (Command.Resolve Quick, verboseLoggingLevel), "resolve --verbose"); - (Result.Ok (Command.Resolve Upgrading, defaultLoggingLevel), "resolve --upgrade "); - (Result.Ok (Command.Resolve Upgrading, verboseLoggingLevel), "resolve --upgrade --verbose"); + (Result.Ok (Command.Resolve Quick, defaultLoggingLevel, RemoteFirst), "resolve"); + (Result.Ok (Command.Resolve Quick, verboseLoggingLevel, RemoteFirst), "resolve --verbose"); + (Result.Ok (Command.Resolve Upgrading, defaultLoggingLevel, RemoteFirst), "resolve --upgrade "); + (Result.Ok (Command.Resolve Upgrading, verboseLoggingLevel, RemoteFirst), "resolve --upgrade --verbose"); + (Result.Ok (Command.Resolve Quick, defaultLoggingLevel, CacheFirst), "resolve --cache-first "); + (Result.Ok (Command.Resolve Quick, verboseLoggingLevel, CacheFirst), "resolve --cache-first --verbose"); - (Result.Ok (Command.UpgradeDependencies [], defaultLoggingLevel), "upgrade"); - (Result.Ok (Command.UpgradeDependencies [ abcDef ], defaultLoggingLevel), "upgrade abc/def"); - (Result.Ok (Command.UpgradeDependencies [], verboseLoggingLevel), " upgrade --verbose "); - (Result.Ok (Command.UpgradeDependencies [ abcDef ], verboseLoggingLevel), "upgrade abc/def --verbose "); + (Result.Ok (Command.UpgradeDependencies [], defaultLoggingLevel, RemoteFirst), "upgrade"); + (Result.Ok (Command.UpgradeDependencies [ abcDef ], defaultLoggingLevel, RemoteFirst), "upgrade abc/def"); + (Result.Ok (Command.UpgradeDependencies [], verboseLoggingLevel, RemoteFirst), " upgrade --verbose "); + (Result.Ok (Command.UpgradeDependencies [ abcDef ], verboseLoggingLevel, RemoteFirst), "upgrade abc/def --verbose "); + (Result.Ok (Command.UpgradeDependencies [], verboseLoggingLevel, CacheFirst), " upgrade --cache-first --verbose "); + (Result.Ok (Command.UpgradeDependencies [ abcDef ], verboseLoggingLevel, CacheFirst), "upgrade abc/def --cache-first --verbose "); ( Result.Ok ( Command.AddDependencies [ { Package = ijkXyz; Constraint = Constraint.wildcard; Targets = None } ], - defaultLoggingLevel + defaultLoggingLevel, + RemoteFirst ), "add github.com/ijk/xyz " ); ( - Result.Ok (Command.UpgradeDependencies [ abcDef; ijkXyz ], verboseLoggingLevel), + Result.Ok (Command.UpgradeDependencies [ abcDef; ijkXyz ], verboseLoggingLevel, RemoteFirst), "upgrade abc/def github.com/ijk/xyz --verbose " ); ] @@ -48,8 +53,8 @@ let ``Command.parse works correctly`` () = for (expected, input) in cases do let actual = Command.parse input - match actual with - | Result.Error error -> + match actual, expected with + | Result.Error error, _ -> System.Console.WriteLine (error + "\nfor \"" + input + "\"") | _ -> () diff --git a/buckaroo-tests/Solver.fs b/buckaroo-tests/Solver.fs index 747f6b2..5c96b08 100644 --- a/buckaroo-tests/Solver.fs +++ b/buckaroo-tests/Solver.fs @@ -125,7 +125,7 @@ let solve (partial : Solution) (cookBook : CookBook) (lockBookEntries : LockBook let context : TaskContext = { Console = console DownloadManager = DownloadManager(console, "/tmp") - GitManager = new GitManager(console, new GitCli(console), "/tmp") + GitManager = new GitManager(CacheFirst, console, new GitCli(console), "/tmp") SourceExplorer = TestingSourceExplorer(cookBook, lockBook) } diff --git a/buckaroo/Command.fs b/buckaroo/Command.fs index 27dd2c3..9778371 100644 --- a/buckaroo/Command.fs +++ b/buckaroo/Command.fs @@ -31,6 +31,13 @@ module Command = return Option.isSome maybeSkip } + let cacheFirstParser : Parser = parse { + let! cacheFirst = + CharParsers.skipString "--cache-first" + |> Primitives.opt + return Option.isSome cacheFirst + } + let startParser : Parser = parse { do! CharParsers.spaces return Start @@ -170,13 +177,16 @@ module Command = do! CharParsers.spaces + let! isCacheFirst = cacheFirstParser + do! CharParsers.spaces let! isVerbose = verboseParser do! CharParsers.spaces let loggingLevel = if isVerbose then LoggingLevel.Trace else LoggingLevel.Info + let fetchStyle = if isCacheFirst then CacheFirst else RemoteFirst - return (command, loggingLevel) + return (command, loggingLevel, fetchStyle) } let parse (x : string) = @@ -230,8 +240,8 @@ module Command = context.Console.Write( ("warning " |> warn) + ("There is already a buckaroo.toml file in this directory" |> text)) } - let runCommand loggingLevel command = async { - let! context = Tasks.getContext loggingLevel + let runCommand loggingLevel fetchStyle command = async { + let! context = Tasks.getContext loggingLevel fetchStyle do! match command with diff --git a/buckaroo/GitManager.fs b/buckaroo/GitManager.fs index 63d0b93..f9bebb4 100644 --- a/buckaroo/GitManager.fs +++ b/buckaroo/GitManager.fs @@ -15,7 +15,11 @@ type GitManagerRequest = | CloneRequest of string * AsyncReplyChannel> | FetchRefs of string * AsyncReplyChannel> -type GitManager (console : ConsoleManager, git : IGit, cacheDirectory : string) = +type FetchStyle = +| RemoteFirst +| CacheFirst + +type GitManager (style: FetchStyle, console : ConsoleManager, git : IGit, cacheDirectory : string) = let logger = createLogger console (Some "git") @@ -45,6 +49,20 @@ type GitManager (console : ConsoleManager, git : IGit, cacheDirectory : string) let folder = sanitizeFilename(url).ToLower() + "-" + hash.Substring(0, 16) Path.Combine(cacheDirectory, folder) + let pickRefsToFetch (style: FetchStyle) (remote : Async>) (cache: Async>) = async { + match style with + | RemoteFirst -> + let! x = remote + if x |> List.isEmpty then + return x + else return! cache + | CacheFirst -> + let! x = cache + if x |> List.isEmpty then + return x + else return! remote + } + let mailboxCloneProcessor = MailboxProcessor.Start(fun inbox -> async { let mutable cloneCache : Map> = Map.empty while true do @@ -78,32 +96,20 @@ type GitManager (console : ConsoleManager, git : IGit, cacheDirectory : string) let startTime = System.DateTime.Now let! refs = - Async.Parallel - ( - ( - git.RemoteRefs url - |> Async.Catch - |> Async.map (Choice.toOption >> Option.defaultValue([])) - ), - ( - git.RemoteRefs cacheDir - |> Async.Catch - |> Async.map (Choice.toOption >> Option.defaultValue([])) - ) - ) - |> Async.map(fun (a, b) -> - if a.Length = 0 && b.Length = 0 - then - raise <| SystemException("No internet connection and the cache is empty") - else if a.Length > 0 - then - a - else - b - ) + pickRefsToFetch + style + (git.RemoteRefs url + |> Async.Catch + |> Async.map (Choice.toOption >> Option.defaultValue([]))) + (git.RemoteRefs cacheDir + |> Async.Catch + |> Async.map (Choice.toOption >> Option.defaultValue([]))) let endTime = System.DateTime.Now + if refs |> List.isEmpty then + raise <| SystemException("No internet connection and the cache is empty") + logger.RichSuccess( (text "Fetched ") + (refs |> List.length |> string |> info) + diff --git a/buckaroo/Solver.fs b/buckaroo/Solver.fs index 3830dc6..45b3996 100644 --- a/buckaroo/Solver.fs +++ b/buckaroo/Solver.fs @@ -258,13 +258,13 @@ let resolutionManager (sourceExplorer : ISourceExplorer) : MailboxProcessor unresolvableCores <- (unresolvableCores |> Map.add (Set [d]) (Unresolvable d)) - printCores() + //printCores() yield Result.Error <| Unresolvable d | Result.Error (LimitReached (d, MaxConsecutiveFailures)) -> if hadCandidate then underconstraintDeps <- (underconstraintDeps |> Set.add d) - printCores() + //printCores() yield Result.Error <| LimitReached (d, MaxConsecutiveFailures) | Result.Ok (_, (location, versions)) -> @@ -420,7 +420,7 @@ let resolutionManager (sourceExplorer : ISourceExplorer) : MailboxProcessor Set.add failedDep unresolvableCores <- unresolvableCores |> Map.add core (SearchStrategyError.Unresolvable (p, bs)) - printCores() + //printCores() | _ -> () diff --git a/buckaroo/Tasks.fs b/buckaroo/Tasks.fs index 9cd0593..230332b 100644 --- a/buckaroo/Tasks.fs +++ b/buckaroo/Tasks.fs @@ -30,7 +30,7 @@ let private getCachePath = async { | path -> path } -let getContext loggingLevel = async { +let getContext loggingLevel (fetchStyle : FetchStyle) = async { let consoleManager = ConsoleManager(loggingLevel) let! cachePath = getCachePath @@ -53,7 +53,7 @@ let getContext loggingLevel = async { then GitLib(consoleManager) :> IGit else GitCli(consoleManager) :> IGit - let gitManager = GitManager(consoleManager, git, cachePath) + let gitManager = GitManager(fetchStyle, consoleManager, git, cachePath) let sourceExplorer = DefaultSourceExplorer(consoleManager, downloadManager, gitManager) return { From e6f9b9ed16fa10442621d7937fa0e7d9a5900e5a Mon Sep 17 00:00:00 2001 From: Gaetano Checinski Date: Wed, 13 Mar 2019 13:18:12 +0000 Subject: [PATCH 20/25] chore: cleanup --- buckaroo-tests/Command.fs | 4 ++-- buckaroo/Command.fs | 17 ++++++++++++++--- buckaroo/GitManager.fs | 4 ++-- buckaroo/Tasks.fs | 2 +- 4 files changed, 19 insertions(+), 8 deletions(-) diff --git a/buckaroo-tests/Command.fs b/buckaroo-tests/Command.fs index 849edd0..a002f85 100644 --- a/buckaroo-tests/Command.fs +++ b/buckaroo-tests/Command.fs @@ -53,8 +53,8 @@ let ``Command.parse works correctly`` () = for (expected, input) in cases do let actual = Command.parse input - match actual, expected with - | Result.Error error, _ -> + match actual with + | Result.Error error -> System.Console.WriteLine (error + "\nfor \"" + input + "\"") | _ -> () diff --git a/buckaroo/Command.fs b/buckaroo/Command.fs index c75a423..8f7d460 100644 --- a/buckaroo/Command.fs +++ b/buckaroo/Command.fs @@ -179,12 +179,23 @@ module Command = let! isCacheFirst = cacheFirstParser do! CharParsers.spaces - let! isVerbose = verboseParser + let! isVerbose = verboseParser do! CharParsers.spaces - let loggingLevel = if isVerbose then LoggingLevel.Trace else LoggingLevel.Info - let fetchStyle = if isCacheFirst then CacheFirst else RemoteFirst + let loggingLevel = + if isVerbose + then + LoggingLevel.Trace + else + LoggingLevel.Info + + let fetchStyle = + if isCacheFirst + then + CacheFirst + else + RemoteFirst return (command, loggingLevel, fetchStyle) } diff --git a/buckaroo/GitManager.fs b/buckaroo/GitManager.fs index f9bebb4..52c9bbc 100644 --- a/buckaroo/GitManager.fs +++ b/buckaroo/GitManager.fs @@ -53,12 +53,12 @@ type GitManager (style: FetchStyle, console : ConsoleManager, git : IGit, cacheD match style with | RemoteFirst -> let! x = remote - if x |> List.isEmpty then + if x |> List.isEmpty |> not then return x else return! cache | CacheFirst -> let! x = cache - if x |> List.isEmpty then + if x |> List.isEmpty |> not then return x else return! remote } diff --git a/buckaroo/Tasks.fs b/buckaroo/Tasks.fs index 230332b..7f6d24b 100644 --- a/buckaroo/Tasks.fs +++ b/buckaroo/Tasks.fs @@ -30,7 +30,7 @@ let private getCachePath = async { | path -> path } -let getContext loggingLevel (fetchStyle : FetchStyle) = async { +let getContext loggingLevel fetchStyle = async { let consoleManager = ConsoleManager(loggingLevel) let! cachePath = getCachePath From 1fcb0b58780cf6f226f28af43698a0850a26418a Mon Sep 17 00:00:00 2001 From: Gaetano Checinski Date: Wed, 13 Mar 2019 14:40:45 +0000 Subject: [PATCH 21/25] chore: re-adds Solver.unlock --- buckaroo/Solver.fs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/buckaroo/Solver.fs b/buckaroo/Solver.fs index 27d2505..903fdea 100644 --- a/buckaroo/Solver.fs +++ b/buckaroo/Solver.fs @@ -728,3 +728,11 @@ let rec fromLock (sourceExplorer : ISourceExplorer) (lock : Lock) : Async Map.ofSeq } } + +let unlock (solution : Solution) (packages : Set) : Solution = { + Resolutions = + solution.Resolutions + |> Map.toSeq + |> Seq.filter (fst >> packages.Contains >> not) + |> Map.ofSeq +} From 620ba44d300a1465bcb8563c1dafb1d3e5e5e2c1 Mon Sep 17 00:00:00 2001 From: Gaetano Checinski Date: Wed, 13 Mar 2019 15:23:10 +0000 Subject: [PATCH 22/25] feat: improves logging --- buckaroo/Solver.fs | 28 +++++++++++++++++++++++----- 1 file changed, 23 insertions(+), 5 deletions(-) diff --git a/buckaroo/Solver.fs b/buckaroo/Solver.fs index 903fdea..0653cec 100644 --- a/buckaroo/Solver.fs +++ b/buckaroo/Solver.fs @@ -212,12 +212,14 @@ let fetchCandidatesForConstraint sourceExplorer locations p c = asyncSeq { |> Result.Error } -let resolutionManager (sourceExplorer : ISourceExplorer) : MailboxProcessor = +let resolutionManager (context : TaskContext) : MailboxProcessor = MailboxProcessor.Start(fun inbox -> async { let mutable unresolvableCores : Map, SearchStrategyError> = Map.empty let mutable underconstraintDeps : Set = Set.empty let mutable world : Map>> = Map.empty + let sourceExplorer = context.SourceExplorer + let logger = createLogger context.Console (Some "solver") let findBadCores (constraints : Constraints) = unresolvableCores |> Map.toSeq @@ -250,11 +252,27 @@ let resolutionManager (sourceExplorer : ISourceExplorer) : MailboxProcessor unresolvableCores <- (unresolvableCores |> Map.add (Set [d]) (Unresolvable d)) + let (p, cs) = d + logger.RichWarning ( + "Unresolvable: " + + PackageIdentifier.showRich p + + subtle "@" + + (highlight <| Constraint.show (All cs |> simplify)) + ) yield Result.Error <| Unresolvable d | Result.Error (LimitReached (d, Constants.MaxConsecutiveFailures)) -> - if hadCandidate + if hadCandidate |> not && (Set.contains d underconstraintDeps |> not) then underconstraintDeps <- (underconstraintDeps |> Set.add d) + let (p, cs) = d + logger.RichWarning ( + text("No manifest found for: ") + + PackageIdentifier.showRich p + + subtle "@" + + Constraint.show (All cs) + ) + logger.Warning ("... is this a valid Buckaroo package?") + yield Result.Error <| LimitReached (d, Constants.MaxConsecutiveFailures) | Result.Ok (_, (location, versions)) -> let! lock = sourceExplorer.LockLocation location @@ -545,7 +563,7 @@ let mergeHint sourceExplorer next = async { let quickStrategy resolver sourceExplorer state selections = asyncSeq { let unresolved = breadthFirst selections state.Root - |> Seq.sortBy (snd >> All >> simplify >> Constraint.chanceOfSuccess) + |> Seq.sortByDescending (snd >> All >> simplify >> Constraint.chanceOfSuccess) for (p, cs) in unresolved do yield! @@ -559,7 +577,7 @@ let quickStrategy resolver sourceExplorer state selections = asyncSeq { let upgradeStrategy resolver sourceExplorer state selections = asyncSeq { let unresolved = breadthFirst selections state.Root - |> Seq.sortBy (snd >> All >> simplify >> Constraint.chanceOfSuccess) + |> Seq.sortByDescending (snd >> All >> simplify >> Constraint.chanceOfSuccess) for (p, cs) in unresolved do yield! @@ -670,7 +688,7 @@ let solve (context : TaskContext) (partialSolution : Solution) (manifest : Manif Locations = manifest.Locations } - let resolver = resolutionManager context.SourceExplorer + let resolver = resolutionManager context let prefetcher = Prefetcher (context.SourceExplorer, 10) From 02400fe66d13a1f90a62c52ebba4bfbe59dc03db Mon Sep 17 00:00:00 2001 From: Gaetano Checinski Date: Wed, 13 Mar 2019 15:33:49 +0000 Subject: [PATCH 23/25] chore: minor changes --- buckaroo/Solver.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/buckaroo/Solver.fs b/buckaroo/Solver.fs index 0653cec..0c7a5a2 100644 --- a/buckaroo/Solver.fs +++ b/buckaroo/Solver.fs @@ -417,7 +417,7 @@ let resolutionManager (context : TaskContext) : MailboxProcessor Seq.map (fun x -> (x.Package, x.Constraint |> toDnf)) |> Seq.filter (fun (q, cs) -> p = q && cs <> contrib) - |> Seq.filter (fun (_, cs) -> Set.isProperSubset cs bs) // TODO: should be an intersection? + |> Seq.map (fun (q, cs) -> (q, Set.intersect cs bs)) |> Seq.map (fun (q, cs) -> (q, Set.difference cs contrib)) |> Seq.filter (fun (_, cs) -> cs.IsEmpty |> not) |> Set From 2e097dd7c40e686e50e380558e0015607e8e2d6d Mon Sep 17 00:00:00 2001 From: Gaetano Checinski Date: Wed, 13 Mar 2019 15:36:32 +0000 Subject: [PATCH 24/25] chore: re-adds Solver.unlock --- buckaroo-tests/Solver.fs | 116 +++++++++++++++++++-------------------- 1 file changed, 58 insertions(+), 58 deletions(-) diff --git a/buckaroo-tests/Solver.fs b/buckaroo-tests/Solver.fs index 5c96b08..8c5f9c1 100644 --- a/buckaroo-tests/Solver.fs +++ b/buckaroo-tests/Solver.fs @@ -511,64 +511,64 @@ let ``Solver does not upgrade if a complete solution is supplied`` () = Assert.Equal ("1", getLockedRev "c" solution) () -//[] -// let ``Solver upgrades completes partial solution with latest packages`` () = -// let cookBook = [ -// (package "a", -// Set[ver 2; br "a"], -// manifest []) -// (package "a", -// Set[ver 1; br "a"], -// manifest []) -// (package "b", -// Set[ver 2; br "a"], -// manifest []) -// (package "b", -// Set[ver 1; br "a"], -// manifest []) -// (package "c", -// Set[ver 2; br "a"], -// manifest []) -// (package "c", -// Set[ver 1; br "a"], -// manifest []) -// ] - -// let lockBookSpec = [ -// (("root", 0), [ -// ("a", 1, Set[ver 1; br "a"]) -// ("b", 1, Set[ver 1; br "a"]) -// ("c", 1, Set[ver 1; br "a"]) -// ]) -// ] - -// let root = manifest [ -// ("a", Exactly (br "a") ) -// ("b", Exactly (br "a") ) -// ("c", Exactly (br "a") ) -// ] - -// let lockBook = lockBookOf lockBookSpec -// let rootLock = lockBook |> Map.find (packageLock ("root", 0)) - -// let explorer = TestingSourceExplorer(cookBook, lockBook) -// let completeSolution = -// Solver.fromLock explorer rootLock -// |> Async.RunSynchronously - -// let partialSolution = Set[package "b"] |> Solver.unlock completeSolution - -// let solution = -// solve -// partialSolution -// cookBook lockBookSpec root -// ResolutionStyle.Upgrading -// |> Async.RunSynchronously - -// Assert.Equal ("1", getLockedRev "a" solution) -// Assert.Equal ("2", getLockedRev "b" solution) -// Assert.Equal ("1", getLockedRev "c" solution) -// () +[] +let ``Solver upgrades completes partial solution with latest packages`` () = + let cookBook = [ + (package "a", + Set[ver 2; br "a"], + manifest []) + (package "a", + Set[ver 1; br "a"], + manifest []) + (package "b", + Set[ver 2; br "a"], + manifest []) + (package "b", + Set[ver 1; br "a"], + manifest []) + (package "c", + Set[ver 2; br "a"], + manifest []) + (package "c", + Set[ver 1; br "a"], + manifest []) + ] + + let lockBookSpec = [ + (("root", 0), [ + ("a", 1, Set[ver 1; br "a"]) + ("b", 1, Set[ver 1; br "a"]) + ("c", 1, Set[ver 1; br "a"]) + ]) + ] + + let root = manifest [ + ("a", Exactly (br "a") ) + ("b", Exactly (br "a") ) + ("c", Exactly (br "a") ) + ] + + let lockBook = lockBookOf lockBookSpec + let rootLock = lockBook |> Map.find (packageLock ("root", 0)) + + let explorer = TestingSourceExplorer(cookBook, lockBook) + let completeSolution = + Solver.fromLock explorer rootLock + |> Async.RunSynchronously + + let partialSolution = Set[package "b"] |> Solver.unlock completeSolution + + let solution = + solve + partialSolution + cookBook lockBookSpec root + ResolutionStyle.Upgrading + |> Async.RunSynchronously + + Assert.Equal ("1", getLockedRev "a" solution) + Assert.Equal ("2", getLockedRev "b" solution) + Assert.Equal ("1", getLockedRev "c" solution) + () [] let ``Solver can handle the simple triangle case`` () = From 193a27b66e32d7793d17b09fcef01c2a074e4dcd Mon Sep 17 00:00:00 2001 From: Gaetano Checinski Date: Wed, 13 Mar 2019 16:09:04 +0000 Subject: [PATCH 25/25] fix tests --- buckaroo-tests/Solver.fs | 2 +- buckaroo/Solver.fs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/buckaroo-tests/Solver.fs b/buckaroo-tests/Solver.fs index 8c5f9c1..888b1eb 100644 --- a/buckaroo-tests/Solver.fs +++ b/buckaroo-tests/Solver.fs @@ -358,7 +358,7 @@ let ``Solver handles negated constraints also`` () = Set[ver 2; br "a"], manifest []) (package "b", - Set[ver 2; br "b"], + Set[ver 2; br "a"], manifest []) (package "a", Set[ver 3; br "a"], diff --git a/buckaroo/Solver.fs b/buckaroo/Solver.fs index 0c7a5a2..c6ce81d 100644 --- a/buckaroo/Solver.fs +++ b/buckaroo/Solver.fs @@ -261,7 +261,7 @@ let resolutionManager (context : TaskContext) : MailboxProcessor - if hadCandidate |> not && (Set.contains d underconstraintDeps |> not) + if hadCandidate && (Set.contains d underconstraintDeps |> not) then underconstraintDeps <- (underconstraintDeps |> Set.add d) let (p, cs) = d