admission protocol for multigroup denial checks

5 files changed, 35 insertions, 3 deletions

diff --git a/lib/protocols/Admission.ml b/lib/protocols/Admission.ml
new file mode 100644
index 0000000..5a20105
--- /dev/null
+++ b/lib/protocols/Admission.ml
@@ -0,0 +1,21 @@
+module Error = struct
+  open Concepts.Condition
+
+  let not_admitting () =
+    condition "not-admitting" "A handle was expected to carry the admission protocol and did not"
+      empty
+end
+
+type violations = (string * Concepts.Tuple.t list) list
+
+class type implementation = object
+  method check : (violations, Concepts.Condition.condition) result
+end
+
+type Handle.protocol += Admission of implementation
+type t = implementation
+
+let make impl = Admission (impl :> implementation)
+let from handle = Handle.into handle (function Admission impl -> Some impl | _ -> None)
+let require handle = from handle |> Option.to_result ~none:(Error.not_admitting ())
+let check i = Handle.invoke i (fun o -> o#check)
diff --git a/lib/protocols/Admission.mli b/lib/protocols/Admission.mli
new file mode 100644
index 0000000..235eae7
--- /dev/null
+++ b/lib/protocols/Admission.mli
@@ -0,0 +1,11 @@
+type t
+type violations = (string * Concepts.Tuple.t list) list
+
+class type implementation = object
+  method check : (violations, Concepts.Condition.condition) result
+end
+
+val make : #implementation -> Handle.protocol
+val from : Handle.t -> t Handle.interface option
+val require : Handle.t -> (t Handle.interface, Concepts.Condition.condition) result
+val check : t Handle.interface -> (violations, Concepts.Condition.condition) result
diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml
index cdadd4a..c8480a6 100644
--- a/lib/protocols/Handle.ml
+++ b/lib/protocols/Handle.ml
@@ -47,4 +47,5 @@ let release ({valid; _} as handle) =
   valid := false;
   o#release
 
+let releasing handle f = Fun.protect ~finally:(fun () -> release handle) f
 let require f h = Option.to_result ~none:(Error.unimplemented_protocol (to_string h)) (f h)
diff --git a/lib/protocols/Handle.mli b/lib/protocols/Handle.mli
index a354257..5c74521 100644
--- a/lib/protocols/Handle.mli
+++ b/lib/protocols/Handle.mli
@@ -17,6 +17,7 @@ val invoke : 'a interface -> ('a -> 'b) -> 'b
 val copy : t -> t option
 val equal : t -> t -> bool
 val release : t -> unit
+val releasing : t -> (unit -> 'a) -> 'a
 val hash : t -> Concepts.Hash.hash
 val protocols : t -> protocol list
 val to_string : t -> string
diff --git a/lib/protocols/Relation.ml b/lib/protocols/Relation.ml
index 9a6e739..af1201b 100644
--- a/lib/protocols/Relation.ml
+++ b/lib/protocols/Relation.ml
@@ -31,9 +31,7 @@ let read relation =
   let* heading = heading relation in
   let* enumerable = Enumerable.require relation in
   let* cursor = Enumerable.enumerate enumerable in
-  Fun.protect
-    ~finally:(fun () -> Handle.release cursor)
-    (fun () ->
+  Handle.releasing cursor (fun () ->
       let* scan = Cursor.require cursor in
       let* tuples = Cursor.drain scan () in
       Ok (heading, BatFingerTree.to_list tuples) )