diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/protocols/Generative.ml | 51 | ||||
| -rw-r--r-- | lib/protocols/Generative.mli | 13 |
2 files changed, 60 insertions, 4 deletions
diff --git a/lib/protocols/Generative.ml b/lib/protocols/Generative.ml index 065ffcb..bd89e21 100644 --- a/lib/protocols/Generative.ml +++ b/lib/protocols/Generative.ml @@ -7,6 +7,18 @@ module Error = struct declares no modes. A relation that cannot be asked this way can still be reached through \ another access path." empty + + let attributes bound = Concepts.Value.String (String.concat ", " (BatSet.String.elements bound)) + + let ungenerable bound = + condition "ungenerable-binding" + "The relation declares no mode that generates under the attributes bound." + ("bound" |=| attributes bound) + + let undecidable bound = + condition "undecidable-membership" + "The relation declares no mode that decides membership under the attributes of the tuple." + ("bound" |=| attributes bound) end type binding = Concepts.Value.value BatMap.String.t @@ -22,10 +34,17 @@ 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 bound = Concepts.Mode.attributes_of_map +let modes i = Handle.invoke i (fun o -> o#modes) + +let generate i binding = + Handle.invoke i (fun o -> + let open Utilities.Result in + let bound = bound binding in + let* declaration = o#modes in + if Option.is_some (Concepts.Mode.generation declaration bound) then o#generate binding + else Error (Error.ungenerable bound) ) let satisfies binding tuple = BatMap.String.for_all @@ -34,3 +53,29 @@ let satisfies binding tuple = | Some found -> Concepts.Value.equal found value | None -> false ) binding + +class virtual membership = + object (self) + val virtual heading : Concepts.Mode.attributes + method virtual modes : (Concepts.Mode.t, Concepts.Condition.condition) result + method virtual generate : binding -> (Handle.t, Concepts.Condition.condition) result + + method contains (tuple : Concepts.Tuple.t) = + let open Utilities.Result in + let binding = tuple.Concepts.Tuple.attributes in + let bound = bound binding in + if not (BatSet.String.equal heading bound) then Ok false + else + let* declaration = self#modes in + let* () = + if Concepts.Mode.decision declaration bound then Ok () else Error (Error.undecidable bound) + in + let* cursor = self#generate binding in + let expected = Concepts.Tuple.hash tuple in + Fun.protect + ~finally:(fun () -> Handle.release cursor) + (fun () -> + let* scan = Cursor.require cursor in + Cursor.exists scan (fun member -> + Concepts.Hash.hash_equals (Concepts.Tuple.hash member) expected ) ) + end diff --git a/lib/protocols/Generative.mli b/lib/protocols/Generative.mli index 14e2c13..5ada329 100644 --- a/lib/protocols/Generative.mli +++ b/lib/protocols/Generative.mli @@ -16,9 +16,20 @@ val modes : t Handle.interface -> (Concepts.Mode.t, Concepts.Condition.condition (** 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. *) + relation carrying enumerable answers the same members here. Refused + when no declared mode generates under the attributes bound. *) 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 + +(** membership for a relation with no lookup of its own, asked of the + generator under the binding the tuple fixes. Only a tuple carrying + exactly the [heading] can be a member, and it must match one whole. *) +class virtual membership : object + val virtual heading : Concepts.Mode.attributes + method virtual modes : (Concepts.Mode.t, Concepts.Condition.condition) result + method virtual generate : binding -> (Handle.t, Concepts.Condition.condition) result + method contains : Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result +end |