diff options
Diffstat (limited to 'test/unit/evaluators')
| -rw-r--r-- | test/unit/evaluators/FOL.ml | 119 | ||||
| -rw-r--r-- | test/unit/evaluators/Lambda.ml | 139 |
2 files changed, 94 insertions, 164 deletions
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"] |