2 files changed, 113 insertions, 9 deletions

diff --git a/lib/kernel/Path.ml b/lib/kernel/Path.ml
index eeef396..d6a65c9 100644
--- a/lib/kernel/Path.ml
+++ b/lib/kernel/Path.ml
@@ -17,6 +17,11 @@ module Error = struct
   let path_not_found path =
     condition "path-not-found" "A given path was not found under the specified object"
       ("path" |=| Concepts.Value.String (to_string path))
+
+  let overlapping_change path =
+    condition "overlapping-change"
+      "A batch of changes both replaced an object and changed inside it"
+      ("path" |=| Concepts.Value.String (to_string path))
 end
 
 let walking f g handle path =
@@ -56,17 +61,100 @@ let update handle path key reference value =
       let* registry = Handle.require Registry.from target in
       Registry.update registry key reference value )
 
-let assoc handle path key value =
+(* Changes under the same name are applied to the child together, so
+   every object on the way is derived once however many changes reach
+   it: a batch of changes to a branch is one successor state. *)
+let assoc_all handle changes =
   let open Utilities.Result in
-  let open Utilities.Fun in
   let open Protocols in
-  let assoc_on handle key value =
-    let* a = Handle.require Associative.from handle in
+  let assoc_on node (key, value) =
+    let* a = Handle.require Associative.from node in
     let* a' = Associative.update a key value in
     Ok (Handle.from a')
   in
-  walking
-    (fun key dir f ->
-      releasing handle dir (fun () -> f () |> fmap (assoc_on dir key |.| Option.some)) )
-    (fun h -> releasing handle h (fun () -> assoc_on h key value))
-    handle path
+  let rec apply prefix node changes =
+    let here, below = List.partition (fun (path, _, _) -> path = []) changes in
+    let segments =
+      List.fold_left
+        (fun segments (path, _, _) ->
+          let x = List.hd path in
+          if List.mem x segments then segments else segments @ [x] )
+        [] below
+    in
+    let beneath x =
+      List.filter_map
+        (fun (path, key, value) ->
+          match path with y :: rest when y = x -> Some (rest, key, value) | _ -> None )
+        below
+    in
+    match List.find_opt (fun (_, key, _) -> List.mem key segments) here with
+    | Some (_, key, _) -> Error (Error.overlapping_change (prefix @ [key]))
+    | None ->
+        let* children =
+          List.map
+            (fun x ->
+              let* dir = Handle.require Directory.from node in
+              let* found = Directory.find dir x in
+              match found with
+              | None -> Error (Error.path_not_found (prefix @ [x]))
+              | Some child ->
+                  releasing handle child (fun () -> apply (prefix @ [x]) child (beneath x))
+                  |> Result.map (fun child' -> x, Some child') )
+            segments
+          |> Utilities.List.sequence
+        in
+        (* each step derives from the last; only the steps in between are
+           ours to release *)
+        List.fold_left
+          (fun current change ->
+            let* current = current in
+            let* next = assoc_on current change in
+            if current != node then Handle.release current;
+            Ok next )
+          (Ok node)
+          (children @ List.map (fun (_, key, value) -> key, value) here)
+  in
+  apply [] handle changes
+
+let assoc handle path key value = assoc_all handle [path, key, value]
+
+let diff a b =
+  let open Utilities.Result in
+  let open Protocols in
+  let address h = Option.map Addressable.address (Addressable.from h) in
+  let same x y =
+    match address x, address y with
+    | Some p, Some q -> Concepts.Hash.hash_equals p q
+    | _ -> Handle.equal x y
+  in
+  let names h =
+    let* dir = Handle.require Directory.from h in
+    let* names = Directory.list dir in
+    Ok (BatFingerTree.to_list names)
+  in
+  let find h name =
+    let* dir = Handle.require Directory.from h in
+    Directory.find dir name
+  in
+  let rec walk prefix a b =
+    let* left = names a in
+    let* right = names b in
+    List.sort_uniq String.compare (left @ right)
+    |> List.map (fun name ->
+        let path = prefix @ [name] in
+        let* x = find a name in
+        let* y = find b name in
+        Fun.protect
+          ~finally:(fun () -> List.iter Handle.release (Option.to_list x @ Option.to_list y))
+          (fun () ->
+            match x, y with
+            | None, None -> Ok []
+            | Some x, Some y when same x y -> Ok []
+            | Some x, Some y when Directory.from x <> None && Directory.from y <> None ->
+                let* below = walk path x y in
+                Ok (if below = [] then [path] else below)
+            | _ -> Ok [path] ) )
+    |> Utilities.List.sequence
+    |> Result.map List.concat
+  in
+  walk [] a b
diff --git a/lib/kernel/Path.mli b/lib/kernel/Path.mli
index 571e59c..e331b3a 100644
--- a/lib/kernel/Path.mli
+++ b/lib/kernel/Path.mli
@@ -4,6 +4,7 @@ val this : t
 val ( @/ ) : string -> t -> t
 val of_list : string list -> t
 val to_list : t -> string list
+val to_string : t -> string
 val lookup : Protocols.Handle.t -> t -> (Protocols.Handle.t, Concepts.Condition.condition) result
 
 val update :
@@ -14,9 +15,24 @@ val update :
   Protocols.Handle.t option ->
   (bool, Concepts.Condition.condition) result
 
+(** [assoc handle path key value] derives [handle] with [key] under
+    [path] bound to [value], or unbound when [None]. *)
 val assoc :
   Protocols.Handle.t ->
   t ->
   string ->
   Protocols.Handle.t option ->
   (Protocols.Handle.t, Concepts.Condition.condition) result
+
+(** every change of [assoc] at once: each object on the way is derived
+    once, so the changes to a branch land as one successor state. *)
+val assoc_all :
+  Protocols.Handle.t ->
+  (t * string * Protocols.Handle.t option) list ->
+  (Protocols.Handle.t, Concepts.Condition.condition) result
+
+(** the paths, relative to [a] and [b], that differ between them. Equal
+    addresses are not descended, so this costs what changed. Every child
+    is compared, so diff a branch's \multigroup rather than the branch,
+    whose \previous differs whenever anything does. *)
+val diff : Protocols.Handle.t -> Protocols.Handle.t -> (t list, Concepts.Condition.condition) result