aboutsummaryrefslogtreecommitdiffstats
path: root/test
diff options
context:
space:
mode:
Diffstat (limited to 'test')
-rw-r--r--test/Helpers.ml13
-rw-r--r--test/integration/Karuta.ml9
-rw-r--r--test/unit/evaluators/FOL.ml45
-rw-r--r--test/unit/kernel/Branch.ml9
-rw-r--r--test/unit/kernel/EphemeralRelation.ml14
-rw-r--r--test/unit/kernel/SubstantialRelation.ml41
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",
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 16:12:18 +0000