aboutsummaryrefslogtreecommitdiffstats
path: root/test/unit
diff options
context:
space:
mode:
Diffstat (limited to 'test/unit')
-rw-r--r--test/unit/evaluators/FOL.ml164
-rw-r--r--test/unit/kernel/Branch.ml20
-rw-r--r--test/unit/kernel/SubstantialRelation.ml63
3 files changed, 242 insertions, 5 deletions
diff --git a/test/unit/evaluators/FOL.ml b/test/unit/evaluators/FOL.ml
index 4a6cadd..2049f23 100644
--- a/test/unit/evaluators/FOL.ml
+++ b/test/unit/evaluators/FOL.ml
@@ -190,18 +190,169 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
let holds term tuple = ask term (fun r -> Protocols.Relation.contains r tuple) in
check
(list (pair (list string) string))
- "a base relation keeps the lookup by hash"
- [[], "finite"; ["age"; "name"], "bounded(1)"]
+ "a base relation keeps the lookup by hash and one lookup per index"
+ [[], "finite"; ["age"; "name"], "bounded(1)"; ["age"], "finite"; ["name"], "finite"]
(modes employees);
check
(list (pair (list string) string))
"its projection keeps only what a projected tuple can bind"
- [[], "finite"]
+ [[], "finite"; ["name"], "finite"]
(modes names);
check bool "the base decides by its own test" true (holds employees (employee "Alaric" 42));
check bool "the projection decides by reading" true (holds names (named "Alaric"));
check bool "and refuses a stranger" false (holds names (named "Gunther"))
+ let aged age = BatMap.String.singleton "age" (Concepts.Value.Integer age)
+ let called name = BatMap.String.singleton "name" (Concepts.Value.String name)
+ let staff = [employee "Alaric" 42; employee "Brunhild" 30; employee "Gunther" 42]
+
+ module F = Rnt.Evaluators.FOL
+
+ let restrict_through_an_index () =
+ let scanned = ref false and looked = ref [] in
+ let cursor tuples = Kernel.Generator.cursor_of (fun ~yield -> List.iter yield tuples; Ok ()) in
+ let schema domain = {Protocols.Schematics.domain; provenance= []} in
+ let relation =
+ Kernel.Prototype.mixture
+ Protocols.
+ [ Relation.make
+ object
+ method contains _ = Ok false
+
+ method modes =
+ Ok Concepts.[Mode.mode [] Cardinality.Finite; Mode.mode ["age"] Cardinality.Finite]
+ end;
+ Enumerable.make
+ object
+ method enumerate =
+ scanned := true;
+ Ok (cursor staff)
+ end;
+ Indexed.make
+ object
+ method indexes = ["age"]
+
+ method lookup attribute value =
+ looked := attribute :: !looked;
+ Ok
+ (cursor
+ (List.filter
+ (fun tuple ->
+ BatMap.String.find_opt attribute tuple.Concepts.Tuple.attributes
+ |> Option.fold ~none:false ~some:(Concepts.Value.equal value) )
+ staff ) )
+ end;
+ Schematics.make
+ object
+ method describe () =
+ Ok
+ (Schematics.Relation
+ (BatMap.String.of_list ["name", schema "string"; "age", schema "integer"]) )
+ end ]
+ in
+ let found =
+ F.(
+ execute
+ (Where
+ ( Base relation,
+ BatMap.String.of_list
+ ["age", Concepts.Value.Integer 42; "name", Concepts.Value.String "Alaric"] ) ) )
+ |> Utilities.Result.(fun result -> result |>> drain)
+ |> Helpers.condition_as_failure
+ in
+ check
+ (list (list (pair string Helpers.value)))
+ "the one tuple agreeing with every bound attribute"
+ [["age", Concepts.Value.Integer 42; "name", Concepts.Value.String "Alaric"]]
+ (bindings found);
+ check bool "the relation was never scanned" false !scanned;
+ check (list string) "its index was looked up once" ["age"] !looked
+
+ let restrict_a_stored_relation conn =
+ let run term f =
+ begin
+ let open Utilities.Result in
+ let* relation = H.relation conn ["name"; "age"] staff in
+ let* result = eval (directory ["employee", relation]) term in
+ f result
+ end
+ |> Helpers.condition_as_failure
+ in
+ let asking term f =
+ run term (fun result ->
+ Protocols.Handle.releasing result (fun () ->
+ Result.bind (Protocols.Relation.require result) f ) )
+ in
+ check
+ (list (list (pair string Helpers.value)))
+ "every tuple holding the bound value"
+ [ ["age", Concepts.Value.Integer 42; "name", Concepts.Value.String "Alaric"];
+ ["age", Concepts.Value.Integer 42; "name", Concepts.Value.String "Gunther"] ]
+ (bindings (run (F.Where (employees, aged 42)) drain));
+ check
+ (list (list (pair string Helpers.value)))
+ "a restriction reaches through a projection"
+ [["name", Concepts.Value.String "Alaric"]]
+ (bindings (run (F.Where (names, called "Alaric")) drain));
+ check bool "a tuple agreeing with the binding is held" true
+ (asking
+ (F.Where (employees, aged 42))
+ (fun r -> Protocols.Relation.contains r (employee "Gunther" 42)) );
+ check bool "a tuple disagreeing with it is not" false
+ (asking
+ (F.Where (employees, aged 42))
+ (fun r -> Protocols.Relation.contains r (employee "Brunhild" 30)) );
+ check bool "through the index it ends with nothing bound" true
+ (asking
+ (F.Where (employees, aged 42))
+ (fun r ->
+ Protocols.Relation.modes r
+ |> Result.map (fun modes -> Concepts.Mode.exhaustible modes BatSet.String.empty) ) )
+
+ let restrict_inside_a_stored_program conn =
+ let inner = F.Project (F.Where (employees, aged 42), BatFingerTree.singleton "name") in
+ let pushed, found =
+ begin
+ let open Utilities.Result in
+ let* relation = H.relation conn ["name"; "age"] staff in
+ let* stored = store conn inner in
+ let* root = namespace ["employee", relation; "stored", stored] in
+ let* plan =
+ F.instantiate root (F.Where (F.Base Kernel.Path.("stored" @/ this), called "Gunther"))
+ in
+ let pushed =
+ match plan with F.Project (F.Where (F.Where (F.Base _, _), _), _) -> true | _ -> false
+ in
+ let* result = F.execute plan in
+ let* found = drain result in
+ Ok (pushed, found)
+ end
+ |> Helpers.condition_as_failure
+ in
+ check string "a restriction survives its encoding" (F.encode inner)
+ (F.encode (Helpers.condition_as_failure (F.decode (F.encode inner))));
+ check bool "the restriction moved below the stored projection" true pushed;
+ check
+ (list (list (pair string Helpers.value)))
+ "and both restrictions held"
+ [["name", Concepts.Value.String "Gunther"]]
+ (bindings found)
+
+ let refuse_a_restriction_on_a_missing_attribute conn =
+ let refused term =
+ match
+ let open Utilities.Result in
+ let* relation = H.relation conn ["name"; "age"] staff in
+ eval (directory ["employee", relation]) term
+ with
+ | Error condition ->
+ BatString.starts_with (Concepts.Condition.to_string_hum condition) "unknown-attribute"
+ | Ok result -> Protocols.Handle.release result; false
+ in
+ check bool "an attribute the relation lacks" true
+ (refused (F.Where (employees, BatMap.String.singleton "salary" (Concepts.Value.Integer 1))));
+ check bool "an attribute projected away" true (refused (F.Where (names, aged 42)))
+
let counter ?(produced = ref 0) ?(closed = ref false) () =
let description =
BatMap.String.singleton "value" {Protocols.Schematics.domain= "integer"; provenance= []}
@@ -294,6 +445,13 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
(H.with_connection refuse_a_program_that_reads_itself "fol-test");
test_case "a-projection-keeps-the-modes-it-can-bind" `Quick
(H.with_connection a_projection_keeps_the_modes_it_can_bind "fol-test");
+ test_case "restrict-through-an-index" `Quick restrict_through_an_index;
+ test_case "restrict-a-stored-relation" `Quick
+ (H.with_connection restrict_a_stored_relation "fol-test");
+ test_case "restrict-inside-a-stored-program" `Quick
+ (H.with_connection restrict_inside_a_stored_program "fol-test");
+ test_case "refuse-a-restriction-on-a-missing-attribute" `Quick
+ (H.with_connection refuse_a_restriction_on_a_missing_attribute "fol-test");
test_case "pull-one-tuple-at-a-time" `Quick pull_one_tuple_at_a_time;
test_case "an-endless-projection-cannot-decide" `Quick an_endless_projection_cannot_decide;
test_case "a-result-owns-the-relations-of-its-plan" `Quick
diff --git a/test/unit/kernel/Branch.ml b/test/unit/kernel/Branch.ml
index a0f201d..10789cd 100644
--- a/test/unit/kernel/Branch.ml
+++ b/test/unit/kernel/Branch.ml
@@ -256,6 +256,23 @@ let a_denial_program_runs_once_per_judgement () =
(K.Scope.publish root ~branch:"master" ~home:library ~denials:["dated", Some dated] []) );
check int "and its program ran once to judge it" 1 !evaluations
+let a_denial_binds_an_attribute () =
+ let root = fresh ["Date"] in
+ let codd =
+ K.EphemeralRelation.of_program title
+ Rnt.Evaluators.FOL.(
+ program
+ (Where (Base (K.Scope.path library "book"), BatMap.String.singleton "title" (s "Codd"))) )
+ in
+ publish root ~denials:["no-codd", Some codd] [];
+ check bool "a book the rule binds is refused" true
+ (Result.is_error
+ (K.Scope.publish root ~branch:"master" ~home:library ["book", Some (books ["Date"; "Codd"])]) );
+ publish root ["book", Some (books ["Date"; "Darwen"])];
+ check (list Helpers.value) "any other book lands"
+ [s "Darwen"; s "Date"]
+ (read root (under master (K.Scope.path library "book")))
+
let suites () =
[ ( "kernel/branch",
[ test_case "reads-as-of-each-state" `Quick reads_as_of_each_state;
@@ -271,4 +288,5 @@ let suites () =
test_case "a-denial-without-end-cannot-be-installed" `Quick
a_denial_without_end_cannot_be_installed;
test_case "a-denial-program-runs-once-per-judgement" `Quick
- a_denial_program_runs_once_per_judgement ] ) ]
+ a_denial_program_runs_once_per_judgement;
+ test_case "a-denial-binds-an-attribute" `Quick a_denial_binds_an_attribute ] ) ]
diff --git a/test/unit/kernel/SubstantialRelation.ml b/test/unit/kernel/SubstantialRelation.ml
index 6000e52..b4e90dc 100644
--- a/test/unit/kernel/SubstantialRelation.ml
+++ b/test/unit/kernel/SubstantialRelation.ml
@@ -49,10 +49,71 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
Concepts.Hash.hash_equals (Concepts.Tuple.hash tuple) (Concepts.Tuple.hash alaric) )
enumerated )
+ let refuse_a_tuple_without_every_attribute conn =
+ let nameless = {alaric with attributes= BatMap.String.remove "name" alaric.attributes} in
+ check bool "storing it fails for the attribute it lacks" true
+ ( match H.relation conn ["name"; "age"] [nameless] with
+ | Error condition ->
+ BatString.starts_with (Concepts.Condition.to_string_hum condition) "missing-attribute"
+ | Ok _ -> false )
+
+ let employee name age =
+ { Concepts.Tuple.type_= "employee";
+ attributes=
+ BatMap.String.empty
+ |> BatMap.String.add "name" (Concepts.Value.String name)
+ |> BatMap.String.add "age" (Concepts.Value.Integer age) }
+
+ let look_up_by_one_attribute conn =
+ let names relation attribute value =
+ let open Utilities.Result in
+ let* indexed = Protocols.Indexed.require relation in
+ let* cursor = Protocols.Indexed.lookup indexed attribute value in
+ let* found = Protocols.Cursor.consuming cursor (fun scan -> Protocols.Cursor.drain scan ()) in
+ Ok
+ ( BatFingerTree.to_list found
+ |> List.map (fun tuple -> BatMap.String.find "name" tuple.Concepts.Tuple.attributes)
+ |> List.sort compare )
+ in
+ let indexes, aged, named, unaged, prefixed, unindexed =
+ begin
+ let open Utilities.Result in
+ let* relation =
+ H.relation conn ["name"; "age"]
+ [employee "Alaric" 42; employee "Brunhild" 30; employee "Gunther" 42]
+ in
+ let* indexed = Protocols.Indexed.require relation in
+ let* aged = names relation "age" (Concepts.Value.Integer 42) in
+ let* named = names relation "name" (Concepts.Value.String "Brunhild") in
+ let* unaged = names relation "age" (Concepts.Value.Integer 4) in
+ let* prefixed = names relation "name" (Concepts.Value.String "Al") in
+ let unindexed = names relation "salary" (Concepts.Value.Integer 1) in
+ Ok (Protocols.Indexed.indexes indexed, aged, named, unaged, prefixed, unindexed)
+ end
+ |> Helpers.condition_as_failure
+ in
+ let s v = Concepts.Value.String v in
+ check (list string) "every attribute is indexed" ["age"; "name"] indexes;
+ check (list Helpers.value) "an integer finds every tuple holding it"
+ [s "Alaric"; s "Gunther"]
+ aged;
+ check (list Helpers.value) "a string finds the tuple holding it" [s "Brunhild"] named;
+ check (list Helpers.value) "an integer is not a prefix of a longer one" [] unaged;
+ check (list Helpers.value) "a string is not a prefix of a longer one" [] prefixed;
+ check bool "an attribute without an index is refused" true
+ ( match unindexed with
+ | Error condition ->
+ BatString.starts_with (Concepts.Condition.to_string_hum condition) "unindexed-attribute"
+ | Ok _ -> false )
+
let suite =
( "kernel/substantial-relation",
[ test_case "contain-and-enumerate" `Quick
- (H.with_connection contain_and_enumerate "substantial-relation-test") ] )
+ (H.with_connection contain_and_enumerate "substantial-relation-test");
+ test_case "refuse-a-tuple-without-every-attribute" `Quick
+ (H.with_connection refuse_a_tuple_without_every_attribute "substantial-relation-test");
+ test_case "look-up-by-one-attribute" `Quick
+ (H.with_connection look_up_by_one_attribute "substantial-relation-test") ] )
end
module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator)
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 21:43:45 +0000