diff options
Diffstat (limited to 'lib/protocols')
| -rw-r--r-- | lib/protocols/Generative.ml | 82 | ||||
| -rw-r--r-- | lib/protocols/Generative.mli | 35 |
2 files changed, 0 insertions, 117 deletions
diff --git a/lib/protocols/Generative.ml b/lib/protocols/Generative.ml deleted file mode 100644 index 6846e43..0000000 --- a/lib/protocols/Generative.ml +++ /dev/null @@ -1,82 +0,0 @@ -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 - - 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 - -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 nothing = BatMap.String.empty -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 - (fun attribute value -> - match BatMap.String.find_opt attribute tuple.Concepts.Tuple.attributes with - | 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 deleted file mode 100644 index 5ada329..0000000 --- a/lib/protocols/Generative.mli +++ /dev/null @@ -1,35 +0,0 @@ -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. 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 |