format and where claude on fol

6 files changed, 133 insertions, 28 deletions

diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml
index 6f851ed..060efae 100644
--- a/lib/kernel/Branch.ml
+++ b/lib/kernel/Branch.ml
@@ -133,7 +133,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct
               object
                 method check =
                   let* named = Directory.children multigroups in
-                  Utilities.List.concat_mapm admits (BatFingerTree.to_list named) (* FIXME: use finger trees *)
+                  Utilities.List.concat_mapm admits (BatFingerTree.to_list named)
+                (* FIXME: use finger trees *)
               end;
             Prototype.Associative.(
               of_properties
diff --git a/lib/kernel/Generator.ml b/lib/kernel/Generator.ml
index b83de3b..a037b3d 100644
--- a/lib/kernel/Generator.ml
+++ b/lib/kernel/Generator.ml
@@ -53,3 +53,19 @@ class producer_cursor produce finally =
   end
 
 let cursor_of ?finally produce = new producer_cursor produce finally |> Protocols.Handle.make
+
+let filter keep cursor =
+  cursor_of
+    ~finally:(fun () -> Protocols.Handle.release cursor)
+    (fun ~yield ->
+      let open Utilities.Result in
+      let* scan = Protocols.Cursor.require cursor in
+      let rec pass () =
+        let* next = Protocols.Cursor.next scan in
+        match next with
+        | None -> Ok ()
+        | Some tuple ->
+            if keep tuple then yield tuple;
+            pass ()
+      in
+      pass () )
diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml
index 4882ec4..b8599d5 100644
--- a/lib/kernel/Merkle.ml
+++ b/lib/kernel/Merkle.ml
@@ -30,7 +30,10 @@ module type TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> sig
     S.transaction -> K.t -> address -> node -> (node, Concepts.Condition.condition) result
 
   val of_list : S.transaction -> (K.t * address) list -> (node, Concepts.Condition.condition) result
-  val of_finger_tree : S.transaction -> (K.t * address) BatFingerTree.t -> (node, Concepts.Condition.condition) result
+
+  val of_finger_tree :
+    S.transaction -> (K.t * address) BatFingerTree.t -> (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
 
diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml
index f28abc4..84ef3f8 100644
--- a/lib/kernel/Multigroup.ml
+++ b/lib/kernel/Multigroup.ml
@@ -112,7 +112,9 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     let open Utilities.Result in
     let* listing = Protocols.Handle.require Protocols.Directory.from h in
     let* found = Protocols.Directory.find listing property in
-    let* children = Option.fold ~none:(Ok BatFingerTree.empty) ~some:Protocols.Directory.children found in
+    let* children =
+      Option.fold ~none:(Ok BatFingerTree.empty) ~some:Protocols.Directory.children found
+    in
     BatFingerTree.map
       (fun (name, child) ->
         Prototype.Associative.admission admit name child |> Result.map (fun p -> name, p) )
@@ -121,7 +123,9 @@ module Make (S : Abstract.Storage.STORAGE) = struct
 
   let tree_of tx admissions =
     let open Utilities.Result in
-    BatFingerTree.map (fun (name, store) -> store tx |> Result.map (fun addr -> name, addr)) admissions
+    BatFingerTree.map
+      (fun (name, store) -> store tx |> Result.map (fun addr -> name, addr))
+      admissions
     |> Utilities.FingerTree.sequence
     |>> T.of_finger_tree tx
 
@@ -227,7 +231,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct
       method check =
         let open Utilities.Result in
         let* named = Protocols.Directory.children (relations ?bind storage denial_tree) in
-        let named = BatFingerTree.to_list named in (* FIXME *)
+        let named = BatFingerTree.to_list named in
+        (* FIXME *)
         Utilities.List.concat_mapm (held ?bind) named
 
       method protocols : Protocols.Handle.protocol list =
diff --git a/lib/kernel/Scope.ml b/lib/kernel/Scope.ml
index ba9c1e0..817da97 100644
--- a/lib/kernel/Scope.ml
+++ b/lib/kernel/Scope.ml
@@ -44,7 +44,9 @@ let attribute home relation text =
 (* every relation of a branch state, as multigroup:schema:relation *)
 let catalog_of branch =
   let open Utilities.Result in
-  let name prefix last = Utilities.FingerTree.join (BatFingerTree.reverse (BatFingerTree.cons prefix last)) ":" in
+  let name prefix last =
+    Utilities.FingerTree.join (BatFingerTree.reverse (BatFingerTree.cons prefix last)) ":"
+  in
   let rec down prefix handle properties =
     let* level = Path.find handle Path.(List.hd properties @/ this) in
     match level, List.tl properties with
@@ -55,7 +57,9 @@ let catalog_of branch =
         Ok (BatFingerTree.map (name prefix) names)
     | Some level, rest ->
         let* named = Protocols.Directory.children level in
-        Utilities.FingerTree.concat_mapm (fun (n, child) -> down (BatFingerTree.cons prefix n) child rest) named
+        Utilities.FingerTree.concat_mapm
+          (fun (n, child) -> down (BatFingerTree.cons prefix n) child rest)
+          named
   in
   down BatFingerTree.empty branch ["multigroup"; "schema"; "relation"]
 
@@ -88,7 +92,9 @@ let rec make branch home =
             let* previous = Path.find branch Path.("previous" @/ this) in
             Ok (Option.map (fun p -> make p home) previous)
 
-          method catalog = catalog_of branch |> Result.map BatFingerTree.to_list (* FIXME: use finger trees thoroughly *)
+          method catalog =
+            catalog_of branch
+            |> Result.map BatFingerTree.to_list (* FIXME: use finger trees thoroughly *)
         end ]
 
 let heads = Path.("system" @/ "branch" @/ this)
diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml
index fe9e34f..3e7945d 100644
--- a/lib/kernel/SubstantialRelation.ml
+++ b/lib/kernel/SubstantialRelation.ml
@@ -19,6 +19,20 @@ module Make (S : Abstract.Storage.STORAGE) = struct
         "The tuple-set root for a substantial relation is missing from the backend. Either your \
          storage is corrupted, or this is a bug in RNT!"
         ("hash" |=| Concepts.Value.String (Concepts.Hash.to_hum_string root))
+
+    let missing_attribute name =
+      condition "missing-attribute" "A tuple to store has no value for an attribute of its relation"
+        ("attribute" |=| Concepts.Value.String name)
+
+    let unindexed_attribute name =
+      condition "unindexed-attribute" "A relation was looked up on an attribute it has no index for"
+        ("attribute" |=| Concepts.Value.String name)
+
+    let invalid_index_root root =
+      condition "invalid-index-root"
+        "An index root for a substantial relation is missing from the backend. Either your storage \
+         is corrupted, or this is a bug in RNT!"
+        ("hash" |=| Concepts.Value.String (Concepts.Hash.to_hum_string root))
   end
 
   module TupleKey = struct
@@ -42,8 +56,12 @@ module Make (S : Abstract.Storage.STORAGE) = struct
   end
 
   module TupleSet = Merkle.Interface (S) (TupleKey) (TupleValue)
+  module Index = Merkle.Make (S) (Merkle.StringKey)
 
-  type t = {schematics: Concepts.Hash.hash; tuples: TupleSet.address}
+  type t =
+    { schematics: Concepts.Hash.hash;
+      tuples: TupleSet.address;
+      indexes: Index.address BatMap.String.t }
 
   module rec Representation : (Concepts.Encoding.Record.S with type t = t) =
     Concepts.Encoding.Record.Make (Body)
@@ -54,16 +72,26 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     let tag = 'R'
     let malformed = Error.malformed_relation
 
-    let fields {schematics; tuples} =
+    let fields {schematics; tuples; indexes} =
       let open Concepts.Encoding in
-      ["schema", Value.bencode_of_hash schematics; "tuples", Value.bencode_of_hash tuples]
+      [ "schema", Value.bencode_of_hash schematics;
+        "tuples", Value.bencode_of_hash tuples;
+        ( "indexes",
+          Bencode.Dict
+            (BatMap.String.bindings indexes |> List.map (fun (a, h) -> a, Value.bencode_of_hash h))
+        ) ]
 
     let of_fields fields =
       let open Utilities.Result in
       let open Concepts.Encoding in
       let* schematics = Bencode.field "schema" fields |>> Value.hash_of_bencode in
       let* tuples = Bencode.field "tuples" fields |>> Value.hash_of_bencode in
-      Ok {schematics; tuples}
+      let* indexes = Bencode.field "indexes" fields |>> Bencode.as_dict in
+      let* indexes =
+        List.map (fun (a, h) -> Value.hash_of_bencode h |> Result.map (fun h -> a, h)) indexes
+        |> Utilities.List.sequence
+      in
+      Ok {schematics; tuples; indexes= BatMap.String.of_list indexes}
   end
 
   let encode = Representation.to_blob
@@ -94,14 +122,40 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     |> Utilities.List.sequence
     |> Result.map BatMap.String.of_list
 
-  let enumerate connection relation =
+  let prefix value =
+    Concepts.Encoding.Bencode.to_bytes (Concepts.Tuple.bencode_of_value value) |> Bytes.to_string
+
+  let reading connection start walk =
     let open Utilities.Result in
     let* tx = S.start_read connection in
     let close () = ignore (S.abort tx) in
-    let* node = tuple_node tx relation |> Result.map_error (fun c -> close (); c) in
-    Ok
-      (Generator.cursor_of ~finally:close (fun ~yield ->
-           TupleSet.iter tx (fun _ tuple -> yield tuple) node ) )
+    let* node = start tx |> Result.map_error (fun c -> close (); c) in
+    Ok (Generator.cursor_of ~finally:close (walk tx node))
+
+  let enumerate connection relation =
+    reading connection
+      (fun tx -> tuple_node tx relation)
+      (fun tx node ~yield -> TupleSet.iter tx (fun _ tuple -> yield tuple) node)
+
+  let lookup connection relation attribute value =
+    let open Utilities.Result in
+    let* root =
+      BatMap.String.find_opt attribute relation.indexes
+      |> Option.to_result ~none:(Error.unindexed_attribute attribute)
+    in
+    let prefix = 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))
+          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 )
 
   class substantial_relation connection value description =
     object (self)
@@ -118,11 +172,13 @@ module Make (S : Abstract.Storage.STORAGE) = struct
 
       method modes =
         Ok
-          Concepts.
-            [ Mode.mode [] Cardinality.Finite;
-              Mode.mode (List.map fst (BatMap.String.bindings description)) (Cardinality.bounded 1)
-            ]
+          Concepts.(
+            Mode.mode [] Cardinality.Finite
+            :: Mode.mode (List.map fst (BatMap.String.bindings description)) (Cardinality.bounded 1)
+            :: List.map (fun a -> Mode.mode [a] Cardinality.Finite) self#indexes )
 
+      method indexes = List.map fst (BatMap.String.bindings relation.indexes)
+      method lookup attribute value = lookup connection relation attribute value
       method describe () = Ok (Protocols.Schematics.Relation description)
       method enumerate = enumerate connection relation
 
@@ -130,6 +186,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
         [ Protocols.Addressable.make self;
           Protocols.Relation.make self;
           Protocols.Enumerable.make self;
+          Protocols.Indexed.make self;
           Protocols.Schematics.make self ]
 
       method hash = encode relation |> Concepts.Hash.hash_of_blob
@@ -141,13 +198,32 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     |> Result.map (fun description ->
         new substantial_relation connection relation description |> Protocols.Handle.make )
 
+  let index tx attribute hashed =
+    let open Utilities.Result in
+    let* entries =
+      List.map
+        (fun (hash, tuple) ->
+          match BatMap.String.find_opt attribute tuple.Concepts.Tuple.attributes with
+          | Some value -> Ok (prefix value ^ Concepts.Hash.to_raw_string hash, hash)
+          | None -> Error (Error.missing_attribute attribute) )
+        hashed
+      |> Utilities.List.sequence
+    in
+    Index.of_list tx entries |> Result.map (fun node -> attribute, Index.hash_of node)
+
   let store tx description tuples =
     let open Utilities.Result in
     let* schematics = store_schema tx description in
-    let* node =
-      TupleSet.of_list tx (List.map (fun tuple -> Concepts.Tuple.hash tuple, tuple) tuples)
+    let hashed = List.map (fun tuple -> Concepts.Tuple.hash tuple, tuple) tuples in
+    let* node = TupleSet.of_list tx hashed in
+    let* indexes =
+      BatMap.String.bindings description
+      |> List.map (fun (attribute, _) -> index tx attribute hashed)
+      |> Utilities.List.sequence
+    in
+    let relation =
+      {schematics; tuples= TupleSet.hash_of node; indexes= BatMap.String.of_list indexes}
     in
-    let relation = {schematics; tuples= TupleSet.hash_of node} in
     let* _ = SI.store_blob tx (encode relation) in
     Ok relation
 
@@ -155,10 +231,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     let open Utilities.Result in
     let* relation =
       SI.with_transaction connection (fun tx ->
-          let* tuples = TupleSet.empty_under tx in
-          let relation = {schematics; tuples} in
-          let* _ = SI.store_blob tx (encode relation) in
-          Ok relation )
+          let* description = schema_of tx schematics in
+          store tx description [] )
     in
     load connection relation
 end