1 files changed, 123 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