range on the interface fold, stopping at the first error

2 files changed, 28 insertions, 25 deletions

diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml
index b8599d5..be4618b 100644
--- a/lib/kernel/Merkle.ml
+++ b/lib/kernel/Merkle.ml
@@ -37,6 +37,15 @@ module type TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> sig
   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 foldm_left :
+    ?from:K.t ->
+    ?until:(K.t -> bool) ->
+    S.transaction ->
+    ('c -> K.t -> address -> ('c, Concepts.Condition.condition) result) ->
+    'c ->
+    node ->
+    ('c, Concepts.Condition.condition) result
+
   val fold_left :
     ?from:K.t ->
     ?until:(K.t -> bool) ->
@@ -349,19 +358,19 @@ functor
     let drop i ft =
       if i < BatFingerTree.size ft then snd (BatFingerTree.split_at ft i) else BatFingerTree.empty
 
-    let fold_left ?from ?(until = fun _ -> false) tx f acc node =
+    let foldm_left ?from ?(until = fun _ -> false) tx f acc node =
       let open Utilities.Result in
       let rec walk from acc = function
         | Leaf {keys; values} ->
             let i = Option.fold ~none:0 ~some:(fun key -> fst (lookup1 keys key)) from in
             Utilities.FingerTree.zip (drop i keys) (drop i values)
-            |> BatFingerTree.fold_left
+            |> Utilities.FingerTree.foldm_left
                  (fun step (k, v) ->
                    match step with
-                   | `Continue acc -> if until k then `Stop acc else `Continue (f acc k v)
-                   | `Stop _ -> step )
+                   | `Continue acc when until k -> Ok (`Stop acc)
+                   | `Continue acc -> f acc k v |> Result.map (fun acc -> `Continue acc)
+                   | `Stop _ -> Ok step )
                  (`Continue acc)
-            |> Result.ok
         | Trunk {keys; children} ->
             let i =
               Option.fold ~none:0
@@ -384,6 +393,8 @@ functor
       in
       walk from acc node |> Result.map (function `Continue acc | `Stop acc -> acc)
 
+    let fold_left ?from ?until tx f = foldm_left ?from ?until tx (fun acc k v -> Ok (f acc k v))
+
     let keys tx node =
       fold_left tx (fun acc k _ -> BatFingerTree.snoc acc k) BatFingerTree.empty node
 
@@ -459,6 +470,8 @@ module type INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VA
   val mem : S.transaction -> K.t -> node -> (bool, Concepts.Condition.condition) result
 
   val fold_left :
+    ?from:K.t ->
+    ?until:(K.t -> bool) ->
     S.transaction ->
     ('c -> K.t -> V.t -> 'c) ->
     'c ->
@@ -518,14 +531,8 @@ functor
 
     let mem tx k node = Tree.lookup tx k node |> Result.map Option.is_some
 
-    let fold_left tx f acc node =
-      Tree.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 fold_left ?from ?until tx f =
+      Tree.foldm_left ?from ?until tx (fun acc k addr -> retrieve tx addr |> Result.map (f acc k))
 
     let iter tx f node = fold_left tx (fun _ k v -> f k v |> ignore) () node
     let keys = Tree.keys
diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml
index 193df98..e89b008 100644
--- a/lib/kernel/SubstantialRelation.ml
+++ b/lib/kernel/SubstantialRelation.ml
@@ -61,7 +61,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
   end
 
   module TupleSet = Merkle.Interface (S) (TupleKey) (TupleValue)
-  module Index = Merkle.Make (S) (Merkle.StringKey)
+  module Index = Merkle.Interface (S) (Merkle.StringKey) (TupleValue)
 
   type t =
     { schematics: Concepts.Hash.hash;
@@ -150,19 +150,15 @@ module Make (S : Abstract.Storage.STORAGE) = struct
       BatMap.String.find_opt attribute relation.indexes
       |> Option.to_result ~none:(Error.unindexed_attribute attribute)
     in
-    let prefix = prefix value in
+    let start = prefix value in
     reading connection
       (fun tx -> Index.find tx root |>> Option.to_result ~none:(Error.invalid_index_root root))
       (fun tx node ~yield ->
-        Index.fold_left ~from:prefix
-          ~until:(fun key -> not (String.starts_with ~prefix key))
+        Index.fold_left ~from:start
+          ~until:(fun key -> not (String.starts_with ~prefix:start key))
           tx
-          (fun read _ address ->
-            let* () = read in
-            let* tuple = SI.get_req tx (S.Hash address) |>> TupleValue.decode in
-            Ok (yield tuple) )
-          (Ok ()) node
-        |> Result.join )
+          (fun () _ tuple -> yield tuple)
+          () node )
 
   class substantial_relation connection value description =
     object (self)
@@ -223,8 +219,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct
           ^ Concepts.Hash.to_raw_string hash,
           hash ) )
       hashed
-    |> Index.of_list tx
-    |> Result.map (fun node -> attribute, Index.hash_of node)
+    |> Index.Tree.of_list tx
+    |> Result.map (fun node -> attribute, Index.Tree.hash_of node)
 
   let store tx description tuples =
     let open Utilities.Result in