diff options
29 files changed, 1097 insertions, 98 deletions
diff --git a/docs/evaluators.org b/docs/evaluators.org index 1e0d7cc..84bc493 100644 --- a/docs/evaluators.org +++ b/docs/evaluators.org @@ -24,55 +24,83 @@ indexes them so a client can ask which evaluators declare =dml= and get back B and C. * Protocols -Three object components, following the existing =implementation= / -=make= / =from= pattern. - -=Protocols.Evaluator= admits programs in string format. Admission -validates a program in the evaluator's own representation (as in: -parses, type checks and does all it requires to validate it) and -yields a handle. +An evaluator is an object like any other, that can be used to execute +program with a context, exactly as an interpreter takes an expression +and an environment. The plan tree should already bear every value the +program needs, so there is nothing left to bind. Each invocation +carries independent state based atop of a database view of the world +(being therefore hash dependent and isolated). #+begin_src ocaml +module Make (P : PROGRAM) : sig class type implementation = object - method capabilities : string BatSet.t - method admit : string -> (Handle.t, condition) result + method invoke : + program:P.t -> Context.t -> (Handle.t, condition) result end +end #+end_src -=Protocols.Program= exposes entry points and an invocation, making a -program reusable, since each invocation carries independent state -based atop of a database view of the world (hash dependent and -isolated). +The protocol is parameterized by the evaluator's own plan type, so a +plan is never encoded into values only to be decoded again. Each +application of the functor yields its own protocol constructor, which +is what keeps one evaluator from answering another's programs: a +client obtains the interface through the module of the evaluator it +intends to speak to. The FOL evaluator, which lives under +=lib/evaluators= alongside the evaluators shipped with RNT, currently +understands a single node: #+begin_src ocaml -class type implementation = object - method entry_points : string list - method invoke : - entry:string -> bindings:Concepts.Tuple.t -> Runtime.Context.t -> - (Handle.t, condition) result -end +type plan = Base of string #+end_src +=Base= names a relation, which is resolved through the context and +enumerated to exhaustion. The name is resolved rather than an address +being followed, which keeps the evaluator free of storage and makes +every resolution happen under one snapshot. + The returned handle carries a result protocol with =Protocols.Cursor=, -giving it incremental consumption. A successor state and a command -completion are further result protocols, added for DML and DDL -later. It's important to notice that the kernel enumerates result -protocols; it thererfore does not enumerate sublanguages. That is not -to say however that we cannot have a builtin catalog relation -installed and configured by the client that enumerates them (that's a -concern for the future). +giving it incremental consumption. Since executing a plan node yields +a cursor, operators stack as cursors over cursors, in the manner of a +volcano iterator, and no intermediate result is materialized. A +successor state and a command completion are further result protocols, +added for DML and DDL later. It's important to notice that the kernel +enumerates result protocols; it thererfore does not enumerate +sublanguages. That is not to say however that we cannot have a builtin +catalog relation installed and configured by the client that +enumerates them (that's a concern for the future). * Context -=Runtime.Context.t= supplies the selected database state, handles -(which assume authorization, since we are a capability based system), -cancellation, and resource usage. Evaluators reach kernel resources -*only* through it. - -A nested invocation shares state, transaction, cancellation, and -budget, and may be given less authority than its caller. Reads keep -the selected state so that nesting does not need to resolve a branch -tip again, and a successful evaluation and cursor exhaustion never -commit. Commit should be an explicit host operation. +=Protocols.Context.t= supplies the selected database state, the root +handle through which names are resolved (which assumes authorization, +since we are a capability based system), and the status of the +evaluation. Evaluators reach kernel resources *only* through it. + +#+begin_src ocaml +type t = + { snapshot : Concepts.Hash.hash + ; root : Handle.t + ; status : unit -> [`Live | `Cancelled | `Exhausted] } +#+end_src + +The snapshot is the hash of a commit. Since every object is content +addressed and prolly trees do not depend on insertion order, equal +state yields an equal hash, so a commit hash is a frozen world rather +than a pointer into a changing one. A cursor therefore pins a hash +instead of an open transaction, and every node of a plan reads the +same state, which gives repeatable reads across a whole plan for free +and makes concurrent commits simply invisible to a running +evaluation. + +=status= collapses cancellation and resource exhaustion into the +single question an operator asks between tuples, namely whether it may +produce another tuple. The runtime owns how =Exhausted= is decided. A +nested invocation shares the snapshot, so nesting does not need to +resolve a branch tip again, and a successful evaluation and cursor +exhaustion never commit. Commit should be an explicit host operation. + +Budgets, authority narrowing, and resource accounting are not +implemented, and adding a fourth status case would break exhaustive +matches in consumers, which is the price of keeping this closed. * Composition Evaluators compose through invocation and result protocols alone. A diff --git a/docs/object-taxonomy.org b/docs/object-taxonomy.org index 02636b0..d948845 100644 --- a/docs/object-taxonomy.org +++ b/docs/object-taxonomy.org @@ -42,12 +42,24 @@ semantics of its multigroup. Schematics therefore describes more than the shape of a relation, recording the information necessary to understand the logical conditions under which a relation value is a semantically consistent -representation of its intended group. Its schema component is exposed -through =Protocols.Schematics.Make(Schema)=, instantiated by the host -with a logical schema implementation satisfying -=Abstract.Schematics.SCHEMA=. Providers and consumers use the shared -protocol module to obtain a schema and list its attributes through an -object handle. +representation of its intended group. + +Schematics being a protocol forces an object to know its own type +through =describe=, which yields a description of a multigroup, of a +relation, or of a tuple (for now only these). There is no separate +notion of a heading: the type of a relation is the schematics object +it points to, and a tuple drawn from that relation is described +against the very same type. A tuple description then, carries both the +description of the relation it belongs to and the domains its own +attributes exhibit, and therefore comparing the two is the admission +test (membership criteria). + +#+begin_src ocaml +type description = + | Multigroup of multigroup_description + | Relation of relation_description + | Tuple of tuple_description +#+end_src For now, types are only opaque tags carried by attributes, and schema operations preserve this metadata without trying to resolve these @@ -176,11 +188,55 @@ membership, enumerate members, establish the cardinality of a particular invocation, and guarantee termination of an expression consuming the relation. +The line that matters (operationally) is not countable vs uncountable +sets, but whether the extension can be enumerated to exhaustion. A +relation whose extension is uncountable cannot be enumerated at all, +so it is excluded by construction rather than by a check: such a +relation is given intensionally, by its membership criteria, and +offers membership testing without carrying enumeration. A countably +infinite relation may be enumerated, but never exhausted, so an +expression that must materialize it is the thing to reject. Membership +is in any case always intensional! One does not ask whether a value is +extensionally among the naturals (for that is very wasteful and +naïve), only whether it satisfies the criteria for being one, and the +extensional lookup a substantial relation can afford is an +optimization that is valid only because admission already enforced +those criteria (which will obviously include constraints). + Sol, as RNT's total relational language, admits procedural relations only where the required evaluation properties can be established. An unrestricted procedure must not silently introduce partiality or nontermination into an otherwise total relational expression. +* Tuple +A tuple is a value of a relation rather than an object of the +administrative tree. It is not registered with the object manager and +holds no name of its own, since it is reached through the relation +that asserts it. It remains an object at runtime, carrying Schematics +so that it can describe the type it claims. + +A tuple is a type label together with its attributes. The label names +the relation whose criteria the tuple claims to satisfy, which is what +allows a tuple to be handed to a multigroup and routed to the relation +representing its type, instead of being inserted into a relation +chosen by the caller. Admission is then a matter of typing and +constraints: the multigroup resolves the label, compares the tuple +against the relation's schematics, and applies its predicate and local +constraints before the tuple becomes asserted. + +The label is redundant while a tuple sits inside a relation, since the +relation already names the type. It earns its keep for a tuple in +flight, which is the admission case. + +Two representations exist for the same value. The evaluator and the +protocols carry tuples as plain values, which is what a cursor yields +and what a program receives as bindings. Storage keeps the attributes +as their own content addressed subtree, so that two tuples asserting +the same thing share one representation, and identical attributes +yield an identical address regardless of the order in which they were +written. Ephemeral tuples, which are never interned, are values that +simply never reach storage. + * Multigroup A multigroup represents a collection of related groups and is represented logically by a database of relations considered together 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/evaluators/FOL.ml b/lib/evaluators/FOL.ml new file mode 100644 index 0000000..70cf9de --- /dev/null +++ b/lib/evaluators/FOL.ml @@ -0,0 +1,40 @@ +module Error = struct + open Concepts.Condition + + let unknown_relation name = + condition "unknown-relation" "A plan named a relation that does not exist under this snapshot" + ("name" |=| Concepts.Value.String name) + + let cancelled () = + condition "evaluation-cancelled" "An evaluation was stopped before it produced its result" empty +end + +type plan = Base of string + +module Program = Protocols.Program.Make (struct + type t = plan +end) + +let execute context = function + | Base name -> + let open Utilities.Result in + match context.Protocols.Context.status () with + | `Cancelled | `Exhausted -> Error (Error.cancelled ()) + | `Live -> + let* found = Runtime.Context.resolve context name in + let* handle = Option.to_result ~none:(Error.unknown_relation name) found in + Fun.protect + ~finally:(fun () -> Protocols.Handle.release handle) + (fun () -> + let* enumerable = Protocols.Enumerable.require handle in + Protocols.Enumerable.enumerate enumerable context) + +class evaluator = object (self) + inherit Kernel.Lifecycle.null + inherit Kernel.Identity.of_id + + method invoke ~program context = execute context program + method protocols : Protocols.Handle.protocol list = [Program.make self] +end + +let make () = new evaluator |> Protocols.Handle.make diff --git a/lib/evaluators/Lambda.ml b/lib/evaluators/Lambda.ml new file mode 100644 index 0000000..7cb0248 --- /dev/null +++ b/lib/evaluators/Lambda.ml @@ -0,0 +1,90 @@ +module Error = struct + open Concepts.Condition + + let unknown_name name = + condition "unknown-name" + "A term named neither a bound variable nor a relation existing under this snapshot" + ("name" |=| Concepts.Value.String name) + let not_applicable () = + condition "not-applicable" + "A term was applied to an argument, but it denotes a relation rather than an abstraction" + empty + let unapplied_abstraction () = + condition "unapplied-abstraction" + "A program reduced to an abstraction, which names no relation to enumerate" empty + let cancelled () = + condition "evaluation-cancelled" "An evaluation was stopped before it produced its result" empty +end + +(* A dummy untyped lambda calculus where constants are relations. We + look for a name in the environment first and resolved through the + context otherwise, so the relations reachable under the snapshot + are the outer environment every program is evaluated on *) +type term = + | Name of string + | Abstract of string * term + | Apply of term * term + +module Program = Protocols.Program.Make (struct + type t = term +end) + +type value = + | Relation of Protocols.Handle.t + | Closure of string * term * environment +and environment = value BatMap.String.t + +let reduce context ~acquire term = + let open Utilities.Result in + let rec eval environment term = + match context.Protocols.Context.status () with + | `Cancelled | `Exhausted -> Error (Error.cancelled ()) + | `Live -> + match term with + | Name name -> + begin match BatMap.String.find_opt name environment with + | Some value -> Ok value + | None -> + let* found = Runtime.Context.resolve context name in + let* handle = Option.to_result ~none:(Error.unknown_name name) found in + Ok (Relation (acquire handle)) + end + | Abstract (binder, body) -> Ok (Closure (binder, body, environment)) + | Apply (operator, operand) -> + let* operator = eval environment operator in + match operator with + | Relation _ -> Error (Error.not_applicable ()) + | Closure (binder, body, closed) -> + let* argument = eval environment operand in + eval (BatMap.String.add binder argument closed) body + in + eval BatMap.String.empty term + +(* Every handle resolved during reduction is released once the result + has been enumerated and we keep a closure free to carry a relation + it did not resolve itself *) +let execute context term = + let open Utilities.Result in + let acquired = ref [] in + let acquire handle = + acquired := handle :: !acquired; + handle + in + Fun.protect + ~finally:(fun () -> List.iter Protocols.Handle.release !acquired) + (fun () -> + let* value = reduce context ~acquire term in + match value with + | Closure _ -> Error (Error.unapplied_abstraction ()) + | Relation handle -> + let* enumerable = Protocols.Enumerable.require handle in + Protocols.Enumerable.enumerate enumerable context) + +class evaluator = object (self) + inherit Kernel.Lifecycle.null + inherit Kernel.Identity.of_id + method invoke ~program context = execute context program + method protocols : Protocols.Handle.protocol list = [Program.make self] +end + +let make () = new evaluator |> Protocols.Handle.make 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/Initialization.ml b/lib/kernel/Initialization.ml index d213b66..ae041fc 100644 --- a/lib/kernel/Initialization.ml +++ b/lib/kernel/Initialization.ml @@ -1,12 +1,22 @@ module Make (S : Abstract.Storage.STORAGE) = struct module BM = BranchManager.Make (S) - let initialize conn = + let initialize ?(evaluators = []) conn = let open Utilities.Result in let open Protocols in let root = Namespace.make () in let registry = Registry.from root |> Option.get in let* branch_manager = BM.make conn "rnt-head" in let* _ = Registry.update registry "branch" None (Some branch_manager) in + let evaluator_namespace = Namespace.make () in + let evaluator_registry = Registry.from evaluator_namespace |> Option.get in + let* _ = + List.fold_left + (fun acc (name, handle) -> + let* _ = acc in + Registry.update evaluator_registry name None (Some handle)) + (Ok true) evaluators + in + let* _ = Registry.update registry "evaluator" None (Some evaluator_namespace) in Ok root end diff --git a/lib/kernel/Initialization.mli b/lib/kernel/Initialization.mli index 104d523..926bbd8 100644 --- a/lib/kernel/Initialization.mli +++ b/lib/kernel/Initialization.mli @@ -1,3 +1,6 @@ module Make (S : Abstract.Storage.STORAGE) : sig - val initialize : S.connection -> (Protocols.Handle.t, Concepts.Condition.condition) result + val initialize : + ?evaluators:(string * Protocols.Handle.t) list -> + S.connection -> + (Protocols.Handle.t, Concepts.Condition.condition) result end diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml index eebae3e..6592acb 100644 --- a/lib/kernel/SubstantialRelation.ml +++ b/lib/kernel/SubstantialRelation.ml @@ -37,7 +37,7 @@ module Make (S : Abstract.Storage.STORAGE) = 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; @@ -52,9 +52,9 @@ module Make (S : Abstract.Storage.STORAGE) = 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; @@ -63,7 +63,7 @@ module Make (S : Abstract.Storage.STORAGE) = 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 @@ -75,13 +75,13 @@ module Make (S : Abstract.Storage.STORAGE) = 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 @@ -93,10 +93,10 @@ module Make (S : Abstract.Storage.STORAGE) = 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) @@ -107,27 +107,84 @@ module Make (S : Abstract.Storage.STORAGE) = struct let* present = TupleSet.lookup tx tuple node in Ok (Option.is_some present) + let schema_of tx relation = + let open Utilities.Result in + 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 + let* tx = S.start storage in + let* node = tuple_node tx relation in + let closed = ref false in + let close () = if not !closed then begin closed := true; ignore (S.abort tx) end in + (* The fold is suspended by [yield], so the tree is walked one node + and one tuple at a time rather than materialized before the + first tuple is produced. *) + let produce ~yield = + let* walked = + TupleSet.fold_left tx + (fun acc _ addr -> + let* () = acc in + let* tuple = + SI.get_req tx (S.Hash addr) |> fmap Concepts.Tuple.Representation.of_blob + in + yield tuple; + Ok ()) + (Ok ()) node + in + close (); + walked + in + Ok (Generator.cursor_of ~on_release:close produce) + class relation storage value = object (self) 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 - method tuples = Ok relation.tuples - - method contains tuple = - SI.with_transaction storage (fun tx -> contains_tuple tx relation tuple) - method protocols : Protocols.Handle.protocol list = Protocols.[Relation.make self] + (* The protocol takes a tuple, not bytes: encoding is this object's business, and a caller + that had to produce the exact stored bytes would have to know this encoding to do it. *) + method contains (tuple : Concepts.Tuple.t) = + SI.with_transaction storage (fun tx -> + contains_tuple tx relation (Concepts.Tuple.Representation.to_blob tuple) ) + + 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 + discovers it cannot iterate one -- see [Protocols.Enumerable]. The context is accepted and + unused here: this enumeration reads through its own cursor-lifetime transaction and needs + no name resolution, but cancellation should eventually be checked between tuples. *) + method enumerate (_ : Protocols.Context.t) = enumerate storage relation + + method protocols : Protocols.Handle.protocol list = + [ 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 9e61411..be2ad28 100644 --- a/lib/kernel/SubstantialRelation.mli +++ b/lib/kernel/SubstantialRelation.mli @@ -6,7 +6,7 @@ module Make (S : Abstract.Storage.STORAGE) : 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 -> @@ -17,7 +17,7 @@ module Make (S : Abstract.Storage.STORAGE) : 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 -> @@ -34,7 +34,7 @@ module Make (S : Abstract.Storage.STORAGE) : 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 @@ -46,4 +46,19 @@ module Make (S : Abstract.Storage.STORAGE) : sig val contains_tuple : S.transaction -> t -> Concepts.Blob.t -> (bool, 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] -- + the body of [Protocols.Relation.enumerate] for this kind of + relation. Opens its own storage transaction, held for the + cursor's whole lifetime rather than just this call -- see + [Kernel.Generator] and docs/design/evaluator.md, "Shape". *) + val enumerate : S.connection -> t -> (Protocols.Handle.t, Concepts.Condition.condition) result end diff --git a/lib/kernel/Tuple.ml b/lib/kernel/Tuple.ml new file mode 100644 index 0000000..ef591ae --- /dev/null +++ b/lib/kernel/Tuple.ml @@ -0,0 +1,144 @@ +module Make (S : Abstract.Storage.STORAGE) = struct + module SI = Storage.Make (S) + + module Error = struct + open Concepts.Condition + + let unknown_attribute name = + condition "unknown-attribute" "No such attribute on this tuple" + ("attribute" |=| Concepts.Value.String name) + let malformed_value () = + condition "malformed-tuple-value" + "A tuple field did not conform to what was expected" empty + let incomplete_tuple addr = + condition "incomplete-tuple" + "A stored tuple is missing part of its expected structure. Is your storage corrupted?" + ("address" |=| Concepts.Value.String (Concepts.Hash.to_hum_string addr)) + end + + 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 + (match value with + | Concepts.Value.String s -> Bencode.Tagged ('s', Bencode.String s) + | Concepts.Value.Integer n -> Bencode.Tagged ('i', Bencode.Int n)) + + let decode blob = + let open Utilities.Result in + let open Concepts.Encoding in + let* data = Bencode.of_blob blob in + 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 (malformed_value ()) + + let domain = function + | Concepts.Value.String _ -> "string" + | Concepts.Value.Integer _ -> "integer" + end + + module AttributeM = Merkle.Interface (S) (Merkle.StringKey) (Attribute) + + (* TODO: ephemeral tuples are served by instantiating this functor + over an in-memory storage. Consider later splitting [t] into + resident (an address) and ephemeral (an in-memory attribute map) + forms instead. *) + type t = { type_ : string; attributes : AttributeM.address } + + 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 = 'T' + let malformed = Error.malformed_value + + let fields { type_; attributes } = + let open Concepts.Encoding in + [ "type", Bencode.String type_; + "attributes", Value.bencode_of_hash attributes ] + + let of_fields data = + let open Utilities.Result in + let open Concepts.Encoding in + let* type_ = Bencode.field "type" data |> fmap Bencode.as_string in + let* attributes = Bencode.field "attributes" data |> fmap Value.hash_of_bencode in + Ok { type_; attributes } + end + + let encode = Representation.to_blob + let decode = Representation.of_blob + let hash tuple = Representation.to_blob tuple |> Concepts.Hash.hash_of_blob + + let type_of { type_; _ } = type_ + + let node tx { attributes; _ } = + let open Utilities.Result in + AttributeM.find tx attributes + |> fmap (Option.to_result ~none:(Error.incomplete_tuple attributes)) + + let empty tx ~type_ () = + let open Utilities.Result in + let* attributes = AttributeM.empty_under tx in + Ok { type_; attributes } + + let make tx ~type_ attributes = + let open Utilities.Result in + let* node = + AttributeM.with_batch tx (fun () -> + 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 } + + let attribute tx tuple name = + let open Utilities.Result in + let* node = node tx tuple in + let* value = AttributeM.lookup tx name node in + Option.to_result ~none:(Error.unknown_attribute name) value + + let attributes tx tuple = + let open Utilities.Result in + let* node = node tx tuple in + AttributeM.fold_left tx + (fun acc name value -> BatMap.String.add name value acc) + BatMap.String.empty node + + class tuple ~relation conn value node = object (self) + inherit Lifecycle.null + + val tuple = value + val storage = conn + val node = node + + method describe () = + let open Utilities.Result in + let* attributes = + SI.with_transaction storage (fun tx -> + AttributeM.fold_left tx + (fun acc name value -> BatMap.String.add name (Attribute.domain value) acc) + BatMap.String.empty node) + in + Ok (Protocols.Schematics.Tuple { Protocols.Schematics.relation; attributes }) + + method protocols : Protocols.Handle.protocol list = + [Protocols.Schematics.make self] + + method hash = hash tuple + end + + let wrap ~relation conn value = + let open Utilities.Result in + let* node = SI.with_transaction conn (fun tx -> node tx value) in + new tuple ~relation conn value node |> Protocols.Handle.make |> Result.ok +end 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/Cursor.ml b/lib/protocols/Cursor.ml new file mode 100644 index 0000000..36db97d --- /dev/null +++ b/lib/protocols/Cursor.ml @@ -0,0 +1,36 @@ +module Error = struct + open Concepts.Condition + + let not_a_cursor () = + condition "not-a-cursor" "A handle was expected to carry the cursor protocol and did not" empty +end + +type batch = {tuples: Concepts.Tuple.t BatFingerTree.t; exhausted: bool} + +class type implementation = object + method fetch : int -> (batch, Concepts.Condition.condition) result +end + +type Handle.protocol += Cursor of implementation +type t = implementation + +let make impl = Cursor (impl :> implementation) +let from handle = Handle.into handle (function Cursor impl -> Some impl | _ -> None) +let require handle = from handle |> Option.to_result ~none:(Error.not_a_cursor ()) +let fetch i limit = Handle.invoke i (fun o -> o#fetch limit) + +let rec next i = + let open Utilities.Result in + let* batch = fetch i 1 in + match BatFingerTree.front batch.tuples with + | Some (_, tuple) -> Ok (Some tuple) + | None -> if batch.exhausted then Ok None else next i + +let drain i ?(limit = 256) () = + let open Utilities.Result in + let rec loop tuples = + let* batch = fetch i limit in + let tuples = BatFingerTree.append tuples batch.tuples in + if batch.exhausted then Ok tuples else loop tuples + in + loop BatFingerTree.empty diff --git a/lib/protocols/Cursor.mli b/lib/protocols/Cursor.mli new file mode 100644 index 0000000..08c7628 --- /dev/null +++ b/lib/protocols/Cursor.mli @@ -0,0 +1,21 @@ +type batch = + {tuples: Concepts.Tuple.t BatFingerTree.t; exhausted: bool} + +type t + +class type implementation = object + method fetch : int -> (batch, Concepts.Condition.condition) result +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 fetch : t Handle.interface -> int -> (batch, Concepts.Condition.condition) result + +val next : t Handle.interface -> (Concepts.Tuple.t option, Concepts.Condition.condition) result + +val drain : + t Handle.interface -> + ?limit:int -> + unit -> + (Concepts.Tuple.t BatFingerTree.t, Concepts.Condition.condition) result diff --git a/lib/protocols/Enumerable.ml b/lib/protocols/Enumerable.ml new file mode 100644 index 0000000..e78f265 --- /dev/null +++ b/lib/protocols/Enumerable.ml @@ -0,0 +1,21 @@ +module Error = struct + open Concepts.Condition + + let not_enumerable () = + condition "not-enumerable" + "A relation was used where the expression must iterate its members, but it does not support \ + enumeration. A procedural relation may decide membership without being able to produce it." + empty +end + +class type implementation = object + method enumerate : Context.t -> (Handle.t, Concepts.Condition.condition) result +end + +type Handle.protocol += Enumerable of implementation +type t = implementation + +let make impl = Enumerable (impl :> implementation) +let from handle = Handle.into handle (function Enumerable impl -> Some impl | _ -> None) +let require handle = from handle |> Option.to_result ~none:(Error.not_enumerable ()) +let enumerate i context = Handle.invoke i (fun o -> o#enumerate context) diff --git a/lib/protocols/Enumerable.mli b/lib/protocols/Enumerable.mli new file mode 100644 index 0000000..4a903f6 --- /dev/null +++ b/lib/protocols/Enumerable.mli @@ -0,0 +1,13 @@ +type t + +class type implementation = object + method enumerate : Context.t -> (Handle.t, Concepts.Condition.condition) result +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 enumerate : + t Handle.interface -> Context.t -> (Handle.t, Concepts.Condition.condition) result diff --git a/lib/protocols/Program.ml b/lib/protocols/Program.ml new file mode 100644 index 0000000..49e6e2d --- /dev/null +++ b/lib/protocols/Program.ml @@ -0,0 +1,20 @@ +module type PROGRAM = sig + type t +end + +module Make (P : PROGRAM) = struct + class type implementation = object + method invoke : + program:P.t -> + Context.t -> + (Handle.t, Concepts.Condition.condition) result + end + + type Handle.protocol += Program of implementation + + type t = implementation + + let make impl = Program (impl :> implementation) + let from handle = Handle.into handle (function Program impl -> Some impl | _ -> None) + let invoke i ~program ctx = Handle.invoke i (fun o -> o#invoke ~program ctx) +end diff --git a/lib/protocols/Program.mli b/lib/protocols/Program.mli new file mode 100644 index 0000000..1d6c3ae --- /dev/null +++ b/lib/protocols/Program.mli @@ -0,0 +1,23 @@ +module type PROGRAM = sig + type t +end + +module Make (P : PROGRAM) : sig + type t + + class type implementation = object + method invoke : + program:P.t -> + Context.t -> + (Handle.t, Concepts.Condition.condition) result + end + + val make : #implementation -> Handle.protocol + val from : Handle.t -> t Handle.interface option + + val invoke : + t Handle.interface -> + program:P.t -> + Context.t -> + (Handle.t, Concepts.Condition.condition) result +end diff --git a/lib/protocols/Relation.ml b/lib/protocols/Relation.ml index ece9b8e..c05337f 100644 --- a/lib/protocols/Relation.ml +++ b/lib/protocols/Relation.ml @@ -1,9 +1,15 @@ +module Error = struct + open Concepts.Condition + + let not_a_relation () = + condition "not-a-relation" "A handle was expected to carry the relation protocol and did not" + empty +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 tuples : (Concepts.Hash.hash, Concepts.Condition.condition) result - method contains : Concepts.Blob.t -> (bool, Concepts.Condition.condition) result + method contains : Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result end type Handle.protocol += Relation of implementation @@ -11,8 +17,7 @@ type t = implementation let make impl = Relation (impl :> implementation) let from handle = Handle.into handle (function Relation impl -> Some impl | _ -> None) -let heading i = Handle.invoke i (fun o -> o#heading) +let require handle = from handle |> Option.to_result ~none:(Error.not_a_relation ()) let predicate i = Handle.invoke i (fun o -> o#predicate) let local_constraints i = Handle.invoke i (fun o -> o#local_constraints) -let tuples i = Handle.invoke i (fun o -> o#tuples) 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 4aeb562..384877e 100644 --- a/lib/protocols/Relation.mli +++ b/lib/protocols/Relation.mli @@ -1,16 +1,14 @@ 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 tuples : (Concepts.Hash.hash, Concepts.Condition.condition) result - method contains : Concepts.Blob.t -> (bool, Concepts.Condition.condition) result + method contains : Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result end val make : #implementation -> Handle.protocol val from : Handle.t -> t Handle.interface option -val heading : t Handle.interface -> (Concepts.Hash.hash, Concepts.Condition.condition) result +val require : Handle.t -> (t Handle.interface, Concepts.Condition.condition) result val predicate : t Handle.interface -> (Concepts.Hash.hash option, Concepts.Condition.condition) result @@ -18,5 +16,5 @@ val predicate : val local_constraints : t Handle.interface -> (Concepts.Hash.hash option, Concepts.Condition.condition) result -val tuples : t Handle.interface -> (Concepts.Hash.hash, Concepts.Condition.condition) result -val contains : t Handle.interface -> Concepts.Blob.t -> (bool, Concepts.Condition.condition) result +val contains : + t Handle.interface -> Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result diff --git a/lib/protocols/Schematics.ml b/lib/protocols/Schematics.ml new file mode 100644 index 0000000..d2e50ad --- /dev/null +++ b/lib/protocols/Schematics.ml @@ -0,0 +1,24 @@ +type multigroup_description = string BatMap.String.t +type relation_description = string BatMap.String.t +type tuple_description = {relation: relation_description; attributes: string BatMap.String.t} + +(* TODO: For now the description is completely detached from actual + types and domains. Later figure out a way to represent the links + without strings. *) +type description = + | Multigroup of multigroup_description + | Relation of relation_description + | Tuple of tuple_description + +class type implementation = object + method describe : unit -> (description, Concepts.Condition.condition) result +end + +type Handle.protocol += Schematics of implementation + +type t = implementation + +let make impl = Schematics (impl :> implementation) +let from handle = + Handle.into handle (function Schematics impl -> Some impl | _ -> None) +let describe impl = Handle.invoke impl (fun o -> o#describe ()) diff --git a/lib/protocols/Schematics.mli b/lib/protocols/Schematics.mli new file mode 100644 index 0000000..dc8f320 --- /dev/null +++ b/lib/protocols/Schematics.mli @@ -0,0 +1,21 @@ +type t + +(* TODO: For now the description is completely detached from actual + types and domains. Later figure out a way to represent the links + without strings. *) +type multigroup_description = string BatMap.String.t +type relation_description = string BatMap.String.t +type tuple_description = {relation: relation_description; attributes: string BatMap.String.t} + +type description = + | Multigroup of multigroup_description + | Relation of relation_description + | Tuple of tuple_description + +class type implementation = object + method describe : unit -> (description, Concepts.Condition.condition) result +end + +val make : #implementation -> Handle.protocol +val from : Handle.t -> t Handle.interface option +val describe : t Handle.interface -> (description, Concepts.Condition.condition) result diff --git a/lib/runtime/Context.ml b/lib/runtime/Context.ml new file mode 100644 index 0000000..000f5d6 --- /dev/null +++ b/lib/runtime/Context.ml @@ -0,0 +1,30 @@ +module Error = struct + open Concepts.Condition + + 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 + +let resolve { Protocols.Context.root; _ } name = + 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 + +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 new file mode 100644 index 0000000..6e7ab2f --- /dev/null +++ b/lib/runtime/Context.mli @@ -0,0 +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 -> + ?cancelled:(unit -> bool) -> + unit -> + Protocols.Context.t diff --git a/test/integration/Registration.ml b/test/integration/Registration.ml index 413be9f..9eb3e4e 100644 --- a/test/integration/Registration.ml +++ b/test/integration/Registration.ml @@ -10,16 +10,18 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = let run conn = let open Utilities.Result in begin - let* root = I.initialize conn in + let* root = I.initialize ~evaluators:["fol", Evaluators.FOL.make ()] conn in let* branch = B.make conn in Kernel.Path.(update root ("branch" @/ this) "master" None (Some branch)) end |> Helpers.condition_as_failure |> ignore; begin - let* root = I.initialize conn in - Kernel.Path.(lookup root ("branch" @/ "master" @/ "multigroup" @/ this)) + let* root = I.initialize ~evaluators:["fol", Evaluators.FOL.make ()] conn in + let* _ = Kernel.Path.(lookup root ("branch" @/ "master" @/ "multigroup" @/ this)) in + let* _ = Kernel.Path.(lookup root ("evaluator" @/ "fol" @/ this)) in + Ok () end - |> Helpers.condition_as_failure |> ignore + |> Helpers.condition_as_failure let suite prefix = ( "registration/" ^ prefix, diff --git a/test/test_rnt.ml b/test/test_rnt.ml index b80de90..d9936ea 100644 --- a/test/test_rnt.ml +++ b/test/test_rnt.ml @@ -2,6 +2,8 @@ let all_suites = Unit.Backend.Storage.suites () @ Unit.Kernel.Merkle.suites () @ Unit.Kernel.SubstantialRelation.suites () + @ Unit.Evaluators.FOL.suites () + @ Unit.Evaluators.Lambda.suites () @ Integration.Registration.suites () let () = Alcotest.run "RNT" all_suites diff --git a/test/unit/evaluators/FOL.ml b/test/unit/evaluators/FOL.ml new file mode 100644 index 0000000..32f09f5 --- /dev/null +++ b/test/unit/evaluators/FOL.ml @@ -0,0 +1,71 @@ +open Rnt + +module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = struct + open Alcotest + + module H = Helpers.Storage.Make (S) (C) + module SR = Rnt.Kernel.SubstantialRelation.Make (S) + + let hash s = + Concepts.Blob.blob_of_bytes (Bytes.of_string s) |> Concepts.Hash.hash_of_blob + + let alaric = + { Concepts.Tuple.type_ = "employee"; + attributes = + BatMap.String.empty + |> BatMap.String.add "name" (Concepts.Value.String "Alaric") } + + let not_a_program () = + Concepts.Condition.condition "not-a-program" + "A handle was expected to carry the program protocol and did not" Concepts.Condition.empty + + let scan_a_base_relation conn = + let scanned = + begin + let open Utilities.Result in + let* tx = S.start conn in + let* relation = SR.empty tx ~schematics:(hash "schema") () in + let* relation = + SR.assert_tuple tx relation (Concepts.Tuple.Representation.to_blob alaric) + in + let* () = S.commit tx in + let* employee = SR.wrap conn relation in + let root = + Kernel.Prototype.mixture + [ Kernel.Prototype.Directory.of_properties + ["employee", employee; "fol", Rnt.Evaluators.FOL.make ()] ] + in + let context = Runtime.Context.over ~snapshot:(hash "snapshot") ~root () in + let* found = Runtime.Context.resolve context "fol" in + let* evaluator = Option.to_result ~none:(not_a_program ()) found in + let* interpreter = + Rnt.Evaluators.FOL.Program.from evaluator + |> Option.to_result ~none:(not_a_program ()) + in + let* cursor = + Rnt.Evaluators.FOL.Program.invoke interpreter + ~program:(Rnt.Evaluators.FOL.Base "employee") context + in + let* scan = Protocols.Cursor.require cursor in + let* tuples = Protocols.Cursor.drain scan () in + Protocols.Handle.release cursor; + Ok (BatFingerTree.to_list tuples) + end + |> Helpers.condition_as_failure + in + check int "one tuple scanned" 1 (List.length scanned); + check bool "the tuple that was asserted" true + (List.for_all + (fun tuple -> + Concepts.Hash.hash_equals (Concepts.Tuple.hash tuple) (Concepts.Tuple.hash alaric)) + scanned) + + let suite prefix = + ( "fol/" ^ prefix, + [test_case "scan-a-base-relation" `Quick (H.with_connection scan_a_base_relation "fol-test")] + ) +end + +module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator) + +let suites () = [LMDB.suite "lmdb"] diff --git a/test/unit/evaluators/Lambda.ml b/test/unit/evaluators/Lambda.ml new file mode 100644 index 0000000..c1098cf --- /dev/null +++ b/test/unit/evaluators/Lambda.ml @@ -0,0 +1,142 @@ +open Rnt + +module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = struct + open Alcotest + + module H = Helpers.Storage.Make (S) (C) + module SR = Rnt.Kernel.SubstantialRelation.Make (S) + + let hash s = + Concepts.Blob.blob_of_bytes (Bytes.of_string s) |> Concepts.Hash.hash_of_blob + + let datum = + { Concepts.Tuple.type_ = "noun"; + attributes = + BatMap.String.empty + |> BatMap.String.add "lemma" (Concepts.Value.String "datum") } + + let reticulare = + { Concepts.Tuple.type_ = "verb"; + attributes = + BatMap.String.empty + |> BatMap.String.add "lemma" (Concepts.Value.String "rēticulāre") } + + let not_a_program () = + Concepts.Condition.condition "not-a-program" + "A handle was expected to carry the program protocol and did not" Concepts.Condition.empty + + (* Sets up the relations "noun" and "verb", each holding one Latin + lemma, hands [term] to the lambda evaluator, and drains the cursor + it returns. Change [term] in the cases below to play with the + calculus *) + let evaluate conn term = + let open Utilities.Result in + let* tx = S.start conn in + let singleton tuple = + let* relation = SR.empty tx ~schematics:(hash "schema") () in + SR.assert_tuple tx relation (Concepts.Tuple.Representation.to_blob tuple) + in + let* noun = singleton datum in + let* verb = singleton reticulare in + let* () = S.commit tx in + let* noun = SR.wrap conn noun in + let* verb = SR.wrap conn verb in + let root = + Kernel.Prototype.mixture + [ Kernel.Prototype.Directory.of_properties + ["noun", noun; "verb", verb; "lambda", Rnt.Evaluators.Lambda.make ()] ] + in + let context = Runtime.Context.over ~snapshot:(hash "snapshot") ~root () in + let* found = Runtime.Context.resolve context "lambda" in + let* evaluator = Option.to_result ~none:(not_a_program ()) found in + let* interpreter = + Rnt.Evaluators.Lambda.Program.from evaluator + |> Option.to_result ~none:(not_a_program ()) + in + let* cursor = Rnt.Evaluators.Lambda.Program.invoke interpreter ~program:term context in + let* scan = Protocols.Cursor.require cursor in + let* tuples = Protocols.Cursor.drain scan () in + Protocols.Handle.release cursor; + Ok (BatFingerTree.to_list tuples) + + let is lemma tuple = + Concepts.Hash.hash_equals (Concepts.Tuple.hash tuple) (Concepts.Tuple.hash lemma) + + (* A bare name resolves through the context, so the relations under + the snapshot are the outer environment *) + let a_name_is_a_relation conn = + let scanned = + evaluate conn (Rnt.Evaluators.Lambda.Name "noun") |> Helpers.condition_as_failure + in + check int "one tuple scanned" 1 (List.length scanned); + check bool "the tuple that was asserted" true (List.for_all (is datum) scanned) + + (* (\x. x) noun *) + let identity_applied_to_a_relation conn = + let open Rnt.Evaluators.Lambda in + let scanned = + evaluate conn (Apply (Abstract ("x", Name "x"), Name "noun")) + |> Helpers.condition_as_failure + in + check int "one tuple scanned" 1 (List.length scanned); + check bool "the tuple that was asserted" true (List.for_all (is datum) scanned) + + (* (\x. \y. x) noun (\z. z), so the argument that wins is the one + the closure kept *) + let a_closure_keeps_its_binding conn = + let open Rnt.Evaluators.Lambda in + let scanned = + evaluate conn + (Apply + ( Apply (Abstract ("x", Abstract ("y", Name "x")), Name "noun"), + Abstract ("z", Name "z") )) + |> Helpers.condition_as_failure + in + check int "one tuple scanned" 1 (List.length scanned); + check bool "the tuple that was asserted" true (List.for_all (is datum) scanned) + + (* The classic conditional, with no conditional in the calculus. A + boolean is the choice it makes, so [if] is application and both + branches are relations *) + let church_conditional conn = + let open Rnt.Evaluators.Lambda in + let true_ = Abstract ("then", Abstract ("else", Name "then")) in + let false_ = Abstract ("then", Abstract ("else", Name "else")) in + let if_ condition then_ else_ = Apply (Apply (condition, then_), else_) in + let declining = if_ true_ (Name "noun") (Name "verb") in + let conjugating = if_ false_ (Name "noun") (Name "verb") in + let declined = evaluate conn declining |> Helpers.condition_as_failure in + let conjugated = evaluate conn conjugating |> Helpers.condition_as_failure in + check int "one tuple on the then branch" 1 (List.length declined); + check bool "the then branch is the noun" true (List.for_all (is datum) declined); + check int "one tuple on the else branch" 1 (List.length conjugated); + check bool "the else branch is the verb" true (List.for_all (is reticulare) conjugated) + + (* A program reducing to an abstraction names nothing to + enumerate *) + let an_abstraction_is_not_a_result conn = + let open Rnt.Evaluators.Lambda in + match evaluate conn (Abstract ("x", Name "x")) with + | Error condition -> + check bool "unapplied abstraction" true + (String.starts_with ~prefix:"unapplied-abstraction" + (Concepts.Condition.to_string_hum condition)) + | Ok _ -> fail "an abstraction was enumerated" + + let suite prefix = + ( "lambda/" ^ prefix, + [ test_case "a-name-is-a-relation" `Quick + (H.with_connection a_name_is_a_relation "lambda-name"); + test_case "identity-applied-to-a-relation" `Quick + (H.with_connection identity_applied_to_a_relation "lambda-identity"); + test_case "a-closure-keeps-its-binding" `Quick + (H.with_connection a_closure_keeps_its_binding "lambda-closure"); + test_case "church-conditional" `Quick + (H.with_connection church_conditional "lambda-conditional"); + test_case "an-abstraction-is-not-a-result" `Quick + (H.with_connection an_abstraction_is_not_a_result "lambda-abstraction") ] ) +end + +module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator) + +let suites () = [LMDB.suite "lmdb"] diff --git a/test/unit/kernel/SubstantialRelation.ml b/test/unit/kernel/SubstantialRelation.ml index 9339845..9d60685 100644 --- a/test/unit/kernel/SubstantialRelation.ml +++ b/test/unit/kernel/SubstantialRelation.ml @@ -6,37 +6,48 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = module H = Helpers.Storage.Make (S) (C) module SR = Rnt.Kernel.SubstantialRelation.Make (S) - let blob s = Concepts.Blob.blob_of_bytes (Bytes.of_string s) - let hash s = blob s |> Concepts.Hash.hash_of_blob + let hash s = + Concepts.Blob.blob_of_bytes (Bytes.of_string s) |> Concepts.Hash.hash_of_blob - let assert_and_load conn = - let tuple = blob "tuple/alaric" in - let original_contains, updated_contains, loaded_contains = + let alaric = + { Concepts.Tuple.type_ = "employee"; + attributes = + BatMap.String.empty + |> BatMap.String.add "name" (Concepts.Value.String "Alaric") + |> BatMap.String.add "age" (Concepts.Value.Integer 42) } + + let assert_and_enumerate conn = + let tuple = Concepts.Tuple.Representation.to_blob alaric in + let before, after, enumerated = begin let open Utilities.Result in let* tx = S.start conn in - let* original = SR.empty tx ~heading:(hash "heading") () in - let* original_contains = SR.contains_tuple tx original tuple in - let* updated = SR.assert_tuple tx original tuple in - let* updated_contains = SR.contains_tuple tx updated tuple in - let* stored = SR.store tx updated in + let* relation = SR.empty tx ~schematics:(hash "schema") () in + let* before = SR.contains_tuple tx relation tuple in + let* relation = SR.assert_tuple tx relation tuple in + let* after = SR.contains_tuple tx relation tuple in let* () = S.commit tx in - let* tx = S.start conn in - let* loaded = SR.load_value tx stored in - let* loaded_contains = SR.contains_tuple tx loaded tuple in - let* () = S.abort tx in - Ok (original_contains, updated_contains, loaded_contains) + let* cursor = SR.enumerate conn relation in + let* scan = Protocols.Cursor.require cursor in + let* enumerated = Protocols.Cursor.drain scan () in + Protocols.Handle.release cursor; + Ok (before, after, BatFingerTree.to_list enumerated) end |> Helpers.condition_as_failure in - check bool "original" false original_contains; - check bool "updated" true updated_contains; - check bool "loaded" true loaded_contains + check bool "absent before assertion" false before; + check bool "present after assertion" true after; + check int "one tuple enumerated" 1 (List.length enumerated); + check bool "the tuple that was asserted" true + (List.for_all + (fun tuple -> + Concepts.Hash.hash_equals (Concepts.Tuple.hash tuple) (Concepts.Tuple.hash alaric)) + enumerated) let suite prefix = ( "substantial-relation/" ^ prefix, - [ test_case "assert-and-load" `Quick - (H.with_connection assert_and_load "substantial-relation-test") ] ) + [ test_case "assert-and-enumerate" `Quick + (H.with_connection assert_and_enumerate "substantial-relation-test") ] ) end module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator) |