lift retaining, membership and mode checks out of ephemeral relation

6 files changed, 74 insertions, 4 deletions

diff --git a/lib/protocols/Cursor.ml b/lib/protocols/Cursor.ml
index 36db97d..75dc77d 100644
--- a/lib/protocols/Cursor.ml
+++ b/lib/protocols/Cursor.ml
@@ -26,6 +26,13 @@ let rec next i =
   | Some (_, tuple) -> Ok (Some tuple)
   | None -> if batch.exhausted then Ok None else next i
 
+let rec exists i p =
+  let open Utilities.Result in
+  let* found = next i in
+  match found with
+  | None -> Ok false
+  | Some tuple -> if p tuple then Ok true else exists i p
+
 let drain i ?(limit = 256) () =
   let open Utilities.Result in
   let rec loop tuples =
diff --git a/lib/protocols/Cursor.mli b/lib/protocols/Cursor.mli
index 08c7628..c977fec 100644
--- a/lib/protocols/Cursor.mli
+++ b/lib/protocols/Cursor.mli
@@ -14,6 +14,11 @@ val fetch : t Handle.interface -> int -> (batch, Concepts.Condition.condition) r
 
 val next : t Handle.interface -> (Concepts.Tuple.t option, Concepts.Condition.condition) result
 
+val exists :
+  t Handle.interface ->
+  (Concepts.Tuple.t -> bool) ->
+  (bool, Concepts.Condition.condition) result
+
 val drain :
   t Handle.interface ->
   ?limit:int ->
diff --git a/lib/protocols/Generative.ml b/lib/protocols/Generative.ml
index 065ffcb..bd89e21 100644
--- a/lib/protocols/Generative.ml
+++ b/lib/protocols/Generative.ml
@@ -7,6 +7,18 @@ module Error = struct
        declares no modes. A relation that cannot be asked this way can still be reached through \
        another access path."
       empty
+
+  let attributes bound = Concepts.Value.String (String.concat ", " (BatSet.String.elements bound))
+
+  let ungenerable bound =
+    condition "ungenerable-binding"
+      "The relation declares no mode that generates under the attributes bound."
+      ("bound" |=| attributes bound)
+
+  let undecidable bound =
+    condition "undecidable-membership"
+      "The relation declares no mode that decides membership under the attributes of the tuple."
+      ("bound" |=| attributes bound)
 end
 
 type binding = Concepts.Value.value BatMap.String.t
@@ -22,10 +34,17 @@ type t = implementation
 let make impl = Generative (impl :> implementation)
 let from handle = Handle.into handle (function Generative impl -> Some impl | _ -> None)
 let require handle = from handle |> Option.to_result ~none:(Error.not_generative ())
-let modes i = Handle.invoke i (fun o -> o#modes)
-let generate i binding = Handle.invoke i (fun o -> o#generate binding)
 let nothing = BatMap.String.empty
-let bound binding = BatMap.String.keys binding |> BatSet.String.of_enum
+let bound = Concepts.Mode.attributes_of_map
+let modes i = Handle.invoke i (fun o -> o#modes)
+
+let generate i binding =
+  Handle.invoke i (fun o ->
+      let open Utilities.Result in
+      let bound = bound binding in
+      let* declaration = o#modes in
+      if Option.is_some (Concepts.Mode.generation declaration bound) then o#generate binding
+      else Error (Error.ungenerable bound) )
 
 let satisfies binding tuple =
   BatMap.String.for_all
@@ -34,3 +53,29 @@ let satisfies binding tuple =
       | Some found -> Concepts.Value.equal found value
       | None -> false )
     binding
+
+class virtual membership =
+  object (self)
+    val virtual heading : Concepts.Mode.attributes
+    method virtual modes : (Concepts.Mode.t, Concepts.Condition.condition) result
+    method virtual generate : binding -> (Handle.t, Concepts.Condition.condition) result
+
+    method contains (tuple : Concepts.Tuple.t) =
+      let open Utilities.Result in
+      let binding = tuple.Concepts.Tuple.attributes in
+      let bound = bound binding in
+      if not (BatSet.String.equal heading bound) then Ok false
+      else
+        let* declaration = self#modes in
+        let* () =
+          if Concepts.Mode.decision declaration bound then Ok () else Error (Error.undecidable bound)
+        in
+        let* cursor = self#generate binding in
+        let expected = Concepts.Tuple.hash tuple in
+        Fun.protect
+          ~finally:(fun () -> Handle.release cursor)
+          (fun () ->
+            let* scan = Cursor.require cursor in
+            Cursor.exists scan (fun member ->
+                Concepts.Hash.hash_equals (Concepts.Tuple.hash member) expected ) )
+  end
diff --git a/lib/protocols/Generative.mli b/lib/protocols/Generative.mli
index 14e2c13..5ada329 100644
--- a/lib/protocols/Generative.mli
+++ b/lib/protocols/Generative.mli
@@ -16,9 +16,20 @@ val modes : t Handle.interface -> (Concepts.Mode.t, Concepts.Condition.condition
 
 (** a handle carrying a cursor over the members agreeing with the
     binding and under the empty binding this is enumeration, so a
-    relation carrying enumerable answers the same members here. *)
+    relation carrying enumerable answers the same members here. Refused
+    when no declared mode generates under the attributes bound. *)
 val generate : t Handle.interface -> binding -> (Handle.t, Concepts.Condition.condition) result
 
 val nothing : binding
 val bound : binding -> Concepts.Mode.attributes
 val satisfies : binding -> Concepts.Tuple.t -> bool
+
+(** membership for a relation with no lookup of its own, asked of the
+    generator under the binding the tuple fixes. Only a tuple carrying
+    exactly the [heading] can be a member, and it must match one whole. *)
+class virtual membership : object
+  val virtual heading : Concepts.Mode.attributes
+  method virtual modes : (Concepts.Mode.t, Concepts.Condition.condition) result
+  method virtual generate : binding -> (Handle.t, Concepts.Condition.condition) result
+  method contains : Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result
+end
diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml
index cb78cf2..378b8c8 100644
--- a/lib/protocols/Handle.ml
+++ b/lib/protocols/Handle.ml
@@ -49,6 +49,7 @@ let equal h1 h2 =
   Concepts.Hash.hash_equals (object_of h1)#hash (object_of h2)#hash
 
 let hash h = (object_of h)#hash
+let protocols h = (object_of h)#protocols
 
 let release ({ valid; _ } as handle) =
   let o = object_of handle in
diff --git a/lib/protocols/Handle.mli b/lib/protocols/Handle.mli
index 5640b14..c5c0d6a 100644
--- a/lib/protocols/Handle.mli
+++ b/lib/protocols/Handle.mli
@@ -23,5 +23,6 @@ val equal : t -> t -> bool
 val release : t -> unit
 
 val hash : t -> Concepts.Hash.hash
+val protocols : t -> protocol list
 
 val require : (t -> 'a interface option) -> t -> ('a interface, Concepts.Condition.condition) result