diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/kernel/EphemeralRelation.ml | 87 | ||||
| -rw-r--r-- | lib/kernel/EphemeralRelation.mli | 26 | ||||
| -rw-r--r-- | lib/kernel/SubstantialRelation.ml | 51 | ||||
| -rw-r--r-- | lib/kernel/SubstantialRelation.mli | 20 | ||||
| -rw-r--r-- | lib/kernel/Tuple.ml | 15 |
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 } |