From 2c500b00e821c11aa9d5c86985e6adc2b59572a9 Mon Sep 17 00:00:00 2001 From: Marcos Magueta Date: Sat, 31 Oct 2026 03:17:49 -0300 Subject: share the condition check and employee fixture across tests --- test/Helpers.ml | 13 ++++++++++ test/integration/Karuta.ml | 9 ++----- test/unit/evaluators/FOL.ml | 45 +++++++++------------------------ test/unit/kernel/Branch.ml | 9 ++----- test/unit/kernel/EphemeralRelation.ml | 14 +++------- test/unit/kernel/SubstantialRelation.ml | 41 ++++++++---------------------- 6 files changed, 44 insertions(+), 87 deletions(-) diff --git a/test/Helpers.ml b/test/Helpers.ml index ecd3985..5f4478f 100644 --- a/test/Helpers.ml +++ b/test/Helpers.ml @@ -15,6 +15,19 @@ let condition_as_failure = function | Ok r -> r | Error c -> Alcotest.fail (Concepts.Condition.to_string_hum c) +let refuses message name result = + Alcotest.(check bool) + message true + ( match result with + | Error c -> BatString.starts_with (Concepts.Condition.to_string_hum c) name + | Ok _ -> false ) + +let employee name age = + { Concepts.Tuple.type_= "employee"; + attributes= + BatMap.String.of_list ["name", Concepts.Value.String name; "age", Concepts.Value.Integer age] + } + let pp_value ppf v = Format.pp_print_string ppf (Concepts.Value.to_string v) let value = Alcotest.testable pp_value Concepts.Value.equal diff --git a/test/integration/Karuta.ml b/test/integration/Karuta.ml index 2b02e69..f03e25e 100644 --- a/test/integration/Karuta.ml +++ b/test/integration/Karuta.ml @@ -80,11 +80,6 @@ let titles batch = |> List.map (fun {Concepts.Tuple.attributes; _} -> Concepts.Value.to_string (BatMap.String.find "title" attributes) ) -let fails_with name = function - | Ok _ -> fail ("expected " ^ name) - | Error c -> - check bool name true (BatString.starts_with (Concepts.Condition.to_string_hum c) name) - let reads_in_batches node = let batches = begin @@ -164,12 +159,12 @@ let reads_a_program_of_no_path ({root; image} as node) = ["C. J. Date"; "Donald Knuth"; "Harold Abelson"; "Richard Mitchell"] ) let a_missing_function_fails node = - fails_with "beam-failed" + Helpers.refuses "a missing function fails the call" "beam-failed" (Result.bind (run node "library" "nope" ["title"]) (fun relation -> Protocols.Handle.releasing relation (fun () -> Protocols.Relation.read relation) ) ) let a_malformed_term_is_refused {root; _} = - fails_with "malformed-beam-program" + Helpers.refuses "a term that is not a program is refused" "malformed-beam-program" (Kernel.Program.load root ~evaluator:"karuta:beam" ~source:"not a term") let suites () = diff --git a/test/unit/evaluators/FOL.ml b/test/unit/evaluators/FOL.ml index ce8a2cd..1e3c316 100644 --- a/test/unit/evaluators/FOL.ml +++ b/test/unit/evaluators/FOL.ml @@ -9,11 +9,7 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = attributes= BatMap.String.empty |> BatMap.String.add "name" (Concepts.Value.String "Alaric") } - let employee name age = - { Concepts.Tuple.type_= "employee"; - attributes= - BatMap.String.of_list ["name", Concepts.Value.String name; "age", Concepts.Value.Integer age] - } + let employee = Helpers.employee let named name = { Concepts.Tuple.type_= "employee"; @@ -152,7 +148,7 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = (bindings projected) let refuse_a_program_that_reads_itself conn = - let expanded = + Helpers.refuses "the expansion stopped at the cycle" "cyclic-program" begin let open Utilities.Result in let stored_path = Kernel.Path.("stored" @/ this) in @@ -160,12 +156,6 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = let* root = namespace ["stored", stored] in Rnt.Evaluators.FOL.(instantiate root (Base stored_path)) end - in - check bool "the expansion stopped at the cycle" true - ( match expanded with - | Error condition -> - BatString.starts_with (Concepts.Condition.to_string_hum condition) "cyclic-program" - | Ok _ -> false ) let shape modes = List.map @@ -363,19 +353,15 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = (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 + let refused message term = + Helpers.refuses message "unknown-attribute" + (Result.bind + (H.relation conn ["name"; "age"] staff) + (fun relation -> eval (directory ["employee", relation]) term) ) 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))) + refused "an attribute the relation lacks" + (F.Where (employees, BatMap.String.singleton "salary" (Concepts.Value.Integer 1))); + refused "an attribute projected away" (F.Where (names, aged 42)) let counter ?(produced = ref 0) ?(closed = ref false) () = let description = @@ -412,7 +398,8 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = check bool "and was closed with its consumer" true !closed let an_endless_projection_cannot_decide () = - let asked = + Helpers.refuses "it fails as undecidable instead of reading without end" + "undecidable-membership" begin let open Utilities.Result in let* result = values (counter ()) in @@ -421,14 +408,6 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = { Concepts.Tuple.type_= "counter"; attributes= BatMap.String.singleton "value" (Concepts.Value.Integer 7) } end - in - check bool "it fails as undecidable instead of reading without end" true - ( match asked with - | Error condition -> - BatString.starts_with - (Concepts.Condition.to_string_hum condition) - "undecidable-membership" - | Ok _ -> false ) let a_result_owns_the_relations_of_its_plan () = let released = ref false in diff --git a/test/unit/kernel/Branch.ml b/test/unit/kernel/Branch.ml index 10789cd..e229ed7 100644 --- a/test/unit/kernel/Branch.ml +++ b/test/unit/kernel/Branch.ml @@ -238,13 +238,8 @@ let a_denial_without_end_cannot_be_installed () = let root = fresh [] in with_toys root; let endless = K.EphemeralRelation.of_program title (toy_program "toys:toy" "endless") in - match - K.Scope.publish root ~branch:"master" ~home:library ~denials:["endless", Some endless] [] - with - | Ok () -> fail "a denial without end was installed" - | Error condition -> - check bool "the state holding it cannot be judged" true - (BatString.starts_with (C.Condition.to_string_hum condition) "unjudgeable-denial") + Helpers.refuses "the state holding it cannot be judged" "unjudgeable-denial" + (K.Scope.publish root ~branch:"master" ~home:library ~denials:["endless", Some endless] []) let a_denial_program_runs_once_per_judgement () = let root = fresh [] in diff --git a/test/unit/kernel/EphemeralRelation.ml b/test/unit/kernel/EphemeralRelation.ml index 9426b9a..5c85d7f 100644 --- a/test/unit/kernel/EphemeralRelation.ml +++ b/test/unit/kernel/EphemeralRelation.ml @@ -69,16 +69,10 @@ let decides_membership () = check bool "a stranger is refused" false rejects let refuses_to_scan_without_end () = - match Protocols.Relation.require (endless ()) with - | Error condition -> fail (Concepts.Condition.to_string_hum condition) - | Ok relation -> ( - match Protocols.Relation.contains relation (member 9) with - | Error condition -> - check bool "it fails as undecidable instead of scanning" true - (BatString.starts_with - (Concepts.Condition.to_string_hum condition) - "undecidable-membership" ) - | Ok _ -> fail "an endless relation with no test decided membership" ) + Helpers.refuses "it fails as undecidable instead of scanning" "undecidable-membership" + (Result.bind + (Protocols.Relation.require (endless ())) + (fun relation -> Protocols.Relation.contains relation (member 9)) ) let describes_itself () = let described = diff --git a/test/unit/kernel/SubstantialRelation.ml b/test/unit/kernel/SubstantialRelation.ml index 20eb163..c1c4bf5 100644 --- a/test/unit/kernel/SubstantialRelation.ml +++ b/test/unit/kernel/SubstantialRelation.ml @@ -5,12 +5,7 @@ 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 alaric = - { Concepts.Tuple.type_= "employee"; - attributes= - BatMap.String.empty - |> BatMap.String.add "name" (Concepts.Value.String "Alaric") - |> BatMap.String.add "age" (Concepts.Value.Integer 42) } + let alaric = Helpers.employee "Alaric" 42 let contains relation tuple = let open Utilities.Result in @@ -50,23 +45,13 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = enumerated ) let refuse_a_tuple_off_its_heading conn = - let refused name attributes = - match H.relation conn ["name"; "age"] [{alaric with attributes}] with - | Error condition -> BatString.starts_with (Concepts.Condition.to_string_hum condition) name - | Ok _ -> false + let refused message name attributes = + Helpers.refuses message name (H.relation conn ["name"; "age"] [{alaric with attributes}]) in - check bool "a tuple lacking an attribute is refused" true - (refused "missing-attribute" (BatMap.String.remove "name" alaric.attributes)); - check bool "a tuple with an attribute too many is refused" true - (refused "unexpected-attribute" - (BatMap.String.add "salary" (Concepts.Value.Integer 1) alaric.attributes) ) - - 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) } + refused "a tuple lacking an attribute is refused" "missing-attribute" + (BatMap.String.remove "name" alaric.attributes); + refused "a tuple with an attribute too many is refused" "unexpected-attribute" + (BatMap.String.add "salary" (Concepts.Value.Integer 1) alaric.attributes) let look_up_by_one_attribute conn = let names relation attribute value = @@ -84,7 +69,7 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = let open Utilities.Result in let* relation = H.relation conn ["name"; "age"] - [employee "Alaric" 42; employee "Brunhild" 30; employee "Gunther" 42] + Helpers.[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 @@ -102,13 +87,9 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = [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 ) + check (list Helpers.value) "an integer finds nothing under a longer one" [] unaged; + check (list Helpers.value) "a string finds nothing under a longer one" [] prefixed; + Helpers.refuses "an attribute without an index is refused" "unindexed-attribute" unindexed let suite = ( "kernel/substantial-relation", -- cgit v1.2.3