B-tree iteration constructs (#49)

* Generic `sequence`, finger tree `map2`/`zip`

* `fold_left` on B-trees

* Finger tree `join`

* `iter`, more tests

* We do not need `keys` when traversing through a trunk node

5 files changed, 156 insertions, 22 deletions

diff --git a/lib/Utilities.ml b/lib/Utilities.ml
index 9ae0119..a6b36c7 100644
--- a/lib/Utilities.ml
+++ b/lib/Utilities.ml
@@ -1,12 +1,71 @@
 module Result = struct
   let ( let* ) = Result.bind
   let fmap f m = Result.bind m f
+end
+
+module type SEQUENCE = sig
+  type 'a t
+
+  val empty : 'a t
+  val cons : 'a -> 'a t -> 'a t
+  val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+end
+
+module Generic (S : SEQUENCE) = struct
+  let sequence ms =
+    let open Result in
+    S.fold
+      (fun m acc ->
+        let* acc = acc in
+        let* m = m in
+        Ok (S.cons m acc))
+      ms
+      (Ok S.empty)
+end
+
+module List = struct
+  module ListSequence : SEQUENCE with type 'a t = 'a list = struct
+    type 'a t = 'a list
+
+    let empty = []
+    let cons x xs = x::xs
+    let fold = List.fold_right
+  end
+
+  include Generic (ListSequence)
+end
+
+module FingerTree = struct
+  module FingerTreeSequence : SEQUENCE with type 'a t = 'a BatFingerTree.t = struct
+    type 'a t = 'a BatFingerTree.t
+
+    let empty = BatFingerTree.empty
+    let cons x xs = BatFingerTree.cons xs x
+    let fold f xs acc = BatFingerTree.fold_right
+                          (Fun.flip f)
+                          acc
+                          xs
+  end
+
+  include Generic (FingerTreeSequence)
+
+  let map2 f xs ys =
+    let rec frob xs ys acc =
+      match BatFingerTree.front xs with
+      | None -> acc
+      | Some (xs', x) ->
+         match BatFingerTree.front ys with
+         | None -> acc
+         | Some (ys', y) ->
+            f x y
+            |> BatFingerTree.snoc acc
+            |> frob xs' ys'
+    in
+    frob xs ys BatFingerTree.empty
+
+  let zip xs ys = map2 (fun x y -> x, y) xs ys
 
-  let sequence ms = List.fold_right
-                      (fun m acc ->
-                        let* acc = acc in
-                        let* m = m in
-                        Ok (m::acc))
-                      ms
-                      (Ok [])
+  let join ss sep =
+    BatFingerTree.print ~first:"" ~last:"" ~sep:sep BatIO.nwrite
+    |> Fun.flip BatIO.to_string ss
 end
diff --git a/lib/Utilities.mli b/lib/Utilities.mli
index cdb53df..2735009 100644
--- a/lib/Utilities.mli
+++ b/lib/Utilities.mli
@@ -1,5 +1,17 @@
 module Result : sig
   val ( let* ) : ('a, 'e) result -> ('a -> ('b, 'e) result) -> ('b, 'e) result
   val fmap : ('a -> ('b, 'e) result) -> ('a, 'e) result -> ('b, 'e) result
+end
+
+module List : sig
   val sequence : ('a, 'b) result list -> ('a list, 'b) result
 end
+
+module FingerTree : sig
+  val map2 : ('a -> 'b -> 'c) -> 'a BatFingerTree.t -> 'b BatFingerTree.t -> 'c BatFingerTree.t
+  val zip : 'a BatFingerTree.t -> 'b BatFingerTree.t -> ('a * 'b) BatFingerTree.t
+
+  val sequence : ('a, 'b) result BatFingerTree.t -> ('a BatFingerTree.t, 'b) result
+
+  val join : string BatFingerTree.t -> string -> string
+end
diff --git a/lib/concepts/Relation.ml b/lib/concepts/Relation.ml
index a4fb341..ef5ac12 100644
--- a/lib/concepts/Relation.ml
+++ b/lib/concepts/Relation.ml
@@ -50,7 +50,7 @@ let schema_of_bencode value =
   |> List.map (fun (name, domain) ->
          let* domain = Codec.Bencode.as_string domain in
          Ok (name, domain) )
-  |> sequence
+  |> Utilities.List.sequence
   |> Result.map schema_of_list
 
 module Body = struct
diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml
index 5bd427f..af703d7 100644
--- a/lib/kernel/Merkle.ml
+++ b/lib/kernel/Merkle.ml
@@ -27,6 +27,8 @@ module type TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> sig
   val insert : S.transaction -> K.t -> address -> node -> (node, Concepts.Condition.condition) result
   val remove : S.transaction -> K.t -> node -> (node, Concepts.Condition.condition) result
   val lookup : S.transaction -> K.t -> node -> (address option, Concepts.Condition.condition) result
+
+  val fold_left : S.transaction -> ('c -> K.t -> address -> 'c) -> 'c -> node -> ('c, Concepts.Condition.condition) result
 end
 
 module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct
@@ -77,7 +79,7 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct
     let decode_list f data = data
                              |> fmap as_list
                              |> Result.map (List.map f)
-                             |> fmap sequence
+                             |> fmap Utilities.List.sequence
                              |> Result.map BatFingerTree.of_list in
     function
     | Tagged ('!', (Dict _ as data)) ->
@@ -117,18 +119,18 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct
      be used for intermediates and the like. *)
   let hash_of node = to_blob node |> Concepts.Hash.hash_of_blob
 
-  let find tx node =
+  let find tx addr =
     let open Utilities.Result in
-    let* data = S.get tx node in
+    let* data = S.get tx addr in
     match data with
     | None -> Ok None
     | Some data ->
        let* node = from_blob data in
        Ok (Some node)
 
-  let find' tx node =
+  let find' tx addr =
     let open Utilities.Result in
-    let* child = find tx node in
+    let* child = find tx addr in
     match child with
     | Some child -> Ok child
     | None -> failwith "A child node was not found on the underlying storage. Either your database is corrupted, or this is a bug on RNT!"
@@ -282,6 +284,22 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct
        Ok new_root
 
   let remove tx key node = failwith "TODO" [@@warning "-27"]
+
+  let rec fold_left tx f acc =
+    let open Utilities.Result in
+    function
+    | Leaf { keys; values } ->
+       Utilities.FingerTree.zip keys values
+       |> BatFingerTree.fold_left (fun acc (k, v) -> f acc k v) acc
+       |> Result.ok
+    | Trunk { children; _ } ->
+       BatFingerTree.fold_left
+         (fun acc addr ->
+           let* acc = acc in
+           let* node = find' tx addr in
+           fold_left tx f acc node)
+         (Ok acc) children
+
 end
 
 module type INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VALUE) -> sig
@@ -297,6 +315,10 @@ module type INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VA
   val insert : S.transaction -> K.t -> V.t -> node -> (node, Concepts.Condition.condition) result
   val remove : S.transaction -> K.t -> node -> (node, Concepts.Condition.condition) result
   val lookup : S.transaction -> K.t -> node -> (V.t option, Concepts.Condition.condition) result
+
+  val fold_left : S.transaction -> ('c -> K.t -> V.t -> 'c) -> 'c -> node -> ('c, Concepts.Condition.condition) result
+
+  val iter : S.transaction -> (K.t -> V.t -> 'a) -> node -> (unit, Concepts.Condition.condition) result
 end
 
 module Interface : INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VALUE) -> struct
@@ -321,6 +343,12 @@ module Interface : INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY)
        let* v = V.decode data in
        Ok (Some v)
 
+  let retrieve' tx addr =
+    let* v = retrieve tx addr in
+    match v with
+    | Some v -> Ok v
+    | None -> failwith "A value was not found on the underlying storage. Either your database is corrupted, or this is a bug on RNT!"
+
   let find = T.find
   let empty = T.empty
   let hash_of = T.hash_of
@@ -337,4 +365,17 @@ module Interface : INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY)
     | None -> Ok None
     | Some addr -> retrieve tx addr
 
+  let fold_left tx f acc node =
+    T.fold_left tx
+      (fun acc k addr ->
+        let* acc = acc in
+        let* v = retrieve' tx addr in
+        Ok (f acc k v))
+      (Ok acc) node
+    |> Result.join
+
+  let iter tx f node =
+    fold_left tx
+      (fun _ k v -> f k v |> ignore)
+      () node
 end
diff --git a/test/unit/kernel/Merkle.ml b/test/unit/kernel/Merkle.ml
index f12182a..5c610bb 100644
--- a/test/unit/kernel/Merkle.ml
+++ b/test/unit/kernel/Merkle.ml
@@ -31,15 +31,16 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
         let* v3 = T.lookup tx "k3" node in
         let* v3' = T.lookup tx "k3" node' in
         let* bogus = T.lookup tx "fnord" node in
+        let* () = S.abort tx in
         Ok (v1, v2, v3, v3', bogus)
       end
       |> Helpers.condition_as_failure
     in
-    check (option string) "" (Some "v1") v1;
-    check (option string) "" (Some "v2") v2;
-    check (option string) "" (Some "v3") v3;
-    check (option string) "" (Some "toodles") v3';
-    check (option string) "" None bogus
+    check (option string) "that in-memory reads from the first write work properly" (Some "v1") v1;
+    check (option string) "that in-memory reads from the second write work properly" (Some "v2") v2;
+    check (option string) "that in-memory reads from the third write work properly" (Some "v3") v3;
+    check (option string) "that in-memory reads from a value replacement work properly" (Some "toodles") v3';
+    check (option string) "that in-memory reads from a non-existent key returns nothing" None bogus
 
   let persistence conn =
     let addr =
@@ -68,9 +69,29 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
       end
       |> Helpers.condition_as_failure
     in
-    check (option string) "" (Some "v1") v1;
-    check (option string) "" (Some "v2") v2;
-    check (option string) "" (Some "v3") v3
+    check (option string) "that on-disk reads from the first write work properly" (Some "v1") v1;
+    check (option string) "that on-disk reads from the second write work properly" (Some "v2") v2;
+    check (option string) "that on-disk reads from the third write work properly" (Some "v3") v3
+
+  let iteration conn =
+    let keys, values =
+      begin
+        let open Utilities.Result in
+        let* tx = S.start conn in
+        let* node = T.empty
+                    |> T.insert tx "k1" "v1"
+                    |> fmap (T.insert tx "k2" "v2")
+                    |> fmap (T.insert tx "k3" "v3")
+        in
+        let* keys = T.fold_left tx (fun acc k _ -> k :: acc) [] node |> Result.map List.rev in
+        let* values = T.fold_left tx (fun acc _ v -> v :: acc) [] node |> Result.map List.rev in
+        let* () = S.abort tx in
+        Ok (keys, values)
+      end
+      |> Helpers.condition_as_failure
+    in
+    check (list string) "that keys are properly enumerated from left to right" ["k1"; "k2"; "k3"] keys;
+    check (list string) "that values are properly enumerated from left to right" ["v1"; "v2"; "v3"] values
 
   (* TODO: this will need `remove` *)
   (* let determinism _conn = *)
@@ -79,7 +100,8 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
   let suite prefix =
     ( "merkle/" ^ prefix,
       [test_case "insert-and-lookup" `Quick (H.with_connection insert_and_lookup "merkle-test");
-       test_case "persistence" `Quick (H.with_connection persistence "merkle-test")])
+       test_case "persistence" `Quick (H.with_connection persistence "merkle-test");
+       test_case "iteration" `Quick (H.with_connection iteration "merkle-test")])
 end
 
 module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator)