diff options
Diffstat (limited to 'lib/protocols')
| -rw-r--r-- | lib/protocols/Cursor.ml | 7 | ||||
| -rw-r--r-- | lib/protocols/Cursor.mli | 5 | ||||
| -rw-r--r-- | lib/protocols/Generative.ml | 81 | ||||
| -rw-r--r-- | lib/protocols/Generative.mli | 35 | ||||
| -rw-r--r-- | lib/protocols/Handle.ml | 1 | ||||
| -rw-r--r-- | lib/protocols/Handle.mli | 1 | ||||
| -rw-r--r-- | lib/protocols/Schematics.ml | 4 | ||||
| -rw-r--r-- | lib/protocols/Schematics.mli | 12 |
8 files changed, 144 insertions, 2 deletions
diff --git a/lib/protocols/Cursor.ml b/lib/protocols/Cursor.ml index 36db97d..75dc77d 100644 --- a/lib/protocols/Cursor.ml +++ b/lib/protocols/Cursor.ml @@ -26,6 +26,13 @@ let rec next i = | Some (_, tuple) -> Ok (Some tuple) | None -> if batch.exhausted then Ok None else next i +let rec exists i p = + let open Utilities.Result in + let* found = next i in + match found with + | None -> Ok false + | Some tuple -> if p tuple then Ok true else exists i p + let drain i ?(limit = 256) () = let open Utilities.Result in let rec loop tuples = diff --git a/lib/protocols/Cursor.mli b/lib/protocols/Cursor.mli index 08c7628..c977fec 100644 --- a/lib/protocols/Cursor.mli +++ b/lib/protocols/Cursor.mli @@ -14,6 +14,11 @@ val fetch : t Handle.interface -> int -> (batch, Concepts.Condition.condition) r val next : t Handle.interface -> (Concepts.Tuple.t option, Concepts.Condition.condition) result +val exists : + t Handle.interface -> + (Concepts.Tuple.t -> bool) -> + (bool, Concepts.Condition.condition) result + val drain : t Handle.interface -> ?limit:int -> diff --git a/lib/protocols/Generative.ml b/lib/protocols/Generative.ml new file mode 100644 index 0000000..bd89e21 --- /dev/null +++ b/lib/protocols/Generative.ml @@ -0,0 +1,81 @@ +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 new file mode 100644 index 0000000..5ada329 --- /dev/null +++ b/lib/protocols/Generative.mli @@ -0,0 +1,35 @@ +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 diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml index c45afb0..41c88dd 100644 --- a/lib/protocols/Handle.ml +++ b/lib/protocols/Handle.ml @@ -51,6 +51,7 @@ let equal h1 h2 = Concepts.Hash.hash_equals (object_of h1)#hash (object_of h2)#hash let hash h = (object_of h)#hash +let protocols h = (object_of h)#protocols let to_string h = (object_of h)#to_string diff --git a/lib/protocols/Handle.mli b/lib/protocols/Handle.mli index daee453..40a78ff 100644 --- a/lib/protocols/Handle.mli +++ b/lib/protocols/Handle.mli @@ -24,6 +24,7 @@ val equal : t -> t -> bool val release : t -> unit val hash : t -> Concepts.Hash.hash +val protocols : t -> protocol list val to_string : t -> string val require : (t -> 'a interface option) -> t -> ('a interface, Concepts.Condition.condition) result diff --git a/lib/protocols/Schematics.ml b/lib/protocols/Schematics.ml index d2e50ad..49d8586 100644 --- a/lib/protocols/Schematics.ml +++ b/lib/protocols/Schematics.ml @@ -1,5 +1,7 @@ type multigroup_description = string BatMap.String.t -type relation_description = string BatMap.String.t +type origin = {source: string list; attribute: string} +type attribute_description = {domain: string; provenance: origin list} +type relation_description = attribute_description BatMap.String.t type tuple_description = {relation: relation_description; attributes: string BatMap.String.t} (* TODO: For now the description is completely detached from actual diff --git a/lib/protocols/Schematics.mli b/lib/protocols/Schematics.mli index dc8f320..fe81943 100644 --- a/lib/protocols/Schematics.mli +++ b/lib/protocols/Schematics.mli @@ -4,7 +4,17 @@ type t types and domains. Later figure out a way to represent the links without strings. *) type multigroup_description = string BatMap.String.t -type relation_description = string BatMap.String.t + +(** where an attribute comes from with the path relation and the + attribute it has. *) +type origin = {source: string list; attribute: string} + +(** an attribute of a derived relation may be for several occurrences + at once, for example in a natural join. So its provenance is a + collection. *) +type attribute_description = {domain: string; provenance: origin list} + +type relation_description = attribute_description BatMap.String.t type tuple_description = {relation: relation_description; attributes: string BatMap.String.t} type description = |