appropriate enumeration for tuple split on object and resident

11 files changed, 124 insertions, 205 deletions

diff --git a/lib/concepts/Tuple.ml b/lib/concepts/Tuple.ml
new file mode 100644
index 0000000..296bf26
--- /dev/null
+++ b/lib/concepts/Tuple.ml
@@ -0,0 +1,45 @@
+type t = { type_ : string; attributes : Value.value BatMap.String.t }
+
+let malformed_value () =
+  Condition.condition "malformed-tuple-value"
+    "A tuple field did not conform to what was expected" Condition.empty
+
+let bencode_of_value = function
+  | Value.String s -> Encoding.Bencode.Tagged ('s', Encoding.Bencode.String s)
+  | Value.Integer n -> Encoding.Bencode.Tagged ('i', Encoding.Bencode.Int n)
+
+let value_of_bencode = function
+  | Encoding.Bencode.Tagged ('s', Encoding.Bencode.String s) -> Ok (Value.String s)
+  | Encoding.Bencode.Tagged ('i', Encoding.Bencode.Int n) -> Ok (Value.Integer n)
+  | _ -> Error (malformed_value ())
+
+module rec Representation : (Encoding.Record.S with type t = t) =
+  Encoding.Record.Make (Body)
+
+and Body : Encoding.Record.BODY = struct
+  type nonrec t = t
+
+  let tag = 'T'
+  let malformed = malformed_value
+
+  let fields { type_; attributes } =
+    [ "type", Encoding.Bencode.String type_;
+      "attributes",
+      Encoding.Bencode.Dict
+        (BatMap.String.enum attributes
+         |> BatEnum.fold
+              (fun acc (name, value) -> (name, bencode_of_value value) :: acc)
+              []) ]
+
+  let of_fields data =
+    let open Utilities.Result in
+    let* type_ = Encoding.Bencode.field "type" data |> fmap Encoding.Bencode.as_string in
+    let* kvs = Encoding.Bencode.field "attributes" data |> fmap Encoding.Bencode.as_dict in
+    kvs
+    |> List.map (fun (name, v) -> value_of_bencode v |> Result.map (fun v -> (name, v)))
+    |> Utilities.List.sequence
+    |> Result.map (fun kvs ->
+           { type_; attributes = BatMap.String.of_list kvs })
+end
+
+let hash tuple = Representation.to_blob tuple |> Hash.hash_of_blob
diff --git a/lib/kernel/EphemeralRelation.ml b/lib/kernel/EphemeralRelation.ml
deleted file mode 100644
index 7682c80..0000000
--- a/lib/kernel/EphemeralRelation.ml
+++ /dev/null
@@ -1,87 +0,0 @@
-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
deleted file mode 100644
index e579abd..0000000
--- a/lib/kernel/EphemeralRelation.mli
+++ /dev/null
@@ -1,26 +0,0 @@
-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/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml
index b0c8a51..3094eb8 100644
--- a/lib/kernel/SubstantialRelation.ml
+++ b/lib/kernel/SubstantialRelation.ml
@@ -1,7 +1,4 @@
-module Make (S : Abstract.Storage.STORAGE) (Schematics : sig
-  include Protocols.Schematics.S
-  val of_blob : Concepts.Blob.t -> (Schema.t, Concepts.Condition.condition) result
-end) = struct
+module Make (S : Abstract.Storage.STORAGE) = struct
   module SI = Storage.Make (S)
 
   module Error = struct
@@ -40,7 +37,7 @@ end) = 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;
@@ -55,9 +52,9 @@ end) = 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;
@@ -66,7 +63,7 @@ end) = 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
@@ -78,13 +75,13 @@ end) = 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
@@ -96,10 +93,10 @@ end) = 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)
 
@@ -110,10 +107,20 @@ end) = struct
     let* present = TupleSet.lookup tx tuple node in
     Ok (Option.is_some present)
 
-  let heading_value tx relation =
+  let schema_of tx relation =
     let open Utilities.Result in
-    let* data = SI.get_req tx (S.Hash relation.heading) in
-    Schematics.of_blob data
+    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
@@ -154,7 +161,6 @@ end) = struct
       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
 
@@ -164,7 +170,10 @@ end) = struct
         SI.with_transaction storage (fun tx ->
             contains_tuple tx relation (Concepts.Tuple.Representation.to_blob tuple) )
 
-      method schema = SI.with_transaction storage (fun tx -> heading_value tx relation)
+      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
@@ -174,14 +183,16 @@ end) = struct
       method enumerate (_ : Protocols.Context.t) = enumerate storage relation
 
       method protocols : Protocols.Handle.protocol list =
-        [Protocols.Relation.make self; Protocols.Enumerable.make self; Schematics.make self]
+        [ 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) )
 
diff --git a/lib/kernel/SubstantialRelation.mli b/lib/kernel/SubstantialRelation.mli
index 866c3a0..be2ad28 100644
--- a/lib/kernel/SubstantialRelation.mli
+++ b/lib/kernel/SubstantialRelation.mli
@@ -1,7 +1,4 @@
-module Make (S : Abstract.Storage.STORAGE) (Schematics : sig
-  include Protocols.Schematics.S
-  val of_blob : Concepts.Blob.t -> (Schema.t, Concepts.Condition.condition) result
-end) : sig
+module Make (S : Abstract.Storage.STORAGE) : sig
   type t
 
   val encode : t -> Concepts.Blob.t
@@ -9,7 +6,7 @@ end) : sig
 
   val empty :
     S.transaction ->
-    heading:Concepts.Hash.hash ->
+    schematics:Concepts.Hash.hash ->
     ?predicate:Concepts.Hash.hash ->
     ?local_constraints:Concepts.Hash.hash ->
     ?indexes:Concepts.Hash.hash ->
@@ -20,7 +17,7 @@ end) : sig
 
   val make :
     S.connection ->
-    heading:Concepts.Hash.hash ->
+    schematics:Concepts.Hash.hash ->
     ?predicate:Concepts.Hash.hash ->
     ?local_constraints:Concepts.Hash.hash ->
     ?indexes:Concepts.Hash.hash ->
@@ -37,7 +34,7 @@ end) : sig
     Concepts.Hash.hash ->
     (Protocols.Handle.t, Concepts.Condition.condition) result
 
-  val heading : t -> Concepts.Hash.hash
+  val schematics : t -> Concepts.Hash.hash
   val predicate : t -> Concepts.Hash.hash option
   val local_constraints : t -> Concepts.Hash.hash option
   val tuples : t -> Concepts.Hash.hash
@@ -50,9 +47,12 @@ end) : sig
   val contains_tuple :
     S.transaction -> t -> Concepts.Blob.t -> (bool, Concepts.Condition.condition) result
 
-  (** decodes the heading at [heading relation] -- the body of
-      [Schematics.schema] for this kind of relation. *)
-  val heading_value : S.transaction -> t -> (Schematics.Schema.t, Concepts.Condition.condition) result
+  (** decodes the schematics at [schematics relation] -- the body of
+      [Protocols.Schematics.describe] for this kind of relation. *)
+  val schema_of :
+    S.transaction ->
+    t ->
+    (Protocols.Schematics.relation_description, Concepts.Condition.condition) result
 
   (** a handle carrying [Protocols.Cursor] over every tuple currently
       asserted, decoded via [Concepts.Tuple.Representation.of_blob] --
diff --git a/lib/kernel/Tuple.ml b/lib/kernel/Tuple.ml
index 50ce5b5..ef591ae 100644
--- a/lib/kernel/Tuple.ml
+++ b/lib/kernel/Tuple.ml
@@ -19,6 +19,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct
   module Attribute = struct
     type t = Concepts.Value.value
 
+    let malformed_value = Error.malformed_value
+
     let encode value =
       let open Concepts.Encoding in
       Bencode.to_blob
@@ -33,7 +35,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
       match data with
       | Bencode.Tagged ('s', Bencode.String s) -> Ok (Concepts.Value.String s)
       | Bencode.Tagged ('i', Bencode.Int n) -> Ok (Concepts.Value.Integer n)
-      | _ -> Error (Error.malformed_value ())
+      | _ -> Error (malformed_value ())
 
     let domain = function
       | Concepts.Value.String _ -> "string"
@@ -90,11 +92,12 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     let open Utilities.Result in
     let* node =
       AttributeM.with_batch tx (fun () ->
-          BatMap.String.foldi
-            (fun name value node ->
-              let* node = node in
-              AttributeM.insert tx name value node)
-            attributes (Ok AttributeM.empty))
+          BatMap.String.enum attributes
+          |> BatEnum.fold
+               (fun node (name, value) ->
+                 let* node = node in
+                 AttributeM.insert tx name value node)
+               (Ok AttributeM.empty))
     in
     Ok { type_; attributes = AttributeM.hash_of node }
 
diff --git a/lib/protocols/Context.ml b/lib/protocols/Context.ml
new file mode 100644
index 0000000..b7c8a37
--- /dev/null
+++ b/lib/protocols/Context.ml
@@ -0,0 +1,4 @@
+type t =
+  { snapshot : Concepts.Hash.hash
+  ; root : Handle.t
+  ; status : unit -> [`Live | `Cancelled | `Exhausted] }
diff --git a/lib/protocols/Relation.ml b/lib/protocols/Relation.ml
index 54454cf..c05337f 100644
--- a/lib/protocols/Relation.ml
+++ b/lib/protocols/Relation.ml
@@ -7,7 +7,6 @@ module Error = struct
 end
 
 class type implementation = object
-  method heading : (Concepts.Hash.hash, Concepts.Condition.condition) result
   method predicate : (Concepts.Hash.hash option, Concepts.Condition.condition) result
   method local_constraints : (Concepts.Hash.hash option, Concepts.Condition.condition) result
   method contains : Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result
@@ -19,7 +18,6 @@ type t = implementation
 let make impl = Relation (impl :> implementation)
 let from handle = Handle.into handle (function Relation impl -> Some impl | _ -> None)
 let require handle = from handle |> Option.to_result ~none:(Error.not_a_relation ())
-let heading i = Handle.invoke i (fun o -> o#heading)
 let predicate i = Handle.invoke i (fun o -> o#predicate)
 let local_constraints i = Handle.invoke i (fun o -> o#local_constraints)
 let contains i tuple = Handle.invoke i (fun o -> o#contains tuple)
diff --git a/lib/protocols/Relation.mli b/lib/protocols/Relation.mli
index 7e64a3b..384877e 100644
--- a/lib/protocols/Relation.mli
+++ b/lib/protocols/Relation.mli
@@ -1,7 +1,6 @@
 type t
 
 class type implementation = object
-  method heading : (Concepts.Hash.hash, Concepts.Condition.condition) result
   method predicate : (Concepts.Hash.hash option, Concepts.Condition.condition) result
   method local_constraints : (Concepts.Hash.hash option, Concepts.Condition.condition) result
   method contains : Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result
@@ -10,7 +9,6 @@ end
 val make : #implementation -> Handle.protocol
 val from : Handle.t -> t Handle.interface option
 val require : Handle.t -> (t Handle.interface, Concepts.Condition.condition) result
-val heading : t Handle.interface -> (Concepts.Hash.hash, Concepts.Condition.condition) result
 
 val predicate :
   t Handle.interface -> (Concepts.Hash.hash option, Concepts.Condition.condition) result
diff --git a/lib/runtime/Context.ml b/lib/runtime/Context.ml
index 10422e4..000f5d6 100644
--- a/lib/runtime/Context.ml
+++ b/lib/runtime/Context.ml
@@ -1,60 +1,30 @@
 module Error = struct
   open Concepts.Condition
 
-  let budget_exhausted ~requested ~remaining =
-    condition "budget-exhausted" "An evaluation asked for more budget than it had left"
-      ("requested" |=| Concepts.Value.Integer requested
-      & "remaining" |=| Concepts.Value.Integer remaining)
-
   let not_a_directory segment =
     condition "not-a-directory" "A path segment named an object with no Directory protocol"
       ("segment" |=| Concepts.Value.String segment)
 end
 
-type budget = int Atomic.t
-
-let charge_budget budget n =
+let resolve { Protocols.Context.root; _ } name =
   let open Utilities.Result in
-  let* _ =
-    Utilities.Atomic.mswap budget (fun remaining ->
-        if remaining >= n then Ok (remaining - n)
-        else Error (Error.budget_exhausted ~requested:n ~remaining) )
+  let rec walk handle = function
+    | [] -> Ok (Protocols.Handle.copy handle)
+    | segment :: rest ->
+       let* directory =
+         Protocols.Directory.from handle
+         |> Option.to_result ~none:(Error.not_a_directory segment)
+       in
+       let* found = Protocols.Directory.find directory segment in
+       match found with
+       | None -> Ok None
+       | Some child ->
+          Fun.protect ~finally:(fun () -> Protocols.Handle.release child)
+            (fun () -> walk child rest)
   in
-  Ok ()
-
-class context ~root ~budget ~cancelled =
-  object (self)
-    val root : Protocols.Handle.t = root
-    val budget : budget = budget
-    val cancelled : unit -> bool = cancelled
-
-    method resolve (name : string) :
-        (Protocols.Handle.t option, Concepts.Condition.condition) result =
-      let open Utilities.Result in
-      let rec walk handle = function
-        | [] -> Ok (Protocols.Handle.copy handle)
-        | segment :: rest ->
-            let* directory = Protocols.Directory.from handle
-              |> Option.to_result ~none:(Error.not_a_directory segment)
-            in
-            let* found = Protocols.Directory.find directory segment in
-            match found with
-            | None -> Ok None
-            | Some child ->
-                Fun.protect ~finally:(fun () -> Protocols.Handle.release child)
-                  (fun () -> walk child rest)
-      in
-      String.split_on_char '/' name |> List.filter (fun segment -> segment <> "") |> walk root
-
-    method cancelled = cancelled ()
-    method charge n = charge_budget budget n
-    method nest ?authority:(_ : string BatSet.t option) () =
-      (new context ~root ~budget ~cancelled :> Protocols.Context.implementation)
-
-    initializer ignore self
-  end
-
-let over ~root ?(budget = max_int) ?(cancelled = fun () -> false) () =
-  Protocols.Context.make (new context ~root ~budget:(Atomic.make budget) ~cancelled)
+  String.split_on_char '/' name |> List.filter (fun segment -> segment <> "") |> walk root
 
-let remaining (_ : Protocols.Context.t) : int option = failwith "not implemented"
+let over ~snapshot ~root ?(cancelled = fun () -> false) () =
+  { Protocols.Context.snapshot
+  ; root
+  ; status = (fun () -> if cancelled () then `Cancelled else `Live) }
diff --git a/lib/runtime/Context.mli b/lib/runtime/Context.mli
index 31ef194..6e7ab2f 100644
--- a/lib/runtime/Context.mli
+++ b/lib/runtime/Context.mli
@@ -1,8 +1,11 @@
+val resolve :
+  Protocols.Context.t ->
+  string ->
+  (Protocols.Handle.t option, Concepts.Condition.condition) result
+
 val over :
+  snapshot:Concepts.Hash.hash ->
   root:Protocols.Handle.t ->
-  ?budget:int ->
   ?cancelled:(unit -> bool) ->
   unit ->
   Protocols.Context.t
-
-val remaining : Protocols.Context.t -> int option