ephemeral relation kernel object

2 files changed, 114 insertions, 0 deletions

diff --git a/lib/kernel/EphemeralRelation.ml b/lib/kernel/EphemeralRelation.ml
new file mode 100644
index 0000000..0b62517
--- /dev/null
+++ b/lib/kernel/EphemeralRelation.ml
@@ -0,0 +1,78 @@
+module type DERIVATION = sig
+  type plan
+
+  val identity : plan -> Concepts.Hash.hash
+
+  val describe :
+    plan -> (Protocols.Schematics.relation_description, Concepts.Condition.condition) result
+
+  val modes : plan -> (Concepts.Mode.t, Concepts.Condition.condition) result
+
+  val generate :
+    plan ->
+    Protocols.Generative.binding ->
+    (Protocols.Handle.t, Concepts.Condition.condition) result
+end
+
+module Make (D : DERIVATION) = struct
+  let pinned_tag = "rnt/pinned/1"
+
+  let identity ?pinned plan =
+    let derivation = D.identity plan in
+    match pinned with
+    | None -> derivation
+    | Some branch ->
+        pinned_tag ^ Concepts.Hash.to_raw_string derivation ^ Concepts.Hash.to_raw_string branch
+        |> Bytes.of_string
+        |> Concepts.Hash.hash_of_bytes
+
+  let exhaustible declaration =
+    match Concepts.Mode.generation declaration BatSet.String.empty with
+    | Some cardinality -> Concepts.Cardinality.exhaustible cardinality
+    | None -> false
+
+  class ephemeral plan address declaration total edges =
+    object (self)
+      inherit Lifecycle.counted
+      val plan : D.plan = plan
+      method destroy = List.iter Protocols.Handle.release edges
+      method predicate = Ok None
+      method local_constraints = Ok None
+      method modes = Ok declaration
+      method generate binding = D.generate plan binding
+      method enumerate = D.generate plan Protocols.Generative.nothing
+
+      method describe () =
+        D.describe plan |> Result.map (fun description -> 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. *)
+      method contains (tuple : Concepts.Tuple.t) =
+        let open Utilities.Result in
+        let* cursor = D.generate plan tuple.Concepts.Tuple.attributes in
+        Fun.protect
+          ~finally:(fun () -> Protocols.Handle.release cursor)
+          (fun () ->
+            let* scan = Protocols.Cursor.require cursor in
+            let* first = Protocols.Cursor.next scan in
+            Ok (Option.is_some first) )
+
+      method protocols : Protocols.Handle.protocol list =
+        let carried =
+          [ Protocols.Relation.make self;
+            Protocols.Schematics.make self;
+            Protocols.Generative.make self ]
+        in
+        if total then Protocols.Enumerable.make self :: carried else carried
+
+      method hash : Concepts.Hash.hash = address
+    end
+
+  let derive ?pinned ?(edges = []) plan =
+    let open Utilities.Result in
+    let* declaration = D.modes plan in
+    Ok
+      ( new ephemeral plan (identity ?pinned plan) declaration (exhaustible declaration) edges
+      |> Protocols.Handle.make )
+end
diff --git a/lib/kernel/EphemeralRelation.mli b/lib/kernel/EphemeralRelation.mli
new file mode 100644
index 0000000..d082394
--- /dev/null
+++ b/lib/kernel/EphemeralRelation.mli
@@ -0,0 +1,36 @@
+module type DERIVATION = sig
+  type plan
+
+  (** the hash of the plan, taken over the branch-local names of its
+      inputs rather than over their content addresses. The idea is to
+      have the same expression denote one object on every branch and
+      at every point in time. *)
+  val identity : plan -> Concepts.Hash.hash
+
+  val describe :
+    plan -> (Protocols.Schematics.relation_description, Concepts.Condition.condition) result
+
+  val modes : plan -> (Concepts.Mode.t, Concepts.Condition.condition) result
+
+  val generate :
+    plan ->
+    Protocols.Generative.binding ->
+    (Protocols.Handle.t, Concepts.Condition.condition) result
+end
+
+module Make (D : DERIVATION) : sig
+  (** unpinned, the identity of the derivation itself; pinned to a
+      branch commit, the identity of that derivation against one
+      reconstructible state, which is the only form for which equal
+      identity implies equal extension. *)
+  val identity : ?pinned:Concepts.Hash.hash -> D.plan -> Concepts.Hash.hash
+
+  (** edges are the handles the derivation reads, which are released
+      when the relation is also. Rejection of a derivation surfaces
+      here instead of when a cursor is being drained. *)
+  val derive :
+    ?pinned:Concepts.Hash.hash ->
+    ?edges:Protocols.Handle.t list ->
+    D.plan ->
+    (Protocols.Handle.t, Concepts.Condition.condition) result
+end