aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/evaluators/FOL.ml118
-rw-r--r--lib/evaluators/Lambda.ml105
-rw-r--r--lib/kernel/EphemeralRelation.ml46
-rw-r--r--lib/kernel/EphemeralRelation.mli36
-rw-r--r--lib/kernel/Multigroup.ml2
-rw-r--r--lib/kernel/SubstantialRelation.ml130
-rw-r--r--lib/kernel/SubstantialRelation.mli55
-rw-r--r--lib/protocols/Evaluator.ml11
-rw-r--r--lib/protocols/Evaluator.mli10
-rw-r--r--lib/protocols/Program.ml16
-rw-r--r--lib/protocols/Program.mli15
-rw-r--r--lib/protocols/Relation.ml4
-rw-r--r--lib/protocols/Relation.mli9
-rw-r--r--test/Helpers.ml18
-rw-r--r--test/integration/Registration.ml8
-rw-r--r--test/test_rnt.ml1
-rw-r--r--test/unit/evaluators/FOL.ml119
-rw-r--r--test/unit/evaluators/Lambda.ml139
-rw-r--r--test/unit/kernel/EphemeralRelation.ml101
-rw-r--r--test/unit/kernel/Merkle.ml6
-rw-r--r--test/unit/kernel/SubstantialRelation.ml54
21 files changed, 360 insertions, 643 deletions
diff --git a/lib/evaluators/FOL.ml b/lib/evaluators/FOL.ml
index 4299524..016e3a0 100644
--- a/lib/evaluators/FOL.ml
+++ b/lib/evaluators/FOL.ml
@@ -7,32 +7,124 @@ module Error = struct
let cancelled () =
condition "evaluation-cancelled" "An evaluation was stopped before it produced its result" empty
+
+ let not_a_plan name =
+ condition "not-a-fol-program" "The evaluator was given an object that carries no FOL plan"
+ ("object" |=| Concepts.Value.String name)
+
+ let not_a_relation name =
+ condition "not-a-relation" "A plan named an object that does not describe itself as a relation"
+ ("object" |=| Concepts.Value.String name)
+
+ let unknown_attribute name =
+ condition "unknown-attribute" "A plan projected an attribute its relation does not have"
+ ("attribute" |=| Concepts.Value.String name)
+
+ let released_relation name =
+ condition "released-relation" "A plan named a relation that was already released"
+ ("object" |=| Concepts.Value.String name)
end
type plan = Base of Protocols.Handle.t | Project of plan * string BatFingerTree.t
+type Protocols.Handle.protocol += Plan of plan
+
+class program plan =
+ object
+ inherit Kernel.Lifecycle.null
+ inherit Kernel.Identity.of_id
+ method to_string = "fol-program"
+ method protocols : Protocols.Handle.protocol list = [Plan plan]
+ end
-module Program = Protocols.Program.Make (struct
- type t = plan
-end)
+let program plan = new program plan |> Protocols.Handle.make
+
+let restrict attributes description =
+ let open Utilities.Result in
+ BatFingerTree.fold_left
+ (fun restricted name ->
+ let* restricted = restricted in
+ let* attribute =
+ BatMap.String.find_opt name description
+ |> Option.to_result ~none:(Error.unknown_attribute name)
+ in
+ Ok (BatMap.String.add name attribute restricted) )
+ (Ok BatMap.String.empty) attributes
-let execute =
+let rec describe =
let open Utilities.Result in
function
- | Base relation_handle ->
- Fun.protect
- ~finally:(fun () -> Protocols.Handle.release relation_handle)
- (fun () ->
- let* enumerable = Protocols.Enumerable.require relation_handle in
- Protocols.Enumerable.enumerate enumerable )
- | Project (_plan, _attributes) -> failwith "TODO"
+ | Base relation -> (
+ let* schematics = Protocols.Handle.require Protocols.Schematics.from relation in
+ let* description = Protocols.Schematics.describe schematics in
+ match description with
+ | Protocols.Schematics.Relation description -> Ok description
+ | _ -> Error (Error.not_a_relation (Protocols.Handle.to_string relation)) )
+ | Project (plan, attributes) -> describe plan |> fmap (restrict attributes)
+
+let enumerate relation =
+ let open Utilities.Result in
+ let* enumerable = Protocols.Enumerable.require relation in
+ Protocols.Enumerable.enumerate enumerable
+
+let project description relation =
+ let open Utilities.Result in
+ let* cursor = enumerate relation in
+ let produce ~yield =
+ let* scan = Protocols.Cursor.require cursor in
+ let rec distinct seen =
+ let* next = Protocols.Cursor.next scan in
+ match next with
+ | None -> Ok ()
+ | Some tuple ->
+ let tuple =
+ { tuple with
+ attributes=
+ BatMap.String.filter
+ (fun name _ -> BatMap.String.mem name description)
+ tuple.Concepts.Tuple.attributes }
+ in
+ let key = Concepts.Tuple.hash tuple |> Concepts.Hash.to_raw_string in
+ if BatSet.String.mem key seen then distinct seen
+ else begin
+ yield tuple;
+ distinct (BatSet.String.add key seen)
+ end
+ in
+ distinct BatSet.String.empty
+ in
+ Ok (Kernel.Generator.cursor_of ~finally:(fun () -> Protocols.Handle.release cursor) produce)
+
+let derive relation description enumerate =
+ Kernel.EphemeralRelation.instantiate ~inputs:[relation] description
+ {Kernel.EphemeralRelation.schematics= `Temporary description}
+ (fun () -> enumerate relation)
+
+let rec execute plan =
+ let open Utilities.Result in
+ let* description = describe plan in
+ match plan with
+ | Base relation ->
+ let* relation =
+ Protocols.Handle.copy relation
+ |> Option.to_result ~none:(Error.released_relation (Protocols.Handle.to_string relation))
+ in
+ Ok (derive relation description enumerate)
+ | Project (plan, _) ->
+ let* relation = execute plan in
+ Ok (derive relation description (project description))
class evaluator =
object (self)
inherit Kernel.Lifecycle.null
inherit Kernel.Identity.of_id
method to_string = "fol-evaluator"
- method invoke = execute
- method protocols : Protocols.Handle.protocol list = [Program.make self]
+
+ method invoke program =
+ Protocols.Handle.into program (function Plan plan -> Some plan | _ -> None)
+ |> Option.to_result ~none:(Error.not_a_plan (Protocols.Handle.to_string program))
+ |> Utilities.Result.fmap (fun plan -> Protocols.Handle.invoke plan execute)
+
+ method protocols : Protocols.Handle.protocol list = [Protocols.Evaluator.make self]
end
let make () = new evaluator |> Protocols.Handle.make
diff --git a/lib/evaluators/Lambda.ml b/lib/evaluators/Lambda.ml
deleted file mode 100644
index d864ca1..0000000
--- a/lib/evaluators/Lambda.ml
+++ /dev/null
@@ -1,105 +0,0 @@
-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
-type program = Program of term * Protocols.Directory.t Protocols.Handle.interface
-
-module Program = Protocols.Program.Make (struct
- type t = program
-end)
-
-type value = Relation of Protocols.Handle.t | Closure of string * term * environment
-and environment = value BatMap.String.t
-
-(* let reduce context 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 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 *)
-
-let reduce (Program (term, dir)) =
- let open Utilities.Result in
- let open Protocols in
- let rec eval env term =
- match term with
- | Name name ->
- begin match BatMap.String.find_opt name env with
- | Some value -> Ok value
- | None ->
- let* handle =
- Directory.find dir name |> fmap (Option.to_result ~none:(Error.unknown_name name))
- in
- Ok (Relation handle)
- end
- | Abstract (binder, body) -> Ok (Closure (binder, body, env))
- | Apply (operator, operand) -> (
- let* operator = eval env operator in
- match operator with
- | Relation _ -> Error (Error.not_applicable ())
- | Closure (binder, body, closed) ->
- let* argument = eval env operand in
- eval (BatMap.String.add binder argument closed) body )
- in
- eval BatMap.String.empty term
-
-let execute term =
- let open Utilities.Result in
- let* value = reduce term in
- match value with
- | Closure _ -> Error (Error.unapplied_abstraction ())
- | Relation handle ->
- let* enumerable = Protocols.Enumerable.require handle in
- Protocols.Enumerable.enumerate enumerable
-
-class evaluator =
- object (self)
- inherit Kernel.Lifecycle.null
- inherit Kernel.Identity.of_id
- method to_string = "lambda-evaluator"
- method invoke program = execute program
- method protocols : Protocols.Handle.protocol list = [Program.make self]
- end
-
-let make () = new evaluator |> Protocols.Handle.make
diff --git a/lib/kernel/EphemeralRelation.ml b/lib/kernel/EphemeralRelation.ml
index ddf005d..e1e450d 100644
--- a/lib/kernel/EphemeralRelation.ml
+++ b/lib/kernel/EphemeralRelation.ml
@@ -1,29 +1,35 @@
type t =
- { schematics: [`Persisted of Concepts.Hash.hash
- | `Temporary of (Protocols.Schematics.attribute_description BatMap.String.t) ] }
+ { schematics:
+ [ `Persisted of Concepts.Hash.hash
+ | `Temporary of Protocols.Schematics.attribute_description BatMap.String.t ] }
module Error = struct
- open Concepts.Condition
- let local_constraint_not_implemented =
- condition "local-constraint-not-implemented"
- "Local constraints have no centralized authority for their discerniment and enforcement yet."
- empty
- let predicate_not_implemented =
- condition "predicate-not-implemented"
- "Preciate descriptions for relations is not designed yet."
- empty
+ (* open Concepts.Condition *)
end
-class ephemeral_relation program address value =
+class ephemeral_relation description value enumerate inputs =
object (self)
- inherit Lifecycle.null
+ inherit Lifecycle.counted
+ inherit Identity.of_id
+ method to_string = "ephemeral-relation"
val relation : t = value
- method local_constraints = Error Error.local_constraint_not_implemented
- method predicate = Error Error.predicate_not_implemented
+ method destroy = List.iter Protocols.Handle.release inputs
+ method enumerate : (Protocols.Handle.t, Concepts.Condition.condition) result = enumerate ()
+ method describe () = Ok (Protocols.Schematics.Relation description)
- method protocol : Protocols.Handle.protocol list =
- Protocols.[ Relation.make self
- ; Enumerable.make self
- ; Schematics.make self ]
- method hash : Concepts.Hash.hash = address
+ method contains (tuple : Concepts.Tuple.t) =
+ let open Utilities.Result in
+ let* cursor = self#enumerate in
+ Fun.protect
+ ~finally:(fun () -> Protocols.Handle.release cursor)
+ (fun () ->
+ let* scan = Protocols.Cursor.require cursor in
+ Protocols.Cursor.exists scan (fun member ->
+ Concepts.Hash.hash_equals (Concepts.Tuple.hash member) (Concepts.Tuple.hash tuple) ) )
+
+ method protocols : Protocols.Handle.protocol list =
+ Protocols.[Relation.make self; Enumerable.make self; Schematics.make self]
end
+
+let instantiate ?(inputs = []) description value enumerate =
+ new ephemeral_relation description value enumerate inputs |> Protocols.Handle.make
diff --git a/lib/kernel/EphemeralRelation.mli b/lib/kernel/EphemeralRelation.mli
deleted file mode 100644
index d082394..0000000
--- a/lib/kernel/EphemeralRelation.mli
+++ /dev/null
@@ -1,36 +0,0 @@
-module type DERIVATION = sig
- type plan
-
- (** the hash of the plan, taken over the branch-local names of its
- inputs rather than over their content addresses. The idea is to
- have the same expression denote one object on every branch and
- at every point in time. *)
- val identity : plan -> Concepts.Hash.hash
-
- val describe :
- plan -> (Protocols.Schematics.relation_description, Concepts.Condition.condition) result
-
- val modes : plan -> (Concepts.Mode.t, Concepts.Condition.condition) result
-
- val generate :
- plan ->
- Protocols.Generative.binding ->
- (Protocols.Handle.t, Concepts.Condition.condition) result
-end
-
-module Make (D : DERIVATION) : sig
- (** unpinned, the identity of the derivation itself; pinned to a
- branch commit, the identity of that derivation against one
- reconstructible state, which is the only form for which equal
- identity implies equal extension. *)
- val identity : ?pinned:Concepts.Hash.hash -> D.plan -> Concepts.Hash.hash
-
- (** edges are the handles the derivation reads, which are released
- when the relation is also. Rejection of a derivation surfaces
- here instead of when a cursor is being drained. *)
- val derive :
- ?pinned:Concepts.Hash.hash ->
- ?edges:Protocols.Handle.t list ->
- D.plan ->
- (Protocols.Handle.t, Concepts.Condition.condition) result
-end
diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml
index 602f3a9..88f5948 100644
--- a/lib/kernel/Multigroup.ml
+++ b/lib/kernel/Multigroup.ml
@@ -57,7 +57,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
[ Addressable.make self;
Prototype.Directory.of_properties
[ ( "relation",
- Prototype.mixture [RMDirectory.make ~storage ~node ~constructor:(R.wrap storage)]
+ Prototype.mixture [RMDirectory.make ~storage ~node ~constructor:(R.load storage)]
) ] ]
method hash = Representation.to_blob multigroup |> Concepts.Hash.hash_of_blob
diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml
index 242aedb..844b186 100644
--- a/lib/kernel/SubstantialRelation.ml
+++ b/lib/kernel/SubstantialRelation.ml
@@ -43,12 +43,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
module TupleSet = Merkle.Interface (S) (TupleKey) (TupleValue)
- type t =
- { schematics: Concepts.Hash.hash;
- predicate: Concepts.Hash.hash option;
- local_constraints: Concepts.Hash.hash option;
- tuples: TupleSet.address;
- indexes: Concepts.Hash.hash option }
+ type t = {schematics: Concepts.Hash.hash; tuples: TupleSet.address}
module rec Representation : (Concepts.Encoding.Record.S with type t = t) =
Concepts.Encoding.Record.Make (Body)
@@ -59,58 +54,26 @@ module Make (S : Abstract.Storage.STORAGE) = struct
let tag = 'R'
let malformed = Error.malformed_relation
- let fields {schematics; predicate; local_constraints; tuples; indexes} =
+ let fields {schematics; tuples} =
let open Concepts.Encoding in
- [ "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;
- "indexes", Value.bencode_of_option Value.bencode_of_hash indexes ]
+ ["schema", Value.bencode_of_hash schematics; "tuples", Value.bencode_of_hash tuples]
let of_fields fields =
let open Utilities.Result in
let open Concepts.Encoding 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
- let* local_constraints =
- Bencode.field "local-constraints" fields
- |> fmap (Value.option_of_bencode Value.hash_of_bencode)
- in
let* tuples = Bencode.field "tuples" fields |> fmap Value.hash_of_bencode in
- let* indexes =
- Bencode.field "indexes" fields |> fmap (Value.option_of_bencode Value.hash_of_bencode)
- in
- Ok {schematics; predicate; local_constraints; tuples; indexes}
+ Ok {schematics; tuples}
end
let encode = Representation.to_blob
let decode = Representation.of_blob
- let schematics {schematics; _} = schematics
- let predicate {predicate; _} = predicate
- let local_constraints {local_constraints; _} = local_constraints
- let tuples {tuples; _} = tuples
- let indexes {indexes; _} = indexes
- let hash relation = Representation.to_blob relation |> Concepts.Hash.hash_of_blob
let tuple_node tx relation =
let open Utilities.Result in
let* tuples = TupleSet.find tx relation.tuples in
Option.to_result ~none:(Error.invalid_tuple_root relation.tuples) tuples
- let empty tx ~schematics ?predicate ?local_constraints ?indexes () =
- let open Utilities.Result in
- let* tuples = TupleSet.empty_under tx in
- Ok {schematics; predicate; local_constraints; tuples; indexes}
-
- let store tx relation = SI.store_blob tx (Representation.to_blob relation)
-
- let contains_tuple tx relation tuple =
- let open Utilities.Result in
- let* node = tuple_node tx relation in
- TupleSet.mem tx (Concepts.Tuple.hash tuple) node
-
let schema_of tx relation =
let open Utilities.Result in
let* data = SI.get_req tx (S.Hash relation.schematics) in
@@ -123,87 +86,52 @@ module Make (S : Abstract.Storage.STORAGE) = struct
|> Utilities.List.sequence
|> Result.map BatMap.String.of_list
- let generate storage relation binding =
+ let enumerate connection relation =
let open Utilities.Result in
- let* tx = S.start_read storage in
+ let* tx = S.start_read connection in
let close () = ignore (S.abort tx) in
let* node = tuple_node tx relation |> Result.map_error (fun c -> close (); c) 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 =
- TupleSet.iter tx
- (fun _ tuple -> if Protocols.Generative.satisfies binding tuple then yield tuple)
- node
- in
- Ok (Generator.cursor_of ~finally:close produce)
-
- let enumerate storage relation = generate storage relation Protocols.Generative.nothing
-
- let modes_of description =
- Concepts.Mode.of_list
- [ Concepts.Mode.enumerable Concepts.Cardinality.Finite;
- {Concepts.Mode.bound= Concepts.Mode.attributes_of_map description; affords= Decides} ]
+ Ok
+ (Generator.cursor_of ~finally:close (fun ~yield ->
+ TupleSet.iter tx (fun _ tuple -> yield tuple) node ) )
- class relation storage value description =
+ class substantial_relation connection value description =
object (self)
inherit Lifecycle.null
method to_string = "relation"
- val storage : S.connection = storage
+ val connection : S.connection = connection
val relation : t = value
- val declaration = modes_of description
- method predicate = Ok relation.predicate
- method local_constraints = Ok relation.local_constraints
- (* 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_read storage (fun tx -> contains_tuple tx relation tuple)
+ SI.with_read connection (fun tx ->
+ let open Utilities.Result in
+ let* node = tuple_node tx relation in
+ TupleSet.mem tx (Concepts.Tuple.hash tuple) node )
method describe () = 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 = enumerate storage relation
- method modes : (Concepts.Mode.t, Concepts.Condition.condition) result = Ok declaration
- method generate binding = generate storage relation binding
+ method enumerate = enumerate connection relation
method protocols : Protocols.Handle.protocol list =
[ Protocols.Relation.make self;
Protocols.Enumerable.make self;
Protocols.Schematics.make self ]
- method hash = hash relation
+ method hash = encode relation |> Concepts.Hash.hash_of_blob
end
- (* A relation never changes its schema, so it is read once here and
- the description and modes are served from it on every request. *)
- let instantiate tx conn relation =
- schema_of tx relation
+ let load connection relation =
+ SI.with_read connection (fun tx -> schema_of tx relation)
|> Result.map (fun description ->
- new relation conn relation description |> Protocols.Handle.make )
-
- let make conn ~schematics ?predicate ?local_constraints ?indexes () =
- let open Utilities.Result in
- SI.with_transaction conn (fun tx ->
- let* relation = empty tx ~schematics ?predicate ?local_constraints ?indexes () in
- let* _ = store tx relation in
- instantiate tx conn relation )
+ new substantial_relation connection relation description |> Protocols.Handle.make )
- let load_value tx addr =
+ let instantiate connection ~schematics =
let open Utilities.Result in
- let* data = SI.get_req tx (S.Hash addr) in
- Representation.of_blob data
-
- let wrap conn relation = SI.with_read conn (fun tx -> instantiate tx conn relation)
- let load tx conn addr = load_value tx addr |> Utilities.Result.fmap (instantiate tx conn)
-
- let assert_tuple tx relation tuple =
- let open Utilities.Result in
- let* node = tuple_node tx relation in
- let* node = TupleSet.insert tx (Concepts.Tuple.hash tuple) tuple node in
- Ok {relation with tuples= TupleSet.hash_of node}
+ let* relation =
+ SI.with_transaction connection (fun tx ->
+ let* tuples = TupleSet.empty_under tx in
+ let relation = {schematics; tuples} in
+ let* _ = SI.store_blob tx (encode relation) in
+ Ok relation )
+ in
+ load connection relation
end
diff --git a/lib/kernel/SubstantialRelation.mli b/lib/kernel/SubstantialRelation.mli
deleted file mode 100644
index 98f1e8f..0000000
--- a/lib/kernel/SubstantialRelation.mli
+++ /dev/null
@@ -1,55 +0,0 @@
-module Make (S : Abstract.Storage.STORAGE) : sig
- type t
-
- val encode : t -> Concepts.Blob.t
- val decode : Concepts.Blob.t -> (t, Concepts.Condition.condition) result
-
- val empty :
- S.transaction ->
- schematics:Concepts.Hash.hash ->
- ?predicate:Concepts.Hash.hash ->
- ?local_constraints:Concepts.Hash.hash ->
- ?indexes:Concepts.Hash.hash ->
- unit ->
- (t, Concepts.Condition.condition) result
-
- val store : S.transaction -> t -> (Concepts.Hash.hash, Concepts.Condition.condition) result
-
- val make :
- S.connection ->
- schematics:Concepts.Hash.hash ->
- ?predicate:Concepts.Hash.hash ->
- ?local_constraints:Concepts.Hash.hash ->
- ?indexes:Concepts.Hash.hash ->
- unit ->
- (Protocols.Handle.t, Concepts.Condition.condition) result
-
- val load_value : S.transaction -> Concepts.Hash.hash -> (t, Concepts.Condition.condition) result
- val wrap : S.connection -> t -> (Protocols.Handle.t, Concepts.Condition.condition) result
-
- val load :
- S.transaction ->
- S.connection ->
- Concepts.Hash.hash ->
- (Protocols.Handle.t, Concepts.Condition.condition) result
-
- 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
- val indexes : t -> Concepts.Hash.hash option
- val hash : t -> Concepts.Hash.hash
-
- val assert_tuple :
- S.transaction -> t -> Concepts.Tuple.t -> (t, Concepts.Condition.condition) result
-
- val contains_tuple :
- S.transaction -> t -> Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result
-
- val schema_of :
- S.transaction ->
- t ->
- (Protocols.Schematics.relation_description, Concepts.Condition.condition) result
-
- val enumerate : S.connection -> t -> (Protocols.Handle.t, Concepts.Condition.condition) result
-end
diff --git a/lib/protocols/Evaluator.ml b/lib/protocols/Evaluator.ml
new file mode 100644
index 0000000..789fb9d
--- /dev/null
+++ b/lib/protocols/Evaluator.ml
@@ -0,0 +1,11 @@
+class type implementation = object
+ method invoke : Handle.t -> (Handle.t, Concepts.Condition.condition) result
+end
+
+type Handle.protocol += Evaluator of implementation
+type t = implementation
+
+let make impl = Evaluator (impl :> implementation)
+let from handle = Handle.into handle (function Evaluator impl -> Some impl | _ -> None)
+let require = Handle.require from
+let invoke i program = Handle.invoke i (fun o -> o#invoke program)
diff --git a/lib/protocols/Evaluator.mli b/lib/protocols/Evaluator.mli
new file mode 100644
index 0000000..3d42b5c
--- /dev/null
+++ b/lib/protocols/Evaluator.mli
@@ -0,0 +1,10 @@
+type t
+
+class type implementation = object
+ method invoke : Handle.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 invoke : t Handle.interface -> Handle.t -> (Handle.t, Concepts.Condition.condition) result
diff --git a/lib/protocols/Program.ml b/lib/protocols/Program.ml
deleted file mode 100644
index e50f07d..0000000
--- a/lib/protocols/Program.ml
+++ /dev/null
@@ -1,16 +0,0 @@
-module type PROGRAM = sig
- type t
-end
-
-module Make (P : PROGRAM) = struct
- class type implementation = object
- method invoke : P.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 = Handle.invoke i (fun o -> o#invoke program)
-end
diff --git a/lib/protocols/Program.mli b/lib/protocols/Program.mli
deleted file mode 100644
index 6cdffd8..0000000
--- a/lib/protocols/Program.mli
+++ /dev/null
@@ -1,15 +0,0 @@
-module type PROGRAM = sig
- type t
-end
-
-module Make (P : PROGRAM) : sig
- type t
-
- class type implementation = object
- method invoke : P.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 -> P.t -> (Handle.t, Concepts.Condition.condition) result
-end
diff --git a/lib/protocols/Relation.ml b/lib/protocols/Relation.ml
index c05337f..3962c9c 100644
--- a/lib/protocols/Relation.ml
+++ b/lib/protocols/Relation.ml
@@ -7,8 +7,6 @@ module Error = struct
end
class type implementation = object
- 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
end
@@ -18,6 +16,4 @@ 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 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 b4a11ec..be11cc1 100644
--- a/lib/protocols/Relation.mli
+++ b/lib/protocols/Relation.mli
@@ -1,19 +1,10 @@
type t
class type implementation = object
- 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
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 predicate :
- t Handle.interface -> (Concepts.Hash.hash option, Concepts.Condition.condition) result
-
-val local_constraints :
- t Handle.interface -> (Concepts.Hash.hash option, Concepts.Condition.condition) result
-
val contains : t Handle.interface -> Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result
diff --git a/test/Helpers.ml b/test/Helpers.ml
index 42cf8a5..7f65007 100644
--- a/test/Helpers.ml
+++ b/test/Helpers.ml
@@ -32,11 +32,29 @@ module Storage = struct
module Make (S : Abstract.Storage.STORAGE) (C : CONFIGURATOR) = struct
module SI = Kernel.Storage.Make (S)
+ module SR = Kernel.SubstantialRelation.Make (S)
let store_schema tx attributes =
Concepts.Encoding.Bencode.(Dict (List.map (fun a -> a, String "string") attributes) |> to_blob)
|> SI.store_blob tx
+ let relation conn attributes tuples =
+ let open Utilities.Result in
+ let* value =
+ SI.with_transaction conn (fun tx ->
+ let* schematics = store_schema tx attributes in
+ let* _ = SR.TupleSet.empty_under tx in
+ let* node =
+ List.fold_left
+ (fun node tuple ->
+ let* node = node in
+ SR.TupleSet.insert tx (Concepts.Tuple.hash tuple) tuple node )
+ (Ok SR.TupleSet.empty) tuples
+ in
+ Ok {SR.schematics; tuples= SR.TupleSet.hash_of node} )
+ in
+ SR.load conn value
+
let with_connection f dir () =
with_temporary_directory dir begin fun dir ->
begin
diff --git a/test/integration/Registration.ml b/test/integration/Registration.ml
index 9ac26f4..60f1690 100644
--- a/test/integration/Registration.ml
+++ b/test/integration/Registration.ml
@@ -30,11 +30,11 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
end
|> Helpers.condition_as_failure
- let suite prefix =
- ( "registration/" ^ prefix,
- [test_case "registration tests" `Quick (H.with_connection run "registration-test")] )
+ let suite =
+ ( "registration",
+ [test_case "register-and-lookup" `Quick (H.with_connection run "registration-test")] )
end
module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator)
-let suites () = [LMDB.suite "lmdb"]
+let suites () = [LMDB.suite]
diff --git a/test/test_rnt.ml b/test/test_rnt.ml
index b9c5962..799ad53 100644
--- a/test/test_rnt.ml
+++ b/test/test_rnt.ml
@@ -5,7 +5,6 @@ let all_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
index 404e7a4..046fa3f 100644
--- a/test/unit/evaluators/FOL.ml
+++ b/test/unit/evaluators/FOL.ml
@@ -3,7 +3,6 @@ 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 alaric =
{ Concepts.Tuple.type_= "employee";
@@ -14,20 +13,31 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
Concepts.Condition.condition "not-a-directory"
"A handle was expected to carry the directory protocol and did not" Concepts.Condition.empty
- 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 missing name =
+ Concepts.Condition.condition "missing" "A name was expected in the directory and was absent"
+ Concepts.Condition.("name" |=| Concepts.Value.String name)
+
+ let employee name age =
+ { Concepts.Tuple.type_= "employee";
+ attributes=
+ BatMap.String.of_list ["name", Concepts.Value.String name; "age", Concepts.Value.Integer age]
+ }
+
+ let drain result =
+ let open Utilities.Result in
+ let* enumerable = Protocols.Enumerable.require result in
+ let* cursor = Protocols.Enumerable.enumerate enumerable in
+ let* scan = Protocols.Cursor.require cursor in
+ let* tuples = Protocols.Cursor.drain scan () in
+ Protocols.Handle.release cursor;
+ Protocols.Handle.release result;
+ Ok (BatFingerTree.to_list tuples)
let scan_a_base_relation conn =
let scanned =
begin
let open Utilities.Result in
- let* tx = S.start conn in
- let* schematics = H.store_schema tx ["name"] in
- let* relation = SR.empty tx ~schematics () in
- let* relation = SR.assert_tuple tx relation alaric in
- let* () = S.commit tx in
- let* employee = SR.wrap conn relation in
+ let* employee = H.relation conn ["name"] [alaric] in
let root =
Kernel.Prototype.mixture
[ Kernel.Prototype.Directory.of_properties
@@ -37,17 +47,12 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
Protocols.Directory.from root |> Option.to_result ~none:(not_a_directory ())
in
let* found = Protocols.Directory.find directory "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 ())
+ let* evaluator = Option.to_result ~none:(missing "fol") found in
+ let* evaluator = Protocols.Evaluator.require evaluator in
+ let* result =
+ Rnt.Evaluators.FOL.(program (Base employee)) |> Protocols.Evaluator.invoke evaluator
in
- let* cursor =
- Rnt.Evaluators.FOL.Program.invoke interpreter (Rnt.Evaluators.FOL.Base employee)
- in
- let* scan = Protocols.Cursor.require cursor in
- let* tuples = Protocols.Cursor.drain scan () in
- Protocols.Handle.release cursor;
- Ok (BatFingerTree.to_list tuples)
+ drain result
end
|> Helpers.condition_as_failure
in
@@ -58,12 +63,76 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
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")]
- )
+ let project_away_an_attribute conn =
+ let projected =
+ begin
+ let open Utilities.Result in
+ let* employees =
+ H.relation conn ["name"; "age"]
+ [employee "Alaric" 42; employee "Alaric" 30; employee "Brunhild" 42]
+ in
+ let* evaluator = Protocols.Evaluator.require (Rnt.Evaluators.FOL.make ()) in
+ let* result =
+ Rnt.Evaluators.FOL.(program (Project (Base employees, BatFingerTree.singleton "name")))
+ |> Protocols.Evaluator.invoke evaluator
+ in
+ drain result
+ end
+ |> Helpers.condition_as_failure
+ in
+ check
+ (list (list (pair string Helpers.value)))
+ "each name once, and nothing else"
+ [["name", Concepts.Value.String "Alaric"]; ["name", Concepts.Value.String "Brunhild"]]
+ ( projected
+ |> List.map (fun tuple -> BatMap.String.bindings tuple.Concepts.Tuple.attributes)
+ |> List.sort compare )
+
+ let pull_one_tuple_at_a_time () =
+ let produced = ref 0 and closed = ref false in
+ let description =
+ BatMap.String.singleton "value" {Protocols.Schematics.domain= "integer"; provenance= []}
+ in
+ let rec count ~yield n =
+ incr produced;
+ yield
+ { Concepts.Tuple.type_= "counter";
+ attributes= BatMap.String.singleton "value" (Concepts.Value.Integer n) };
+ count ~yield (n + 1)
+ in
+ let source =
+ Kernel.EphemeralRelation.instantiate description
+ {Kernel.EphemeralRelation.schematics= `Temporary description}
+ (fun () -> Ok (Kernel.Generator.cursor_of ~finally:(fun () -> closed := true) (count 0)))
+ in
+ let first =
+ begin
+ let open Utilities.Result in
+ let* evaluator = Protocols.Evaluator.require (Rnt.Evaluators.FOL.make ()) in
+ let* result =
+ Rnt.Evaluators.FOL.(program (Project (Base source, BatFingerTree.singleton "value")))
+ |> Protocols.Evaluator.invoke evaluator
+ in
+ let* enumerable = Protocols.Enumerable.require result in
+ let* cursor = Protocols.Enumerable.enumerate enumerable in
+ let* scan = Protocols.Cursor.require cursor in
+ let* first = Protocols.Cursor.next scan in
+ Protocols.Handle.release cursor; Protocols.Handle.release result; Ok first
+ end
+ |> Helpers.condition_as_failure
+ in
+ check bool "a tuple came through" true (Option.is_some first);
+ check int "the source produced only that tuple" 1 !produced;
+ check bool "and was closed with its consumer" true !closed
+
+ let suite =
+ ( "evaluators/fol",
+ [ test_case "scan-a-base-relation" `Quick (H.with_connection scan_a_base_relation "fol-test");
+ test_case "project-away-an-attribute" `Quick
+ (H.with_connection project_away_an_attribute "fol-test");
+ test_case "pull-one-tuple-at-a-time" `Quick pull_one_tuple_at_a_time ] )
end
module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator)
-let suites () = [LMDB.suite "lmdb"]
+let suites () = [LMDB.suite]
diff --git a/test/unit/evaluators/Lambda.ml b/test/unit/evaluators/Lambda.ml
deleted file mode 100644
index ee15c16..0000000
--- a/test/unit/evaluators/Lambda.ml
+++ /dev/null
@@ -1,139 +0,0 @@
-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 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_directory () =
- Concepts.Condition.condition "not-a-directory"
- "A handle was expected to carry the directory protocol and did not" Concepts.Condition.empty
-
- 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* schematics = H.store_schema tx ["lemma"] in
- let singleton tuple =
- let* relation = SR.empty tx ~schematics () in
- SR.assert_tuple tx relation 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* directory = Protocols.Directory.from root |> Option.to_result ~none:(not_a_directory ()) in
- let* found = Protocols.Directory.find directory "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, directory))) 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 directory, so the relations it
- holds 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/EphemeralRelation.ml b/test/unit/kernel/EphemeralRelation.ml
index f75fd0d..c4bfc05 100644
--- a/test/unit/kernel/EphemeralRelation.ml
+++ b/test/unit/kernel/EphemeralRelation.ml
@@ -1,46 +1,21 @@
open Alcotest
module Concepts = Rnt.Concepts
module Protocols = Rnt.Protocols
-
-(* A derivation over a fixed set of members. It reads nothing and
- computes nothing, so what the tests observe is the kernel object
- rather than any particular evaluator. *)
-module Derivation = struct
- type plan = {name: string; members: Concepts.Tuple.t list; declared: Concepts.Mode.t}
-
- let identity {name; _} = Concepts.Hash.hash_of_bytes (Bytes.of_string name)
-
- let describe _ =
- Ok
- (BatMap.String.singleton "value"
- { Protocols.Schematics.domain= "integer";
- provenance= [{Protocols.Schematics.source= ["example"]; attribute= "value"}] } )
-
- let modes {declared; _} = Ok declared
-
- let generate {members; _} binding =
- Ok
- (Rnt.Kernel.Generator.cursor_of (fun ~yield ->
- List.iter
- (fun member -> if Protocols.Generative.satisfies binding member then yield member)
- members;
- Ok () ) )
-end
-
-module Derived = Rnt.Kernel.EphemeralRelation.Make (Derivation)
+module Ephemeral = Rnt.Kernel.EphemeralRelation
let member n =
{ Concepts.Tuple.type_= "example";
attributes= BatMap.String.singleton "value" (Concepts.Value.Integer n) }
-let plan_over cardinality =
- { Derivation.name= "the-derivation";
- members= [member 1; member 2; member 3];
- declared=
- Concepts.Mode.of_list
- [Concepts.Mode.enumerable cardinality; Concepts.Mode.decides_when ["value"]] }
+let description =
+ BatMap.String.singleton "value"
+ { Protocols.Schematics.domain= "integer";
+ provenance= [{Protocols.Schematics.source= ["example"]; attribute= "value"}] }
-let derive plan = Derived.derive plan |> Helpers.condition_as_failure
+let over ?inputs members =
+ Ephemeral.instantiate ?inputs description
+ {Ephemeral.schematics= `Temporary description}
+ (fun () -> Ok (Rnt.Kernel.Generator.cursor_of (fun ~yield -> List.iter yield members; Ok ())))
let values tuples =
BatFingerTree.to_list tuples
@@ -50,25 +25,11 @@ let values tuples =
| _ -> None )
|> List.sort compare
-let commit = Concepts.Hash.hash_of_bytes (Bytes.of_string "a-commit")
-
-let identity_is_the_derivation () =
- let plan = plan_over Concepts.Cardinality.Finite in
- check bool "unpinned, the identity of the plan" true
- (Concepts.Hash.hash_equals (Derived.identity plan) (Derivation.identity plan));
- check bool "pinned to a commit, another identity" false
- (Concepts.Hash.hash_equals (Derived.identity plan) (Derived.identity ~pinned:commit plan));
- check bool "the same pin twice is the same identity" true
- (Concepts.Hash.hash_equals
- (Derived.identity ~pinned:commit plan)
- (Derived.identity ~pinned:commit plan) )
-
-let an_exhaustible_derivation_enumerates () =
- let derived = derive (plan_over Concepts.Cardinality.Finite) in
+let enumerates_every_member () =
let enumerated =
begin
let open Rnt.Utilities.Result in
- let* enumerable = Protocols.Enumerable.require derived in
+ let* enumerable = Protocols.Enumerable.require (over [member 1; member 2; member 3]) in
let* cursor = Protocols.Enumerable.enumerate enumerable in
let* scan = Protocols.Cursor.require cursor in
let* tuples = Protocols.Cursor.drain scan () in
@@ -79,28 +40,25 @@ let an_exhaustible_derivation_enumerates () =
in
check (list int) "every member" [1; 2; 3] enumerated
-let a_countable_derivation_decides_only () =
- let derived = derive (plan_over Concepts.Cardinality.Countable) in
+let decides_membership () =
let holds, rejects =
begin
let open Rnt.Utilities.Result in
- let* relation = Protocols.Relation.require derived in
+ let* relation = Protocols.Relation.require (over [member 1; member 2; member 3]) in
let* holds = Protocols.Relation.contains relation (member 2) in
let* rejects = Protocols.Relation.contains relation (member 9) in
Ok (holds, rejects)
end
|> Helpers.condition_as_failure
in
- check bool "no enumeration is offered" false (Option.is_some (Protocols.Enumerable.from derived));
- check bool "membership is still decided" true holds;
- check bool "and still refused" false rejects
+ check bool "a member is held" true holds;
+ check bool "a stranger is refused" false rejects
-let a_derivation_describes_itself () =
- let derived = derive (plan_over Concepts.Cardinality.Finite) in
+let describes_itself () =
let described =
begin
let open Rnt.Utilities.Result in
- let* schematics = Protocols.Handle.require Protocols.Schematics.from derived in
+ let* schematics = Protocols.Handle.require Protocols.Schematics.from (over []) in
Protocols.Schematics.describe schematics
end
|> Helpers.condition_as_failure
@@ -118,32 +76,27 @@ let a_derivation_describes_itself () =
String.concat "/" origin.Protocols.Schematics.source
^ "/"
^ origin.Protocols.Schematics.attribute ) ) )
- | _ -> fail "a derived relation describes itself as a relation"
+ | _ -> fail "an ephemeral relation describes itself as a relation"
-let releasing_a_derivation_releases_its_inputs () =
+let releasing_releases_its_inputs () =
let released = ref false in
let input =
object
method reference = true
method release = released := true
method hash = Concepts.Hash.hash_of_int 0
+ method to_string = "input"
method protocols : Protocols.Handle.protocol list = []
end
in
- let edge = Protocols.Handle.make input in
- let derived =
- Derived.derive ~edges:[edge] (plan_over Concepts.Cardinality.Finite)
- |> Helpers.condition_as_failure
- in
- check bool "an input is held while the derivation lives" false !released;
- Protocols.Handle.release derived;
+ let relation = over ~inputs:[Protocols.Handle.make input] [] in
+ check bool "an input is held while the relation lives" false !released;
+ Protocols.Handle.release relation;
check bool "and released with it" true !released
let suites () =
[ ( "kernel/ephemeral-relation",
- [ test_case "identity-is-the-derivation" `Quick identity_is_the_derivation;
- test_case "an-exhaustible-derivation-enumerates" `Quick an_exhaustible_derivation_enumerates;
- test_case "a-countable-derivation-decides-only" `Quick a_countable_derivation_decides_only;
- test_case "a-derivation-describes-itself" `Quick a_derivation_describes_itself;
- test_case "releasing-a-derivation-releases-its-inputs" `Quick
- releasing_a_derivation_releases_its_inputs ] ) ]
+ [ test_case "enumerates-every-member" `Quick enumerates_every_member;
+ test_case "decides-membership" `Quick decides_membership;
+ test_case "describes-itself" `Quick describes_itself;
+ test_case "releasing-releases-its-inputs" `Quick releasing_releases_its_inputs ] ) ]
diff --git a/test/unit/kernel/Merkle.ml b/test/unit/kernel/Merkle.ml
index eaff92d..9d0dc6e 100644
--- a/test/unit/kernel/Merkle.ml
+++ b/test/unit/kernel/Merkle.ml
@@ -126,8 +126,8 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
(* let determinism _conn = *)
(* () *)
- let suite prefix =
- ( "merkle/" ^ prefix,
+ let suite =
+ ( "kernel/merkle",
[ test_case "insert-and-lookup" `Quick (H.with_connection insert_and_lookup "merkle-test");
test_case "batching" `Quick (H.with_connection batching "merkle-test");
test_case "persistence" `Quick (H.with_connection persistence "merkle-test");
@@ -136,4 +136,4 @@ end
module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator)
-let suites () = [LMDB.suite "lmdb"]
+let suites () = [LMDB.suite]
diff --git a/test/unit/kernel/SubstantialRelation.ml b/test/unit/kernel/SubstantialRelation.ml
index db13026..b9f87bf 100644
--- a/test/unit/kernel/SubstantialRelation.ml
+++ b/test/unit/kernel/SubstantialRelation.ml
@@ -5,8 +5,6 @@ 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 hash s = Concepts.Blob.blob_of_bytes (Bytes.of_string s) |> Concepts.Hash.hash_of_blob
-
let alaric =
{ Concepts.Tuple.type_= "employee";
attributes=
@@ -14,26 +12,38 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
|> BatMap.String.add "name" (Concepts.Value.String "Alaric")
|> BatMap.String.add "age" (Concepts.Value.Integer 42) }
- let assert_and_enumerate conn =
- let before, after, enumerated =
+ let contains relation tuple =
+ let open Utilities.Result in
+ let* relation = Protocols.Relation.require relation in
+ Protocols.Relation.contains relation tuple
+
+ let enumerate relation =
+ let open Utilities.Result in
+ let* enumerable = Protocols.Enumerable.require relation in
+ let* cursor = Protocols.Enumerable.enumerate enumerable in
+ let* scan = Protocols.Cursor.require cursor in
+ let* enumerated = Protocols.Cursor.drain scan () in
+ Protocols.Handle.release cursor;
+ Ok (BatFingerTree.to_list enumerated)
+
+ let contain_and_enumerate conn =
+ let absent, present, enumerated =
begin
let open Utilities.Result in
- let* tx = S.start conn in
- let* relation = SR.empty tx ~schematics:(hash "schema") () in
- let* before = SR.contains_tuple tx relation alaric in
- let* relation = SR.assert_tuple tx relation alaric in
- let* after = SR.contains_tuple tx relation alaric in
- let* () = S.commit tx in
- 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)
+ let* schematics =
+ H.SI.with_transaction conn (fun tx -> H.store_schema tx ["name"; "age"])
+ in
+ let* empty = SR.instantiate conn ~schematics in
+ let* absent = contains empty alaric in
+ let* holding = H.relation conn ["name"; "age"] [alaric] in
+ let* present = contains holding alaric in
+ let* enumerated = enumerate holding in
+ Ok (absent, present, enumerated)
end
|> Helpers.condition_as_failure
in
- check bool "absent before assertion" false before;
- check bool "present after assertion" true after;
+ check bool "absent from an empty relation" false absent;
+ check bool "present in a relation holding it" true present;
check int "one tuple enumerated" 1 (List.length enumerated);
check bool "the tuple that was asserted" true
(List.for_all
@@ -41,12 +51,12 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
Concepts.Hash.hash_equals (Concepts.Tuple.hash tuple) (Concepts.Tuple.hash alaric) )
enumerated )
- let suite prefix =
- ( "substantial-relation/" ^ prefix,
- [ test_case "assert-and-enumerate" `Quick
- (H.with_connection assert_and_enumerate "substantial-relation-test") ] )
+ let suite =
+ ( "kernel/substantial-relation",
+ [ test_case "contain-and-enumerate" `Quick
+ (H.with_connection contain_and_enumerate "substantial-relation-test") ] )
end
module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator)
-let suites () = [LMDB.suite "lmdb"]
+let suites () = [LMDB.suite]
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 07:14:09 +0000