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

4 files changed, 125 insertions, 13 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