lift retaining, membership and mode checks out of ephemeral relation

12 files changed, 107 insertions, 81 deletions

diff --git a/lib/concepts/Mode.ml b/lib/concepts/Mode.ml
index 6ac1704..fc3ef84 100644
--- a/lib/concepts/Mode.ml
+++ b/lib/concepts/Mode.ml
@@ -5,6 +5,7 @@ type mode = {bound: attributes; affords: affordance}
 type t = mode list
 
 let attributes_of_list = BatSet.String.of_list
+let attributes_of_map map = BatMap.String.keys map |> BatSet.String.of_enum
 let decides_when bound = {bound= attributes_of_list bound; affords= Decides}
 
 let generates_when bound cardinality =
diff --git a/lib/concepts/Mode.mli b/lib/concepts/Mode.mli
index 8d84093..018eeb2 100644
--- a/lib/concepts/Mode.mli
+++ b/lib/concepts/Mode.mli
@@ -11,6 +11,7 @@ type mode = {bound: attributes; affords: affordance}
 type t
 
 val attributes_of_list : attribute list -> attributes
+val attributes_of_map : 'a BatMap.String.t -> attributes
 val decides_when : attribute list -> mode
 val generates_when : attribute list -> Cardinality.t -> mode
 val enumerable : Cardinality.t -> mode
diff --git a/lib/kernel/EphemeralRelation.ml b/lib/kernel/EphemeralRelation.ml
index 29b15ed..b403e13 100644
--- a/lib/kernel/EphemeralRelation.ml
+++ b/lib/kernel/EphemeralRelation.ml
@@ -15,22 +15,6 @@ module type DERIVATION = sig
 end
 
 module Make (D : DERIVATION) = struct
-  module Error = struct
-    open Concepts.Condition
-
-    let attributes bound = Concepts.Value.String (String.concat ", " (BatSet.String.elements bound))
-
-    let ungenerable bound =
-      condition "ungenerable-binding"
-        "The derivation declares no mode that generates under the attributes bound."
-        ("bound" |=| attributes bound)
-
-    let undecidable bound =
-      condition "undecidable-membership"
-        "The derivation declares no mode that decides membership under the attributes of the tuple."
-        ("bound" |=| attributes bound)
-  end
-
   let pinned_tag = "rnt/pinned/1"
 
   let identity ?pinned plan =
@@ -42,78 +26,26 @@ module Make (D : DERIVATION) = struct
         |> Bytes.of_string
         |> Concepts.Hash.hash_of_bytes
 
-  (* A cursor holds a reference to its relation, so the edges it reads
-     outlive a release of the relation that produced it. *)
-  class retaining scan release_owner =
-    object (self)
-      inherit Lifecycle.counted
-      inherit Identity.of_id
-
-      method destroy =
-        Protocols.Handle.release (Protocols.Handle.from scan);
-        release_owner ()
-
-      method fetch limit = Protocols.Cursor.fetch scan limit
-      method protocols : Protocols.Handle.protocol list = [Protocols.Cursor.make self]
-    end
-
   class ephemeral (plan : D.plan) address declaration description edges =
     object (self)
       inherit Lifecycle.counted
-      val heading = BatMap.String.keys description |> BatSet.String.of_enum
+      inherit Protocols.Generative.membership
+      val heading = Concepts.Mode.attributes_of_map description
       method destroy = List.iter Protocols.Handle.release edges
       method predicate = Ok None
       method local_constraints = Ok None
       method modes = Ok declaration
 
+      (* A cursor holds a reference to its relation, so the edges it reads
+         outlive a release of the relation that produced it. *)
       method generate binding =
-        let open Utilities.Result in
-        let bound = Protocols.Generative.bound binding in
-        let* () =
-          if Option.is_some (Concepts.Mode.generation declaration bound) then Ok ()
-          else Error (Error.ungenerable bound)
-        in
-        let* cursor = D.generate plan binding in
-        match Protocols.Cursor.require cursor with
-        | Error c ->
-            Protocols.Handle.release cursor;
-            Error c
-        | Ok scan ->
-            ignore self#reference;
-            Ok (new retaining scan (fun () -> self#release) |> Protocols.Handle.make)
+        D.generate plan binding
+        |> Result.map (fun cursor ->
+               new Lifecycle.retaining cursor (self :> Lifecycle.lifecycle) |> Protocols.Handle.make )
 
       method enumerate = self#generate Protocols.Generative.nothing
       method describe () = Ok (Protocols.Schematics.Relation description)
 
-      (* Membership of a derived relation is decided by the derivation
-         and not by a lookup, so it is asked of the generator under the
-         binding the tuple itself fixes. Only a tuple carrying exactly the
-         described attributes can be a member, and it must match one whole. *)
-      method contains (tuple : Concepts.Tuple.t) =
-        let open Utilities.Result in
-        let binding = tuple.Concepts.Tuple.attributes in
-        let bound = Protocols.Generative.bound binding in
-        if not (BatSet.String.equal heading bound) then Ok false
-        else
-          let* () =
-            if Concepts.Mode.decision declaration bound then Ok () else Error (Error.undecidable bound)
-          in
-          let* cursor = D.generate plan binding in
-          let expected = Concepts.Tuple.hash tuple in
-          Fun.protect
-            ~finally:(fun () -> Protocols.Handle.release cursor)
-            (fun () ->
-              let* scan = Protocols.Cursor.require cursor in
-              let rec seek () =
-                let* found = Protocols.Cursor.next scan in
-                match found with
-                | None -> Ok false
-                | Some member ->
-                    if Concepts.Hash.hash_equals (Concepts.Tuple.hash member) expected then Ok true
-                    else seek ()
-              in
-              seek () )
-
       method protocols : Protocols.Handle.protocol list =
         let carried =
           [ Protocols.Relation.make self;
diff --git a/lib/kernel/Lifecycle.ml b/lib/kernel/Lifecycle.ml
index 20282dd..772cb6e 100644
--- a/lib/kernel/Lifecycle.ml
+++ b/lib/kernel/Lifecycle.ml
@@ -26,3 +26,15 @@ class virtual counted = object (self)
     if Atomic.fetch_and_add references (-1) = 1 then
       self#destroy
 end
+
+class retaining inner (owner : lifecycle) = object
+  inherit counted
+  initializer ignore owner#reference
+
+  method destroy =
+    Protocols.Handle.release inner;
+    owner#release
+
+  method hash = Protocols.Handle.hash inner
+  method protocols = Protocols.Handle.protocols inner
+end
diff --git a/lib/kernel/Lifecycle.mli b/lib/kernel/Lifecycle.mli
index f110768..fa3abee 100644
--- a/lib/kernel/Lifecycle.mli
+++ b/lib/kernel/Lifecycle.mli
@@ -10,3 +10,13 @@ end
 
 class null : lifecycle
 class virtual counted : controlled_lifecycle
+
+(** stands for [inner], carrying what it carries, while holding a
+    reference to [owner], so what [inner] reads outlives a release of
+    the object that produced it. *)
+class retaining : Protocols.Handle.t -> lifecycle -> object
+  inherit lifecycle
+  method destroy : unit
+  method hash : Concepts.Hash.hash
+  method protocols : Protocols.Handle.protocol list
+end
diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml
index 7beb133..b94e2f8 100644
--- a/lib/kernel/SubstantialRelation.ml
+++ b/lib/kernel/SubstantialRelation.ml
@@ -145,7 +145,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
   let modes_of description =
     Concepts.Mode.of_list
       [ Concepts.Mode.enumerable Concepts.Cardinality.Finite;
-        Concepts.Mode.decides_when (BatMap.String.keys description |> BatList.of_enum) ]
+        {Concepts.Mode.bound= Concepts.Mode.attributes_of_map description; affords= Decides} ]
 
   let modes tx relation = schema_of tx relation |> Result.map modes_of
 
@@ -161,7 +161,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
       (* 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 tuple)
+        SI.with_read storage (fun tx -> contains_tuple tx relation tuple)
 
       method describe () = Ok (Protocols.Schematics.Relation description)
 
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