From 882511dc8c0abded18ba6abdca64938db2652771 Mon Sep 17 00:00:00 2001 From: Marcos Magueta Date: Wed, 23 Sep 2026 03:32:15 -0300 Subject: lift retaining, membership and mode checks out of ephemeral relation --- lib/concepts/Mode.ml | 1 + lib/concepts/Mode.mli | 1 + lib/kernel/EphemeralRelation.ml | 82 ++++----------------------------------- lib/kernel/Lifecycle.ml | 12 ++++++ lib/kernel/Lifecycle.mli | 10 +++++ lib/kernel/SubstantialRelation.ml | 4 +- lib/protocols/Cursor.ml | 7 ++++ lib/protocols/Cursor.mli | 5 +++ lib/protocols/Generative.ml | 51 ++++++++++++++++++++++-- lib/protocols/Generative.mli | 13 ++++++- lib/protocols/Handle.ml | 1 + lib/protocols/Handle.mli | 1 + 12 files changed, 107 insertions(+), 81 deletions(-) (limited to 'lib') diff --git a/lib/concepts/Mode.ml b/lib/concepts/Mode.ml index 6ac1704..fc3ef84 100644 --- a/lib/concepts/Mode.ml +++ b/lib/concepts/Mode.ml @@ -5,6 +5,7 @@ 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 generates_when bound cardinality = diff --git a/lib/concepts/Mode.mli b/lib/concepts/Mode.mli index 8d84093..018eeb2 100644 --- a/lib/concepts/Mode.mli +++ b/lib/concepts/Mode.mli @@ -11,6 +11,7 @@ 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 generates_when : attribute list -> Cardinality.t -> mode val enumerable : Cardinality.t -> mode diff --git a/lib/kernel/EphemeralRelation.ml b/lib/kernel/EphemeralRelation.ml index 29b15ed..b403e13 100644 --- a/lib/kernel/EphemeralRelation.ml +++ b/lib/kernel/EphemeralRelation.ml @@ -15,22 +15,6 @@ module type DERIVATION = sig end module Make (D : DERIVATION) = struct - module Error = struct - open Concepts.Condition - - let attributes bound = Concepts.Value.String (String.concat ", " (BatSet.String.elements bound)) - - let ungenerable bound = - condition "ungenerable-binding" - "The derivation declares no mode that generates under the attributes bound." - ("bound" |=| attributes bound) - - let undecidable bound = - condition "undecidable-membership" - "The derivation declares no mode that decides membership under the attributes of the tuple." - ("bound" |=| attributes bound) - end - let pinned_tag = "rnt/pinned/1" let identity ?pinned plan = @@ -42,78 +26,26 @@ module Make (D : DERIVATION) = struct |> Bytes.of_string |> Concepts.Hash.hash_of_bytes - (* A cursor holds a reference to its relation, so the edges it reads - outlive a release of the relation that produced it. *) - class retaining scan release_owner = - object (self) - inherit Lifecycle.counted - inherit Identity.of_id - - method destroy = - Protocols.Handle.release (Protocols.Handle.from scan); - release_owner () - - method fetch limit = Protocols.Cursor.fetch scan limit - method protocols : Protocols.Handle.protocol list = [Protocols.Cursor.make self] - end - class ephemeral (plan : D.plan) address declaration description edges = object (self) inherit Lifecycle.counted - val heading = BatMap.String.keys description |> BatSet.String.of_enum + 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 = - let open Utilities.Result in - let bound = Protocols.Generative.bound binding in - let* () = - if Option.is_some (Concepts.Mode.generation declaration bound) then Ok () - else Error (Error.ungenerable bound) - in - let* cursor = D.generate plan binding in - match Protocols.Cursor.require cursor with - | Error c -> - Protocols.Handle.release cursor; - Error c - | Ok scan -> - ignore self#reference; - Ok (new retaining scan (fun () -> self#release) |> Protocols.Handle.make) + 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) - (* Membership of a derived relation is decided by the derivation - and not by a lookup, so it is asked of the generator under the - binding the tuple itself fixes. Only a tuple carrying exactly the - described attributes can be a member, and it must match one whole. *) - method contains (tuple : Concepts.Tuple.t) = - let open Utilities.Result in - let binding = tuple.Concepts.Tuple.attributes in - let bound = Protocols.Generative.bound binding in - if not (BatSet.String.equal heading bound) then Ok false - else - let* () = - if Concepts.Mode.decision declaration bound then Ok () else Error (Error.undecidable bound) - in - let* cursor = D.generate plan binding in - let expected = Concepts.Tuple.hash tuple in - Fun.protect - ~finally:(fun () -> Protocols.Handle.release cursor) - (fun () -> - let* scan = Protocols.Cursor.require cursor in - let rec seek () = - let* found = Protocols.Cursor.next scan in - match found with - | None -> Ok false - | Some member -> - if Concepts.Hash.hash_equals (Concepts.Tuple.hash member) expected then Ok true - else seek () - in - seek () ) - method protocols : Protocols.Handle.protocol list = let carried = [ Protocols.Relation.make self; diff --git a/lib/kernel/Lifecycle.ml b/lib/kernel/Lifecycle.ml index 20282dd..772cb6e 100644 --- a/lib/kernel/Lifecycle.ml +++ b/lib/kernel/Lifecycle.ml @@ -26,3 +26,15 @@ class virtual counted = object (self) 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/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml index 7beb133..b94e2f8 100644 --- a/lib/kernel/SubstantialRelation.ml +++ b/lib/kernel/SubstantialRelation.ml @@ -145,7 +145,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct let modes_of description = Concepts.Mode.of_list [ Concepts.Mode.enumerable Concepts.Cardinality.Finite; - Concepts.Mode.decides_when (BatMap.String.keys description |> BatList.of_enum) ] + {Concepts.Mode.bound= Concepts.Mode.attributes_of_map description; affords= Decides} ] let modes tx relation = schema_of tx relation |> Result.map modes_of @@ -161,7 +161,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct (* 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 () = Ok (Protocols.Schematics.Relation description) 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 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 diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml index cb78cf2..378b8c8 100644 --- a/lib/protocols/Handle.ml +++ b/lib/protocols/Handle.ml @@ -49,6 +49,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 release ({ valid; _ } as handle) = let o = object_of handle in diff --git a/lib/protocols/Handle.mli b/lib/protocols/Handle.mli index 5640b14..c5c0d6a 100644 --- a/lib/protocols/Handle.mli +++ b/lib/protocols/Handle.mli @@ -23,5 +23,6 @@ val equal : t -> t -> bool val release : t -> unit val hash : t -> Concepts.Hash.hash +val protocols : t -> protocol list val require : (t -> 'a interface option) -> t -> ('a interface, Concepts.Condition.condition) result -- cgit v1.2.3