diff options
Diffstat (limited to 'test/unit/evaluators/FOL.ml')
| -rw-r--r-- | test/unit/evaluators/FOL.ml | 164 |
1 files changed, 161 insertions, 3 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 |