aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/kernel/EphemeralRelation.ml98
-rw-r--r--lib/kernel/SubstantialRelation.ml1
-rw-r--r--lib/protocols/Generative.ml82
-rw-r--r--lib/protocols/Generative.mli35
4 files changed, 27 insertions, 189 deletions
diff --git a/lib/kernel/EphemeralRelation.ml b/lib/kernel/EphemeralRelation.ml
index 8aa0463..ddf005d 100644
--- a/lib/kernel/EphemeralRelation.ml
+++ b/lib/kernel/EphemeralRelation.ml
@@ -1,73 +1,29 @@
-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
+type t =
+ { schematics: [`Persisted of Concepts.Hash.hash
+ | `Temporary of (Protocols.Schematics.attribute_description BatMap.String.t) ] }
+
+module Error = struct
+ open Concepts.Condition
+ let local_constraint_not_implemented =
+ condition "local-constraint-not-implemented"
+ "Local constraints have no centralized authority for their discerniment and enforcement yet."
+ empty
+ let predicate_not_implemented =
+ condition "predicate-not-implemented"
+ "Preciate descriptions for relations is not designed yet."
+ empty
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
+class ephemeral_relation program address value =
+ object (self)
+ inherit Lifecycle.null
+ val relation : t = value
+ method local_constraints = Error Error.local_constraint_not_implemented
+ method predicate = Error Error.predicate_not_implemented
+
+ method protocol : Protocols.Handle.protocol list =
+ Protocols.[ Relation.make self
+ ; Enumerable.make self
+ ; Schematics.make self ]
+ method hash : Concepts.Hash.hash = address
+ end
diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml
index f90ddff..242aedb 100644
--- a/lib/kernel/SubstantialRelation.ml
+++ b/lib/kernel/SubstantialRelation.ml
@@ -174,7 +174,6 @@ module Make (S : Abstract.Storage.STORAGE) = struct
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
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
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 10:33:54 +0000