1 files changed, 73 insertions, 16 deletions

diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml
index eebae3e..6592acb 100644
--- a/lib/kernel/SubstantialRelation.ml
+++ b/lib/kernel/SubstantialRelation.ml
@@ -37,7 +37,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
   module TupleSet = Merkle.Make (S) (TupleKey)
 
   type t =
-    { heading: Concepts.Hash.hash;
+    { schematics: Concepts.Hash.hash;
       predicate: Concepts.Hash.hash option;
       local_constraints: Concepts.Hash.hash option;
       tuples: TupleSet.address;
@@ -52,9 +52,9 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     let tag = 'R'
     let malformed = Error.malformed_relation
 
-    let fields {heading; predicate; local_constraints; tuples; indexes} =
+    let fields {schematics; predicate; local_constraints; tuples; indexes} =
       let open Concepts.Encoding in
-      [ "heading", Value.bencode_of_hash heading;
+      [ "schema", Value.bencode_of_hash schematics;
         "predicate", Value.bencode_of_option Value.bencode_of_hash predicate;
         "local-constraints", Value.bencode_of_option Value.bencode_of_hash local_constraints;
         "tuples", Value.bencode_of_hash tuples;
@@ -63,7 +63,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     let of_fields fields =
       let open Utilities.Result in
       let open Concepts.Encoding in
-      let* heading = Bencode.field "heading" fields |> fmap Value.hash_of_bencode in
+      let* schematics = Bencode.field "schema" fields |> fmap Value.hash_of_bencode in
       let* predicate =
         Bencode.field "predicate" fields |> fmap (Value.option_of_bencode Value.hash_of_bencode)
       in
@@ -75,13 +75,13 @@ module Make (S : Abstract.Storage.STORAGE) = struct
       let* indexes =
         Bencode.field "indexes" fields |> fmap (Value.option_of_bencode Value.hash_of_bencode)
       in
-      Ok {heading; predicate; local_constraints; tuples; indexes}
+      Ok {schematics; predicate; local_constraints; tuples; indexes}
   end
 
   let encode = Representation.to_blob
   let decode = Representation.of_blob
 
-  let heading {heading; _} = heading
+  let schematics {schematics; _} = schematics
   let predicate {predicate; _} = predicate
   let local_constraints {local_constraints; _} = local_constraints
   let tuples {tuples; _} = tuples
@@ -93,10 +93,10 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     let* tuples = TupleSet.find tx relation.tuples in
     Option.to_result ~none:(Error.invalid_tuple_root relation.tuples) tuples
 
-  let empty tx ~heading ?predicate ?local_constraints ?indexes () =
+  let empty tx ~schematics ?predicate ?local_constraints ?indexes () =
     let open Utilities.Result in
     let* tuples = TupleSet.empty_under tx in
-    Ok {heading; predicate; local_constraints; tuples; indexes}
+    Ok {schematics; predicate; local_constraints; tuples; indexes}
 
   let store tx relation = SI.store_blob tx (Representation.to_blob relation)
 
@@ -107,27 +107,84 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     let* present = TupleSet.lookup tx tuple node in
     Ok (Option.is_some present)
 
+  let schema_of tx relation =
+    let open Utilities.Result in
+    let* data = SI.get_req tx (S.Hash relation.schematics) in
+    let* fields = Concepts.Encoding.Bencode.of_blob data in
+    let* kvs = Concepts.Encoding.Bencode.as_dict fields in
+    kvs
+    |> List.map (fun (name, domain) ->
+           Concepts.Encoding.Bencode.as_string domain
+           |> Result.map (fun domain -> (name, domain)))
+    |> Utilities.List.sequence
+    |> Result.map (fun kvs ->
+           List.fold_left
+             (fun acc (name, domain) -> BatMap.String.add name domain acc)
+             BatMap.String.empty kvs)
+
+  let enumerate storage relation =
+    let open Utilities.Result in
+    let* tx = S.start storage in
+    let* node = tuple_node tx relation in
+    let closed = ref false in
+    let close () = if not !closed then begin closed := true; ignore (S.abort tx) end in
+    (* The fold is suspended by [yield], so the tree is walked one node
+       and one tuple at a time rather than materialized before the
+       first tuple is produced. *)
+    let produce ~yield =
+      let* walked =
+        TupleSet.fold_left tx
+          (fun acc _ addr ->
+            let* () = acc in
+            let* tuple =
+              SI.get_req tx (S.Hash addr) |> fmap Concepts.Tuple.Representation.of_blob
+            in
+            yield tuple;
+            Ok ())
+          (Ok ()) node
+      in
+      close ();
+      walked
+    in
+    Ok (Generator.cursor_of ~on_release:close produce)
+
   class relation storage value =
     object (self)
       inherit Lifecycle.null
       val storage : S.connection = storage
       val relation : t = value
-      method heading = Ok relation.heading
       method predicate = Ok relation.predicate
       method local_constraints = Ok relation.local_constraints
-      method tuples = Ok relation.tuples
-
-      method contains tuple =
-        SI.with_transaction storage (fun tx -> contains_tuple tx relation tuple)
 
-      method protocols : Protocols.Handle.protocol list = Protocols.[Relation.make self]
+      (* The protocol takes a tuple, not bytes: encoding is this object's business, and a caller
+         that had to produce the exact stored bytes would have to know this encoding to do it. *)
+      method contains (tuple : Concepts.Tuple.t) =
+        SI.with_transaction storage (fun tx ->
+            contains_tuple tx relation (Concepts.Tuple.Representation.to_blob tuple) )
+
+      method describe () =
+        let open Utilities.Result in
+        let* description = SI.with_transaction storage (fun tx -> schema_of tx relation) in
+        Ok (Protocols.Schematics.Relation description)
+
+      (* A substantial relation is finitely enumerable, so it carries [Enumerable] as well as
+         [Relation]. A procedural relation would carry only the latter, which is how an evaluator
+         discovers it cannot iterate one -- see [Protocols.Enumerable]. The context is accepted and
+         unused here: this enumeration reads through its own cursor-lifetime transaction and needs
+         no name resolution, but cancellation should eventually be checked between tuples. *)
+      method enumerate (_ : Protocols.Context.t) = enumerate storage relation
+
+      method protocols : Protocols.Handle.protocol list =
+        [ Protocols.Relation.make self
+        ; Protocols.Enumerable.make self
+        ; Protocols.Schematics.make self ]
       method hash = hash relation
     end
 
-  let make conn ~heading ?predicate ?local_constraints ?indexes () =
+  let make conn ~schematics ?predicate ?local_constraints ?indexes () =
     let open Utilities.Result in
     SI.with_transaction conn (fun tx ->
-        let* relation = empty tx ~heading ?predicate ?local_constraints ?indexes () in
+        let* relation = empty tx ~schematics ?predicate ?local_constraints ?indexes () in
         let* _ = store tx relation in
         Ok (new relation conn relation |> Protocols.Handle.make) )