generative protocol

2 files changed, 60 insertions, 0 deletions

diff --git a/lib/protocols/Generative.ml b/lib/protocols/Generative.ml
new file mode 100644
index 0000000..065ffcb
--- /dev/null
+++ b/lib/protocols/Generative.ml
@@ -0,0 +1,36 @@
+module Error = struct
+  open Concepts.Condition
+
+  let not_generative () =
+    condition "not-generative"
+      "A relation was used where the expression must produce members under a binding, but it \
+       declares no modes. A relation that cannot be asked this way can still be reached through \
+       another access path."
+      empty
+end
+
+type binding = Concepts.Value.value BatMap.String.t
+
+class type implementation = object
+  method modes : (Concepts.Mode.t, Concepts.Condition.condition) result
+  method generate : binding -> (Handle.t, Concepts.Condition.condition) result
+end
+
+type Handle.protocol += Generative of implementation
+type t = implementation
+
+let make impl = Generative (impl :> implementation)
+let from handle = Handle.into handle (function Generative impl -> Some impl | _ -> None)
+let require handle = from handle |> Option.to_result ~none:(Error.not_generative ())
+let modes i = Handle.invoke i (fun o -> o#modes)
+let generate i binding = Handle.invoke i (fun o -> o#generate binding)
+let nothing = BatMap.String.empty
+let bound binding = BatMap.String.keys binding |> BatSet.String.of_enum
+
+let satisfies binding tuple =
+  BatMap.String.for_all
+    (fun attribute value ->
+      match BatMap.String.find_opt attribute tuple.Concepts.Tuple.attributes with
+      | Some found -> Concepts.Value.equal found value
+      | None -> false )
+    binding
diff --git a/lib/protocols/Generative.mli b/lib/protocols/Generative.mli
new file mode 100644
index 0000000..14e2c13
--- /dev/null
+++ b/lib/protocols/Generative.mli
@@ -0,0 +1,24 @@
+type t
+
+(** values fixed for some of a relation's attributes, the attributes
+    absent from it being the ones left free. *)
+type binding = Concepts.Value.value BatMap.String.t
+
+class type implementation = object
+  method modes : (Concepts.Mode.t, Concepts.Condition.condition) result
+  method generate : binding -> (Handle.t, 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 modes : t Handle.interface -> (Concepts.Mode.t, Concepts.Condition.condition) result
+
+(** a handle carrying a cursor over the members agreeing with the
+    binding and under the empty binding this is enumeration, so a
+    relation carrying enumerable answers the same members here. *)
+val generate : t Handle.interface -> binding -> (Handle.t, Concepts.Condition.condition) result
+
+val nothing : binding
+val bound : binding -> Concepts.Mode.attributes
+val satisfies : binding -> Concepts.Tuple.t -> bool