update tests and add beam tests

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