aboutsummaryrefslogtreecommitdiffstats
path: root/lib/kernel
diff options
context:
space:
mode:
Diffstat (limited to 'lib/kernel')
-rw-r--r--lib/kernel/EphemeralRelation.ml87
-rw-r--r--lib/kernel/EphemeralRelation.mli26
-rw-r--r--lib/kernel/SubstantialRelation.ml51
-rw-r--r--lib/kernel/SubstantialRelation.mli20
-rw-r--r--lib/kernel/Tuple.ml15
5 files changed, 50 insertions, 149 deletions
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 }
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 04:36:10 +0000