aboutsummaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/abstract/Storage.ml6
-rw-r--r--lib/backend/storage/LMDB.ml18
-rw-r--r--lib/concepts/Cardinality.ml20
-rw-r--r--lib/concepts/Cardinality.mli9
-rw-r--r--lib/concepts/Mode.ml30
-rw-r--r--lib/concepts/Mode.mli27
-rw-r--r--lib/kernel/EphemeralRelation.ml73
-rw-r--r--lib/kernel/EphemeralRelation.mli36
-rw-r--r--lib/kernel/Generator.ml19
-rw-r--r--lib/kernel/Lifecycle.ml15
-rw-r--r--lib/kernel/Lifecycle.mli10
-rw-r--r--lib/kernel/Storage.ml7
-rw-r--r--lib/kernel/Storage.mli1
-rw-r--r--lib/kernel/SubstantialRelation.ml59
-rw-r--r--lib/kernel/SubstantialRelation.mli8
-rw-r--r--lib/protocols/Cursor.ml7
-rw-r--r--lib/protocols/Cursor.mli5
-rw-r--r--lib/protocols/Generative.ml81
-rw-r--r--lib/protocols/Generative.mli35
-rw-r--r--lib/protocols/Handle.ml1
-rw-r--r--lib/protocols/Handle.mli1
-rw-r--r--lib/protocols/Schematics.ml4
-rw-r--r--lib/protocols/Schematics.mli12
23 files changed, 434 insertions, 50 deletions
diff --git a/lib/abstract/Storage.ml b/lib/abstract/Storage.ml
index e921be9..afd1a3c 100644
--- a/lib/abstract/Storage.ml
+++ b/lib/abstract/Storage.ml
@@ -6,9 +6,15 @@ module type STORAGE = sig
val connect : Concepts.Configuration.term -> (connection, Concepts.Condition.condition) result
+ (** close `connection`, after which none of its transactions may be used *)
+ val disconnect : connection -> unit
+
(** begin a transaction within `connection` *)
val start : connection -> (transaction, Concepts.Condition.condition) result
+ (** begin a read-only transaction, which may be held alongside others *)
+ val start_read : connection -> (transaction, Concepts.Condition.condition) result
+
(** `commit` the current transaction *)
val commit : transaction -> (unit, Concepts.Condition.condition) result
diff --git a/lib/backend/storage/LMDB.ml b/lib/backend/storage/LMDB.ml
index be23128..e364b6a 100644
--- a/lib/backend/storage/LMDB.ml
+++ b/lib/backend/storage/LMDB.ml
@@ -118,6 +118,11 @@ module C = struct
module Errors = struct
let mdb_notfound = -30798
end
+
+ module Flags = struct
+ let mdb_notls = Unsigned.UInt.of_int 0x200000
+ let mdb_rdonly = Unsigned.UInt.of_int 0x20000
+ end
end
module Error = struct
@@ -147,7 +152,9 @@ let connect (c : Concepts.Configuration.term) =
let* path, mode = parse c in
begin
let* env = C.mdb_env_create' () in
- match C.mdb_env_open env path Unsigned.UInt.zero (PosixTypes.Mode.of_int mode) with
+ (* NOTLS ties readers to transactions rather than threads, so one
+ thread can hold several read transactions (nested cursors). *)
+ match C.mdb_env_open env path C.Flags.mdb_notls (PosixTypes.Mode.of_int mode) with
| Error x -> C.mdb_env_close env; Error x
| Ok () ->
let* tx = C.mdb_txn_begin' env C.null_txn Unsigned.UInt.zero in
@@ -160,11 +167,16 @@ let connect (c : Concepts.Configuration.term) =
Concepts.Condition.(
complement ("path" |=| Concepts.Value.String path & "mode" |=| Concepts.Value.Integer mode) )
-let start ({env; dbi} : connection) =
- C.mdb_txn_begin' env C.null_txn Unsigned.UInt.zero
+let disconnect ({env; _} : connection) = C.mdb_env_close env
+
+let begin_with flags ({env; dbi} : connection) =
+ C.mdb_txn_begin' env C.null_txn flags
|> Result.map (fun tx -> {tx; dbi; active = true;})
|> Result.map_error Error.lmdb_error
+let start = begin_with Unsigned.UInt.zero
+let start_read = begin_with C.Flags.mdb_rdonly
+
let commit transaction =
if not transaction.active then Error Error.closed_transaction
else begin
diff --git a/lib/concepts/Cardinality.ml b/lib/concepts/Cardinality.ml
new file mode 100644
index 0000000..d878aa9
--- /dev/null
+++ b/lib/concepts/Cardinality.ml
@@ -0,0 +1,20 @@
+type t = Empty | Bounded of int | Finite | Countable
+
+let bounded n = if n <= 0 then Empty else Bounded n
+let rank = function Empty -> 0 | Bounded _ -> 1 | Finite -> 2 | Countable -> 3
+
+let compare a b =
+ match a, b with
+ | Bounded n, Bounded m -> Utilities.Ordering.of_int (Int.compare n m)
+ | _ -> Utilities.Ordering.of_int (Int.compare (rank a) (rank b))
+
+let equal a b = compare a b = Utilities.Ordering.Equal
+let leq a b = compare a b <> Utilities.Ordering.Greater
+let meet a b = if leq a b then a else b
+let exhaustible = function Countable -> false | Empty | Bounded _ | Finite -> true
+
+let to_string = function
+ | Empty -> "empty"
+ | Bounded n -> Printf.sprintf "bounded(%d)" n
+ | Finite -> "finite"
+ | Countable -> "countable"
diff --git a/lib/concepts/Cardinality.mli b/lib/concepts/Cardinality.mli
new file mode 100644
index 0000000..d345bce
--- /dev/null
+++ b/lib/concepts/Cardinality.mli
@@ -0,0 +1,9 @@
+type t = Empty | Bounded of int | Finite | Countable
+
+val bounded : int -> t
+val compare : t -> t -> Utilities.Ordering.t
+val equal : t -> t -> bool
+val leq : t -> t -> bool
+val meet : t -> t -> t
+val exhaustible : t -> bool
+val to_string : t -> string
diff --git a/lib/concepts/Mode.ml b/lib/concepts/Mode.ml
new file mode 100644
index 0000000..b7aa814
--- /dev/null
+++ b/lib/concepts/Mode.ml
@@ -0,0 +1,30 @@
+type attribute = string
+type attributes = BatSet.String.t
+type affordance = Decides | Generates of Cardinality.t
+type mode = {bound: attributes; affords: affordance}
+type t = mode list
+
+let attributes_of_list = BatSet.String.of_list
+let attributes_of_map map = BatMap.String.keys map |> BatSet.String.of_enum
+let decides_when bound = {bound= attributes_of_list bound; affords= Decides}
+let enumerable cardinality = {bound= BatSet.String.empty; affords= Generates cardinality}
+let of_list modes = modes
+
+let generation declaration bound =
+ List.fold_left
+ (fun tightest {bound= declared; affords} ->
+ match affords with
+ | Generates cardinality when BatSet.String.subset declared bound ->
+ Some (Option.fold ~none:cardinality ~some:(Cardinality.meet cardinality) tightest)
+ | Generates _ | Decides -> tightest )
+ None declaration
+
+let exhaustible declaration bound =
+ Option.fold ~none:false ~some:Cardinality.exhaustible (generation declaration bound)
+
+let decision declaration bound =
+ exhaustible declaration bound
+ || List.exists
+ (fun {bound= declared; affords} ->
+ match affords with Decides -> BatSet.String.equal declared bound | Generates _ -> false )
+ declaration
diff --git a/lib/concepts/Mode.mli b/lib/concepts/Mode.mli
new file mode 100644
index 0000000..6a906d1
--- /dev/null
+++ b/lib/concepts/Mode.mli
@@ -0,0 +1,27 @@
+type attribute = string
+type attributes = BatSet.String.t
+
+(** what asking a relation under a given set of bound attributes
+ affords. The answer is to whether anything satisfies the binding,
+ or the bindings of the attributes left free together with the
+ class of what is produced. *)
+type affordance = Decides | Generates of Cardinality.t
+
+type mode = {bound: attributes; affords: affordance}
+type t
+
+val attributes_of_list : attribute list -> attributes
+val attributes_of_map : 'a BatMap.String.t -> attributes
+val decides_when : attribute list -> mode
+val enumerable : Cardinality.t -> mode
+val of_list : mode list -> t
+
+(** the tightest class declared for generating under [bound]. A mode
+ declared for fewer bound attributes applies to more, since the
+ attributes left free are then fewer and no more numerous. *)
+val generation : t -> attributes -> Cardinality.t option
+
+val exhaustible : t -> attributes -> bool
+
+(** declared outright, or implied by a generation that can be exhausted. *)
+val decision : t -> attributes -> bool
diff --git a/lib/kernel/EphemeralRelation.ml b/lib/kernel/EphemeralRelation.ml
new file mode 100644
index 0000000..b403e13
--- /dev/null
+++ b/lib/kernel/EphemeralRelation.ml
@@ -0,0 +1,73 @@
+module type DERIVATION = sig
+ type plan
+
+ val identity : plan -> Concepts.Hash.hash
+
+ val describe :
+ plan -> (Protocols.Schematics.relation_description, Concepts.Condition.condition) result
+
+ val modes : plan -> (Concepts.Mode.t, Concepts.Condition.condition) result
+
+ val generate :
+ plan ->
+ Protocols.Generative.binding ->
+ (Protocols.Handle.t, Concepts.Condition.condition) result
+end
+
+module Make (D : DERIVATION) = struct
+ let pinned_tag = "rnt/pinned/1"
+
+ let identity ?pinned plan =
+ let derivation = D.identity plan in
+ match pinned with
+ | None -> derivation
+ | Some branch ->
+ pinned_tag ^ Concepts.Hash.to_raw_string derivation ^ Concepts.Hash.to_raw_string branch
+ |> Bytes.of_string
+ |> Concepts.Hash.hash_of_bytes
+
+ class ephemeral (plan : D.plan) address declaration description edges =
+ object (self)
+ inherit Lifecycle.counted
+ inherit Protocols.Generative.membership
+ val heading = Concepts.Mode.attributes_of_map description
+ method destroy = List.iter Protocols.Handle.release edges
+ method predicate = Ok None
+ method local_constraints = Ok None
+ method modes = Ok declaration
+
+ (* A cursor holds a reference to its relation, so the edges it reads
+ outlive a release of the relation that produced it. *)
+ method generate binding =
+ D.generate plan binding
+ |> Result.map (fun cursor ->
+ new Lifecycle.retaining cursor (self :> Lifecycle.lifecycle) |> Protocols.Handle.make )
+
+ method enumerate = self#generate Protocols.Generative.nothing
+ method describe () = Ok (Protocols.Schematics.Relation description)
+
+ method protocols : Protocols.Handle.protocol list =
+ let carried =
+ [ Protocols.Relation.make self;
+ Protocols.Schematics.make self;
+ Protocols.Generative.make self ]
+ in
+ if Concepts.Mode.exhaustible declaration BatSet.String.empty then
+ Protocols.Enumerable.make self :: carried
+ else carried
+
+ method hash : Concepts.Hash.hash = address
+ end
+
+ let derive ?pinned ?(edges = []) plan =
+ let open Utilities.Result in
+ let derived =
+ let* declaration = D.modes plan in
+ let* description = D.describe plan in
+ Ok
+ ( new ephemeral plan (identity ?pinned plan) declaration description edges
+ |> Protocols.Handle.make )
+ in
+ Result.iter_error (fun _ -> List.iter Protocols.Handle.release edges) derived;
+ derived
+end
diff --git a/lib/kernel/EphemeralRelation.mli b/lib/kernel/EphemeralRelation.mli
new file mode 100644
index 0000000..d082394
--- /dev/null
+++ b/lib/kernel/EphemeralRelation.mli
@@ -0,0 +1,36 @@
+module type DERIVATION = sig
+ type plan
+
+ (** the hash of the plan, taken over the branch-local names of its
+ inputs rather than over their content addresses. The idea is to
+ have the same expression denote one object on every branch and
+ at every point in time. *)
+ val identity : plan -> Concepts.Hash.hash
+
+ val describe :
+ plan -> (Protocols.Schematics.relation_description, Concepts.Condition.condition) result
+
+ val modes : plan -> (Concepts.Mode.t, Concepts.Condition.condition) result
+
+ val generate :
+ plan ->
+ Protocols.Generative.binding ->
+ (Protocols.Handle.t, Concepts.Condition.condition) result
+end
+
+module Make (D : DERIVATION) : sig
+ (** unpinned, the identity of the derivation itself; pinned to a
+ branch commit, the identity of that derivation against one
+ reconstructible state, which is the only form for which equal
+ identity implies equal extension. *)
+ val identity : ?pinned:Concepts.Hash.hash -> D.plan -> Concepts.Hash.hash
+
+ (** edges are the handles the derivation reads, which are released
+ when the relation is also. Rejection of a derivation surfaces
+ here instead of when a cursor is being drained. *)
+ val derive :
+ ?pinned:Concepts.Hash.hash ->
+ ?edges:Protocols.Handle.t list ->
+ D.plan ->
+ (Protocols.Handle.t, Concepts.Condition.condition) result
+end
diff --git a/lib/kernel/Generator.ml b/lib/kernel/Generator.ml
index 10f6865..204699f 100644
--- a/lib/kernel/Generator.ml
+++ b/lib/kernel/Generator.ml
@@ -10,7 +10,7 @@ let start produce =
let resume k = Effect.Deep.continue k ()
-class producer_cursor produce on_release =
+class producer_cursor produce finally =
object (self)
inherit Lifecycle.null
inherit Identity.of_id
@@ -19,13 +19,18 @@ class producer_cursor produce on_release =
val mutable state : [`Fresh | `Live of (unit, step) Effect.Deep.continuation | `Done] = `Fresh
method protocols : Protocols.Handle.protocol list = Protocols.[Cursor.make self]
+
+ method private finish =
+ state <- `Done;
+ Option.iter (fun f -> f ()) finally
+
method private step : (Concepts.Tuple.t option, Concepts.Condition.condition) result =
let settle = function
| Element (tuple, k) ->
state <- `Live k;
Ok (Some tuple)
| Finished r ->
- state <- `Done;
+ self#finish;
Result.map (fun () -> None) r
in
match state with
@@ -47,12 +52,8 @@ class producer_cursor produce on_release =
Ok Protocols.Cursor.{tuples= BatFingerTree.empty; exhausted= (state = `Done)}
else fill 0 BatFingerTree.empty
- method! release =
- (match state with
- | `Live _ -> Option.iter (fun f -> f ()) on_release
- | `Fresh | `Done -> ());
- state <- `Done
+ method! release = match state with `Fresh | `Live _ -> self#finish | `Done -> ()
end
-let cursor_of ?on_release produce =
- new producer_cursor produce on_release |> Protocols.Handle.make
+let cursor_of ?finally produce =
+ new producer_cursor produce finally |> Protocols.Handle.make
diff --git a/lib/kernel/Lifecycle.ml b/lib/kernel/Lifecycle.ml
index ff67ecf..772cb6e 100644
--- a/lib/kernel/Lifecycle.ml
+++ b/lib/kernel/Lifecycle.ml
@@ -23,7 +23,18 @@ class virtual counted = object (self)
true
method release =
- Atomic.decr references;
- if Atomic.get references <= 0 then
+ if Atomic.fetch_and_add references (-1) = 1 then
self#destroy
end
+
+class retaining inner (owner : lifecycle) = object
+ inherit counted
+ initializer ignore owner#reference
+
+ method destroy =
+ Protocols.Handle.release inner;
+ owner#release
+
+ method hash = Protocols.Handle.hash inner
+ method protocols = Protocols.Handle.protocols inner
+end
diff --git a/lib/kernel/Lifecycle.mli b/lib/kernel/Lifecycle.mli
index f110768..fa3abee 100644
--- a/lib/kernel/Lifecycle.mli
+++ b/lib/kernel/Lifecycle.mli
@@ -10,3 +10,13 @@ end
class null : lifecycle
class virtual counted : controlled_lifecycle
+
+(** stands for [inner], carrying what it carries, while holding a
+ reference to [owner], so what [inner] reads outlives a release of
+ the object that produced it. *)
+class retaining : Protocols.Handle.t -> lifecycle -> object
+ inherit lifecycle
+ method destroy : unit
+ method hash : Concepts.Hash.hash
+ method protocols : Protocols.Handle.protocol list
+end
diff --git a/lib/kernel/Storage.ml b/lib/kernel/Storage.ml
index 665b1a7..d50735c 100644
--- a/lib/kernel/Storage.ml
+++ b/lib/kernel/Storage.ml
@@ -36,11 +36,14 @@ module Make (S : Abstract.Storage.STORAGE) = struct
let _ = S.abort tx in
Error condition
- let with_transaction connection body =
+ let within start connection body =
let open Utilities.Result in
- let* tx = S.start connection in
+ let* tx = start connection in
body tx |> finish tx
+ let with_transaction connection = within S.start connection
+ let with_read connection = within S.start_read connection
+
let store_blob tx blob =
let open Utilities.Result in
let address = Concepts.Hash.hash_of_blob blob in
diff --git a/lib/kernel/Storage.mli b/lib/kernel/Storage.mli
index 3c036ca..53bb666 100644
--- a/lib/kernel/Storage.mli
+++ b/lib/kernel/Storage.mli
@@ -12,6 +12,7 @@ module Make : functor (S : Abstract.Storage.STORAGE) -> sig
val finish : S.transaction -> ('a, Concepts.Condition.condition) result -> ('a, Concepts.Condition.condition) result
val with_transaction : S.connection -> (S.transaction -> ('a, Concepts.Condition.condition) result) -> ('a, Concepts.Condition.condition) result
+ val with_read : S.connection -> (S.transaction -> ('a, Concepts.Condition.condition) result) -> ('a, Concepts.Condition.condition) result
val store_blob : S.transaction -> Concepts.Blob.t -> (Concepts.Hash.hash, Concepts.Condition.condition) result
val get_req: S.transaction -> S.address -> (Concepts.Blob.t, Concepts.Condition.condition) result
end
diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml
index 136c146..52ce83c 100644
--- a/lib/kernel/SubstantialRelation.ml
+++ b/lib/kernel/SubstantialRelation.ml
@@ -120,30 +120,34 @@ module Make (S : Abstract.Storage.STORAGE) = struct
kvs
|> List.map (fun (name, domain) ->
Concepts.Encoding.Bencode.as_string domain
- |> Result.map (fun domain -> (name, domain)))
+ |> Result.map (fun domain ->
+ (name, {Protocols.Schematics.domain; provenance= []}) ) )
|> Utilities.List.sequence
- |> Result.map (fun kvs ->
- List.fold_left
- (fun acc (name, domain) -> BatMap.String.add name domain acc)
- BatMap.String.empty kvs)
+ |> Result.map BatMap.String.of_list
- let enumerate storage relation =
+ let generate storage relation binding =
let open Utilities.Result in
- let* tx = S.start storage in
- let* node = tuple_node tx relation in
- let closed = ref false in
- let close () = if not !closed then begin closed := true; ignore (S.abort tx) end in
+ let* tx = S.start_read storage in
+ let close () = ignore (S.abort tx) in
+ let* node = tuple_node tx relation |> Result.map_error (fun c -> close (); c) in
(* The fold is suspended by [yield], so the tree is walked one node
and one tuple at a time rather than materialized before the
first tuple is produced. *)
let produce ~yield =
- let walked = TupleSet.iter tx (fun _ tuple -> yield tuple) node in
- close ();
- walked
+ TupleSet.iter tx
+ (fun _ tuple -> if Protocols.Generative.satisfies binding tuple then yield tuple)
+ node
in
- Ok (Generator.cursor_of ~on_release:close produce)
+ Ok (Generator.cursor_of ~finally:close produce)
+
+ let enumerate storage relation = generate storage relation Protocols.Generative.nothing
+
+ let modes_of description =
+ Concepts.Mode.of_list
+ [ Concepts.Mode.enumerable Concepts.Cardinality.Finite;
+ {Concepts.Mode.bound= Concepts.Mode.attributes_of_map description; affords= Decides} ]
- class relation storage value =
+ class relation storage value description =
object (self)
inherit Lifecycle.null
@@ -151,18 +155,16 @@ module Make (S : Abstract.Storage.STORAGE) = struct
val storage : S.connection = storage
val relation : t = value
+ val declaration = modes_of description
method predicate = Ok relation.predicate
method local_constraints = Ok relation.local_constraints
(* The protocol takes a tuple, not bytes: encoding is this object's business, and a caller
that had to produce the exact stored bytes would have to know this encoding to do it. *)
method contains (tuple : Concepts.Tuple.t) =
- SI.with_transaction storage (fun tx -> contains_tuple tx relation tuple)
+ SI.with_read storage (fun tx -> contains_tuple tx relation tuple)
- method describe () =
- let open Utilities.Result in
- let* description = SI.with_transaction storage (fun tx -> schema_of tx relation) in
- Ok (Protocols.Schematics.Relation description)
+ method describe () = Ok (Protocols.Schematics.Relation description)
(* A substantial relation is finitely enumerable, so it carries [Enumerable] as well as
[Relation]. A procedural relation would carry only the latter, which is how an evaluator
@@ -171,30 +173,39 @@ module Make (S : Abstract.Storage.STORAGE) = struct
no name resolution, but cancellation should eventually be checked between tuples. *)
method enumerate = enumerate storage relation
+ method modes : (Concepts.Mode.t, Concepts.Condition.condition) result = Ok declaration
+ method generate binding = generate storage relation binding
+
method protocols : Protocols.Handle.protocol list =
[ Protocols.Relation.make self
; Protocols.Enumerable.make self
+ ; Protocols.Generative.make self
; Protocols.Schematics.make self ]
method hash = hash relation
end
+ (* A relation never changes its schema, so it is read once here and
+ the description and modes are served from it on every request. *)
+ let instantiate tx conn relation =
+ schema_of tx relation
+ |> Result.map (fun description -> new relation conn relation description |> Protocols.Handle.make)
+
let make conn ~schematics ?predicate ?local_constraints ?indexes () =
let open Utilities.Result in
SI.with_transaction conn (fun tx ->
let* relation = empty tx ~schematics ?predicate ?local_constraints ?indexes () in
let* _ = store tx relation in
- Ok (new relation conn relation |> Protocols.Handle.make) )
+ instantiate tx conn relation )
let load_value tx addr =
let open Utilities.Result in
let* data = SI.get_req tx (S.Hash addr) in
Representation.of_blob data
- let wrap conn relation =
- new relation conn relation |> Protocols.Handle.make |> Result.ok
+ let wrap conn relation = SI.with_read conn (fun tx -> instantiate tx conn relation)
let load tx conn addr =
- load_value tx addr |> Utilities.Result.fmap (wrap conn)
+ load_value tx addr |> Utilities.Result.fmap (instantiate tx conn)
let assert_tuple tx relation tuple =
let open Utilities.Result in
diff --git a/lib/kernel/SubstantialRelation.mli b/lib/kernel/SubstantialRelation.mli
index 5061e5d..a36c802 100644
--- a/lib/kernel/SubstantialRelation.mli
+++ b/lib/kernel/SubstantialRelation.mli
@@ -47,18 +47,10 @@ module Make (S : Abstract.Storage.STORAGE) : sig
val contains_tuple :
S.transaction -> t -> Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result
- (** decodes the schematics at [schematics relation] -- the body of
- [Protocols.Schematics.describe] for this kind of relation. *)
val schema_of :
S.transaction ->
t ->
(Protocols.Schematics.relation_description, Concepts.Condition.condition) result
- (** a handle carrying [Protocols.Cursor] over every tuple currently
- asserted, decoded via [Concepts.Tuple.Representation.of_blob] --
- the body of [Protocols.Relation.enumerate] for this kind of
- relation. Opens its own storage transaction, held for the
- cursor's whole lifetime rather than just this call -- see
- [Kernel.Generator] and docs/design/evaluator.md, "Shape". *)
val enumerate : S.connection -> t -> (Protocols.Handle.t, Concepts.Condition.condition) result
end
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 =
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 05:22:37 +0000