2 files changed, 145 insertions, 10 deletions

diff --git a/lib/kernel/Path.ml b/lib/kernel/Path.ml
index 2e712cc..0814b1c 100644
--- a/lib/kernel/Path.ml
+++ b/lib/kernel/Path.ml
@@ -17,9 +17,14 @@ 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 =
+let walking ?missing f g handle path =
   let open Protocols in
   let open Utilities.Result in
   let rec walk handle = function
@@ -32,7 +37,8 @@ let walking f g handle path =
         in
         let* elem = Directory.find dir x |> Result.map (Option.map Handle.autorelease) in
         match elem with
-        | None -> Error (Error.path_not_found path)
+        | None -> (
+          match missing with Some m -> m () | None -> Error (Error.path_not_found path) )
         | Some elem -> f x handle (fun () -> walk elem xs) )
   in
   Handle.with_autorelease (fun () ->
@@ -42,6 +48,13 @@ let walking f g handle path =
 
 let lookup handle path = walking (fun _ _ f -> f ()) Result.ok handle path
 
+let find handle path =
+  walking
+    ~missing:(fun () -> Ok None)
+    (fun _ _ f -> f ())
+    (fun h -> Ok (Some h))
+    handle path
+
 let update handle path key reference value =
   let open Utilities.Result in
   let open Protocols in
@@ -49,16 +62,116 @@ 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 =
+(* The changes at this object, and those beneath each child they reach. *)
+let split changes =
+  let here, below = List.partition (fun (path, _, _) -> path = []) changes in
+  let segments =
+    List.sort_uniq String.compare (List.map (fun (path, _, _) -> List.hd path) 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
+  here, List.map (fun x -> x, beneath x) segments
+
+(* What is not there yet is handed over as a directory of what the
+   changes put in it, for its parent to store. *)
+let rec fresh changes =
+  let here, children = split changes in
+  Prototype.(
+    mixture
+      [ Directory.of_properties
+          ( List.filter_map (fun (_, key, value) -> Option.map (fun v -> key, v) value) here
+          @ List.map (fun (x, beneath) -> x, fresh beneath) children ) ] )
+
+let binds changes = List.exists (fun (_, _, value) -> Option.is_some value) changes
+
+(* 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 -> f () |> fmap (assoc_on dir key |.| Option.some))
-    (fun h -> assoc_on h key value)
-    handle path
+  let rec apply prefix node changes =
+    let here, below = split changes in
+    let segments = List.map fst 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, beneath) ->
+              let* dir = Handle.require Directory.from node in
+              let* found = Directory.find dir x in
+              match found with
+              | None when binds beneath -> Ok [x, Some (fresh beneath)]
+              | None -> Ok []
+              | Some child ->
+                  Handle.releasing child (fun () -> apply (prefix @ [x]) child beneath)
+                  |> Result.map (fun child' -> [x, Some child']) )
+            below
+          |> Utilities.List.sequence
+          |> Result.map List.concat
+        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..e95505d 100644
--- a/lib/kernel/Path.mli
+++ b/lib/kernel/Path.mli
@@ -4,8 +4,13 @@ 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
 
+(** what [path] reaches, or [None] when some part of it is not there. *)
+val find :
+  Protocols.Handle.t -> t -> (Protocols.Handle.t option, Concepts.Condition.condition) result
+
 val update :
   Protocols.Handle.t ->
   t ->
@@ -14,9 +19,26 @@ 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. An
+    object on the way that is not there yet is handed to its parent as a
+    directory of what the changes put in it. *)
+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