share the condition check and employee fixture across tests

4 files changed, 29 insertions, 80 deletions

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",