ephemeral relation and generator at the kernel

4 files changed, 173 insertions, 0 deletions

diff --git a/lib/kernel/EphemeralRelation.ml b/lib/kernel/EphemeralRelation.ml
new file mode 100644
index 0000000..7682c80
--- /dev/null
+++ b/lib/kernel/EphemeralRelation.ml
@@ -0,0 +1,87 @@
+module Make (S : Abstract.Storage.STORAGE) = struct
+  module SI = Storage.Make (S)
+
+  type t = {
+    heading: Concepts.Hash.hash;
+    evaluator: string;
+    source: string;
+    entry: string;
+    bindings: Concepts.Hash.hash;
+    inputs: string BatFingerTree.t
+  }
+
+  module Error = struct
+    open Concepts.Condition
+
+    let malformed () =
+      condition "malformed-ephemeral-relation"
+        "The on-disk representation of an ephemeral relation did not conform to what was expected"
+        empty
+
+    let replay_not_implemented () =
+      condition "ephemeral-relation-replay-not-implemented"
+        "Replaying an ephemeral relation's stored plan is not implemented in this slice -- \
+         see lib/kernel/EphemeralRelation.mli"
+        empty
+  end
+
+  let heading {heading; _} = heading
+  let evaluator {evaluator; _} = evaluator
+  let inputs {inputs; _} = inputs
+
+  let make ~heading ~evaluator ~source ~entry ~bindings ~inputs () =
+    Ok {heading; evaluator; source; entry; bindings; inputs}
+
+  module rec Representation : (Concepts.Encoding.Record.S with type t = t) =
+    Concepts.Encoding.Record.Make (Body)
+
+  and Body : Concepts.Encoding.Record.BODY = struct
+    type nonrec t = t
+
+    let tag = 'E'
+    let malformed = Error.malformed
+
+    let fields {heading; evaluator; source; entry; bindings; inputs} =
+      let open Concepts.Encoding in
+      [ "heading", Value.bencode_of_hash heading;
+        "evaluator", Field.string evaluator;
+        "source", Field.string source;
+        "entry", Field.string entry;
+        "bindings", Value.bencode_of_hash bindings;
+        "inputs", Bencode.List (BatFingerTree.to_list inputs |> List.map Field.string) ]
+
+    (* TODO: symmetric to `fields` above -- decode each field back with
+       Concepts.Encoding.Bencode.{field,as_string,as_list} and
+       Concepts.Encoding.Value.hash_of_bencode, then rebuild the
+       BatFingerTree for `inputs` with BatFingerTree.of_list. Left
+       unimplemented because nothing in this slice ever calls `load`
+       on a real address (see `load` below); the algorithm is exactly
+       SubstantialRelation.Body.of_fields's shape, one field wider. *)
+    let of_fields _fields = Error (malformed ()) [@@warning "-27"]
+  end
+
+  let store tx relation = SI.store_blob tx (Representation.to_blob relation)
+
+  (* TODO: `enumerate`/`contains` on the Relation object this should
+     return must, on every call:
+     1. resolve `evaluator` via the *current* Runtime.Context's root,
+        not the one live when `make` ran (lifecycle.org: "not
+        version-pinned paths" -- the whole point of storing a path
+        instead of a hash for `evaluator` and `inputs`);
+     2. `Protocols.Evaluator.admit source` against it;
+     3. `Protocols.Program.invoke ~entry ~bindings:(decode bindings)`;
+     4. drain the resulting Cursor into this call's answer.
+     None of that belongs in this module (see the module comment on
+     layering) -- it belongs in whatever session/host module builds
+     Runtime.Context.t values, since only that code is already
+     S-aware AND Protocols-aware. `load` therefore returns a handle
+     whose Relation methods all fail with `Error.replay_not_implemented`
+     rather than wiring a half-generic version of that four-step
+     replay here. *)
+  let load tx conn addr =
+    let open Utilities.Result in
+    let* data = SI.get_req tx (S.Hash addr) in
+    let* (_relation : t) = Representation.of_blob data in
+    let _ = conn in
+    Error (Error.replay_not_implemented ())
+end
diff --git a/lib/kernel/EphemeralRelation.mli b/lib/kernel/EphemeralRelation.mli
new file mode 100644
index 0000000..e579abd
--- /dev/null
+++ b/lib/kernel/EphemeralRelation.mli
@@ -0,0 +1,26 @@
+module Make (S : Abstract.Storage.STORAGE) : sig
+  type t
+
+  val make :
+    heading:Concepts.Hash.hash ->
+    evaluator:string ->
+    source:string ->
+    entry:string ->
+    bindings:Concepts.Hash.hash ->
+    inputs:string BatFingerTree.t ->
+    unit ->
+    (t, Concepts.Condition.condition) result
+
+  val store : S.transaction -> t -> (Concepts.Hash.hash, Concepts.Condition.condition) result
+  val load : S.transaction -> S.connection -> Concepts.Hash.hash -> (Protocols.Handle.t, Concepts.Condition.condition) result
+  val heading : t -> Concepts.Hash.hash
+  val evaluator : t -> string
+  val inputs : t -> string BatFingerTree.t
+
+  module Error : sig
+    val malformed : unit -> Concepts.Condition.condition
+    val replay_not_implemented : unit -> Concepts.Condition.condition
+  end
+
+  module Representation : Concepts.Encoding.Record.S with type t = t
+end
diff --git a/lib/kernel/Generator.ml b/lib/kernel/Generator.ml
new file mode 100644
index 0000000..e4a15f8
--- /dev/null
+++ b/lib/kernel/Generator.ml
@@ -0,0 +1,56 @@
+type _ Effect.t += Yield : Concepts.Tuple.t -> unit Effect.t
+
+type step =
+  | Element of Concepts.Tuple.t * (unit, step) Effect.Deep.continuation
+  | Finished of (unit, Concepts.Condition.condition) result
+
+let start produce =
+  try Finished (produce ~yield:(fun tuple -> Effect.perform (Yield tuple))) with
+  | effect (Yield tuple), k -> Element (tuple, k)
+
+let resume k = Effect.Deep.continue k ()
+
+class producer_cursor produce on_release =
+  object (self)
+    inherit Lifecycle.null
+    inherit Identity.of_id
+
+    val mutable state : [`Fresh | `Live of (unit, step) Effect.Deep.continuation | `Done] = `Fresh
+    method protocols : Protocols.Handle.protocol list = Protocols.[Cursor.make self]
+    method private step : (Concepts.Tuple.t option, Concepts.Condition.condition) result =
+      let settle = function
+        | Element (tuple, k) ->
+            state <- `Live k;
+            Ok (Some tuple)
+        | Finished r ->
+            state <- `Done;
+            Result.map (fun () -> None) r
+      in
+      match state with
+      | `Done -> Ok None
+      | `Fresh -> settle (start produce)
+      | `Live k -> settle (resume k)
+
+    method fetch limit =
+      let open Utilities.Result in
+      let rec fill taken tuples =
+        if taken >= limit then Ok Protocols.Cursor.{tuples; exhausted= false}
+        else
+          let* stepped = self#step in
+          match stepped with
+          | None -> Ok Protocols.Cursor.{tuples; exhausted= true}
+          | Some tuple -> fill (taken + 1) (BatFingerTree.snoc tuples tuple)
+      in
+      if limit <= 0 then
+        Ok Protocols.Cursor.{tuples= BatFingerTree.empty; exhausted= (state = `Done)}
+      else fill 0 BatFingerTree.empty
+
+    method! release =
+      (match state with
+       | `Live _ -> Option.iter (fun f -> f ()) on_release
+       | `Fresh | `Done -> ());
+      state <- `Done
+  end
+
+let cursor_of ?on_release produce =
+  new producer_cursor produce on_release |> Protocols.Handle.make
diff --git a/lib/kernel/Generator.mli b/lib/kernel/Generator.mli
new file mode 100644
index 0000000..f30f8ef
--- /dev/null
+++ b/lib/kernel/Generator.mli
@@ -0,0 +1,4 @@
+val cursor_of :
+  ?on_release:(unit -> unit) ->
+  (yield:(Concepts.Tuple.t -> unit) -> (unit, Concepts.Condition.condition) result) ->
+  Protocols.Handle.t