aboutsummaryrefslogtreecommitdiffstats
path: root/lib/kernel
diff options
context:
space:
mode:
Diffstat (limited to 'lib/kernel')
-rw-r--r--lib/kernel/Branch.ml4
-rw-r--r--lib/kernel/BranchManager.ml7
-rw-r--r--lib/kernel/EphemeralRelation.ml74
-rw-r--r--lib/kernel/Generator.ml4
-rw-r--r--lib/kernel/Lifecycle.ml4
-rw-r--r--lib/kernel/Lifecycle.mli1
-rw-r--r--lib/kernel/Multigroup.ml27
-rw-r--r--lib/kernel/Namespace.ml10
-rw-r--r--lib/kernel/Namespace.mli1
-rw-r--r--lib/kernel/Path.ml31
-rw-r--r--lib/kernel/Session.ml3
-rw-r--r--lib/kernel/SubstantialRelation.ml7
12 files changed, 106 insertions, 67 deletions
diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml
index ac8978b..25c2e7b 100644
--- a/lib/kernel/Branch.ml
+++ b/lib/kernel/Branch.ml
@@ -126,8 +126,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct
let* violations = Protocols.Admission.check admission in
Ok
(List.map
- (fun (d, tuples) ->
- Path.(to_string ("multigroup" @/ m @/ "denial" @/ d @/ this)), tuples )
+ (fun (d, witness) ->
+ Path.(to_string ("multigroup" @/ m @/ "denial" @/ d @/ this)), witness )
violations ) )
in
Protocols.
diff --git a/lib/kernel/BranchManager.ml b/lib/kernel/BranchManager.ml
index 206aae9..886d100 100644
--- a/lib/kernel/BranchManager.ml
+++ b/lib/kernel/BranchManager.ml
@@ -10,11 +10,8 @@ module Error = struct
let refused violations =
condition "refused" "The state is not admitted: a denial in it holds tuples"
(List.fold_left
- (fun ps (path, tuples) ->
- ps
- & path
- |=| Concepts.Value.String
- (String.concat "; " (List.map Concepts.Tuple.to_string tuples)) )
+ (fun ps (path, witness) ->
+ ps & path |=| Concepts.Value.String (Concepts.Tuple.to_string witness) )
empty violations )
end
diff --git a/lib/kernel/EphemeralRelation.ml b/lib/kernel/EphemeralRelation.ml
index 8cae91f..c0ec241 100644
--- a/lib/kernel/EphemeralRelation.ml
+++ b/lib/kernel/EphemeralRelation.ml
@@ -18,8 +18,12 @@ module Error = struct
let unbound_program name =
condition "unbound-program"
- "A stored relation has to be instantiated by its evaluator before it can be enumerated"
+ "A relation generated by a program has to be given a state to run within before it is read"
("relation" |=| Concepts.Value.String name)
+
+ let undecidable_membership () =
+ condition "undecidable-membership"
+ "A relation with no membership test and no end was asked whether it holds a tuple" empty
end
module Persisted = struct
@@ -59,7 +63,7 @@ let persisted = function
Some {Persisted.name; schematics; program}
| _ -> None
-class ephemeral_relation ?program description value enumerate inputs =
+class ephemeral_relation ?program ?decide description value modes enumerate inputs =
object (self)
inherit Lifecycle.counted
inherit Identity.of_id
@@ -67,19 +71,24 @@ class ephemeral_relation ?program description value enumerate inputs =
val relation : t = value
method destroy = List.iter Protocols.Handle.release inputs
method enumerate : (Protocols.Handle.t, Concepts.Condition.condition) result = enumerate ()
+ method modes : (Concepts.Mode.t, Concepts.Condition.condition) result = modes ()
method describe () = Ok (Protocols.Schematics.Relation description)
- (* TODO: We do not need to scan, but simply apply a membership
- criteria (set of constraints. For now this works, but it's
- inneficient and hurts data independence, as there is an
- assymetry between ephemeral and substantial relations. *)
method contains (tuple : Concepts.Tuple.t) =
let open Utilities.Result in
- let* cursor = self#enumerate in
- Protocols.Handle.releasing cursor (fun () ->
- let* scan = Protocols.Cursor.require cursor in
- Protocols.Cursor.exists scan (fun member ->
- Concepts.Hash.hash_equals (Concepts.Tuple.hash member) (Concepts.Tuple.hash tuple) ) )
+ match decide with
+ | Some decide -> decide tuple
+ | None ->
+ let* modes = self#modes in
+ if not (Concepts.Mode.exhaustible modes BatSet.String.empty) then
+ Error (Error.undecidable_membership ())
+ else
+ let* cursor = self#enumerate in
+ Protocols.Handle.releasing cursor (fun () ->
+ let* scan = Protocols.Cursor.require cursor in
+ Protocols.Cursor.exists scan (fun member ->
+ Concepts.Hash.hash_equals (Concepts.Tuple.hash member)
+ (Concepts.Tuple.hash tuple) ) )
method protocols : Protocols.Handle.protocol list =
let protocols =
@@ -96,11 +105,13 @@ class ephemeral_relation ?program description value enumerate inputs =
:: protocols
end
-let instantiate ?(inputs = []) ?program description value enumerate =
- new ephemeral_relation ?program description value enumerate inputs |> Protocols.Handle.make
+let instantiate ?(inputs = []) ?program ?decide ~modes description value enumerate =
+ new ephemeral_relation ?program ?decide description value modes enumerate inputs
+ |> Protocols.Handle.make
let literal description tuples =
instantiate description
+ ~modes:(fun () -> Ok [Concepts.(Mode.mode [] (Cardinality.bounded (List.length tuples)))])
{name= None; schematics= `Temporary description; program= None}
(fun () -> Ok (Generator.cursor_of (fun ~yield -> List.iter yield tuples; Ok ())))
@@ -113,6 +124,7 @@ let enumerate_owned relation =
object
method reference = true
method release = Protocols.Handle.release relation
+ method is_managed = true
end
in
match
@@ -128,18 +140,29 @@ let enumerate_owned relation =
method to_string = Protocols.Handle.to_string cursor
end )
-let run name program within () =
- let open Utilities.Result in
- match program, within with
- | Some program, Some within ->
- let* executable = Protocols.Executable.require program in
- Result.bind (Protocols.Executable.invoke executable [] ~within) enumerate_owned
- | _ -> Error (Error.unbound_program name)
-
-let view ?within description program =
- instantiate ~program description
+let asking f relation =
+ Protocols.Handle.releasing relation (fun () -> Result.bind (Protocols.Relation.require relation) f)
+
+(* What a program generates is known only from the relation it
+ returns, so reading it, asking its modes and asking for a tuple
+ all invoke it. *)
+let generated ?program ?within name description value =
+ let invoking f () =
+ let open Utilities.Result in
+ match program, within with
+ | Some program, Some within ->
+ let* executable = Protocols.Executable.require program in
+ Result.bind (Protocols.Executable.invoke executable [] ~within) f
+ | _ -> Error (Error.unbound_program name)
+ in
+ instantiate ?program
+ ~decide:(fun tuple -> invoking (asking (fun r -> Protocols.Relation.contains r tuple)) ())
+ ~modes:(invoking (asking Protocols.Relation.modes))
+ description value (invoking enumerate_owned)
+
+let of_program ?within description program =
+ generated ~program ?within (Protocols.Handle.to_string program) description
{name= None; schematics= `Temporary description; program= None}
- (run (Protocols.Handle.to_string program) (Some program) within)
module Make (S : Abstract.Storage.STORAGE) = struct
module SI = Storage.Make (S)
@@ -147,9 +170,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct
let restore ?program ?within ({Persisted.name; schematics; program= pointer} : Persisted.t)
description =
- instantiate ?program description
+ generated ?program ?within name description
{name= Some name; schematics= `Persisted schematics; program= Some pointer}
- (run name program within)
let load ?bind connection (record : Persisted.t) =
let open Utilities.Result in
diff --git a/lib/kernel/Generator.ml b/lib/kernel/Generator.ml
index 272bb86..b83de3b 100644
--- a/lib/kernel/Generator.ml
+++ b/lib/kernel/Generator.ml
@@ -12,7 +12,7 @@ let resume k = Effect.Deep.continue k ()
class producer_cursor produce finally =
object (self)
- inherit Lifecycle.null
+ inherit Lifecycle.counted
inherit Identity.of_id
method to_string = "producer-cursor"
val mutable state : [`Fresh | `Live of (unit, step) Effect.Deep.continuation | `Done] = `Fresh
@@ -49,7 +49,7 @@ class producer_cursor produce finally =
if limit <= 0 then Ok Protocols.Cursor.{tuples= BatFingerTree.empty; exhausted= state = `Done}
else fill 0 BatFingerTree.empty
- method! release = match state with `Fresh | `Live _ -> self#finish | `Done -> ()
+ method destroy = match state with `Fresh | `Live _ -> self#finish | `Done -> ()
end
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 ac6bb20..4fb12b9 100644
--- a/lib/kernel/Lifecycle.ml
+++ b/lib/kernel/Lifecycle.ml
@@ -1,6 +1,7 @@
class type lifecycle = object
method reference : bool
method release : unit
+ method is_managed : bool
end
class type virtual controlled_lifecycle = object
@@ -12,6 +13,7 @@ class null =
object
method reference = true
method release = ()
+ method is_managed = false
end
class exclusive =
@@ -19,6 +21,7 @@ class exclusive =
val taken = Atomic.make false
method reference = Atomic.compare_and_set taken false true
method release = Atomic.set taken false
+ method is_managed = true
end
class virtual counted =
@@ -27,6 +30,7 @@ class virtual counted =
method virtual destroy : unit
method reference = Atomic.incr references; true
method release = if Atomic.fetch_and_add references (-1) = 1 then self#destroy
+ method is_managed = true
end
class retaining inner (owner : lifecycle) =
diff --git a/lib/kernel/Lifecycle.mli b/lib/kernel/Lifecycle.mli
index d4ef178..a323197 100644
--- a/lib/kernel/Lifecycle.mli
+++ b/lib/kernel/Lifecycle.mli
@@ -1,6 +1,7 @@
class type lifecycle = object
method reference : bool
method release : unit
+ method is_managed : bool
end
class type virtual controlled_lifecycle = object
diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml
index eaef8c3..f01a983 100644
--- a/lib/kernel/Multigroup.ml
+++ b/lib/kernel/Multigroup.ml
@@ -69,6 +69,12 @@ module Make (S : Abstract.Storage.STORAGE) = struct
condition "incomplete-multigroup"
"A stored multigroup is missing part of its expected structure. Is your storage corrupted?"
("address" |=| Concepts.Value.String (Concepts.Hash.to_hum_string addr))
+
+ let unjudgeable denial =
+ condition "unjudgeable-denial"
+ "A denial does not declare that reading it with nothing bound ends, so the state cannot \
+ be judged"
+ ("denial" |=| Concepts.Value.String denial)
end
module Representation = Concepts.Encoding.Record.Make (struct
@@ -177,16 +183,17 @@ module Make (S : Abstract.Storage.STORAGE) = struct
let held (name, relation) =
let open Utilities.Result in
Protocols.Handle.releasing relation (fun () ->
- let* enumerable = Protocols.Enumerable.require relation in
- let* cursor = Protocols.Enumerable.enumerate enumerable in
- Protocols.Handle.releasing cursor (fun () ->
- let* scan = Protocols.Cursor.require cursor in
- let* first = Protocols.Cursor.next scan in
- match first with
- | None -> Ok []
- | Some tuple ->
- let* rest = Protocols.Cursor.drain scan () in
- Ok [name, tuple :: BatFingerTree.to_list rest] ) )
+ let* denial = Protocols.Relation.require relation in
+ let* modes = Protocols.Relation.modes denial in
+ if not (Concepts.Mode.exhaustible modes BatSet.String.empty) then
+ Error (Error.unjudgeable name)
+ else
+ let* enumerable = Protocols.Enumerable.require relation in
+ let* cursor = Protocols.Enumerable.enumerate enumerable in
+ Protocols.Handle.releasing cursor (fun () ->
+ let* scan = Protocols.Cursor.require cursor in
+ let* first = Protocols.Cursor.next scan in
+ Ok (Option.to_list (Option.map (fun witness -> name, witness) first)) ) )
class multigroup ?bind conn value schema_tree denial_tree =
object (self)
diff --git a/lib/kernel/Namespace.ml b/lib/kernel/Namespace.ml
index 340e813..c7c0767 100644
--- a/lib/kernel/Namespace.ml
+++ b/lib/kernel/Namespace.ml
@@ -1,18 +1,22 @@
class namespace =
object (self)
- inherit Lifecycle.null
+ inherit Lifecycle.counted
inherit Identity.of_id
method to_string = "namespace"
val entries : (string, Protocols.Handle.t) BatMap.t Atomic.t = Atomic.make BatMap.empty
method protocols = Protocols.[Directory.make self; Registry.make self]
+ method destroy = Atomic.get entries |> BatMap.values |> BatEnum.iter Protocols.Handle.release
method update key reference value =
match
Utilities.Atomic.mswap entries (fun e ->
- if BatMap.find_opt key e = reference then
+ let existing = BatMap.find_opt key e in
+ if existing = reference then begin
+ Option.map Protocols.Handle.release existing |> ignore;
match value with
- | Some v -> Ok (BatMap.add key v e)
+ | Some v -> Ok (BatMap.add key (Protocols.Handle.move v) e)
| None -> Ok (BatMap.remove key e)
+ end
else Error () )
with
| Ok _ -> Ok true
diff --git a/lib/kernel/Namespace.mli b/lib/kernel/Namespace.mli
index ec77724..394e44a 100644
--- a/lib/kernel/Namespace.mli
+++ b/lib/kernel/Namespace.mli
@@ -2,6 +2,7 @@ class namespace : object
inherit Protocols.Handle.obj
inherit Protocols.Directory.implementation
inherit Protocols.Registry.implementation
+ method destroy : unit
end
val make : unit -> Protocols.Handle.t
diff --git a/lib/kernel/Path.ml b/lib/kernel/Path.ml
index 4e36125..0814b1c 100644
--- a/lib/kernel/Path.ml
+++ b/lib/kernel/Path.ml
@@ -25,37 +25,33 @@ module Error = struct
end
let walking ?missing f g handle path =
+ let open Protocols in
+ let open Utilities.Result in
let rec walk handle = function
- | [] -> g handle
+ | [] -> g (Handle.keep handle)
| x :: xs -> (
- let open Utilities.Result in
- let open Protocols in
let* dir =
Handle.require Directory.from handle
|> Result.map_error
Concepts.Condition.(complement ("before-segment" |=| Concepts.Value.String x))
in
- let* elem = Directory.find dir x in
+ let* elem = Directory.find dir x |> Result.map (Option.map Handle.autorelease) in
match elem with
| None -> (
match missing with Some m -> m () | None -> Error (Error.path_not_found path) )
| Some elem -> f x handle (fun () -> walk elem xs) )
in
- walk handle path
- |> Result.map_error
- Concepts.Condition.(complement ("path" |=| Concepts.Value.String (to_string path)))
+ Handle.with_autorelease (fun () ->
+ walk handle path
+ |> Result.map_error
+ Concepts.Condition.(complement ("path" |=| Concepts.Value.String (to_string path))) )
-(* Handles we find in the middle of a walk get released once we're
- done with them, but never the caller's root. If you leak one and
- its refcount never drops, nothing under that path gets collected,
- and an exclusive object, like a session, stays locked forever. *)
-let releasing root handle f = if handle == root then f () else Protocols.Handle.releasing handle f
-let lookup handle path = walking (fun _ parent -> releasing handle parent) Result.ok handle path
+let lookup handle path = walking (fun _ _ f -> f ()) Result.ok handle path
let find handle path =
walking
~missing:(fun () -> Ok None)
- (fun _ parent -> releasing handle parent)
+ (fun _ _ f -> f ())
(fun h -> Ok (Some h))
handle path
@@ -63,9 +59,8 @@ let update handle path key reference value =
let open Utilities.Result in
let open Protocols in
let* target = lookup handle path in
- releasing handle target (fun () ->
- let* registry = Handle.require Registry.from target in
- Registry.update registry key reference value )
+ let* registry = Handle.require Registry.from target in
+ Registry.update registry key reference value
(* The changes at this object, and those beneath each child they reach. *)
let split changes =
@@ -119,7 +114,7 @@ let assoc_all handle changes =
| None when binds beneath -> Ok [x, Some (fresh beneath)]
| None -> Ok []
| Some child ->
- releasing handle child (fun () -> apply (prefix @ [x]) child beneath)
+ Handle.releasing child (fun () -> apply (prefix @ [x]) child beneath)
|> Result.map (fun child' -> [x, Some child']) )
below
|> Utilities.List.sequence
diff --git a/lib/kernel/Session.ml b/lib/kernel/Session.ml
index 1abd278..231f518 100644
--- a/lib/kernel/Session.ml
+++ b/lib/kernel/Session.ml
@@ -4,7 +4,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
class session storage state =
object (self)
- inherit Lifecycle.exclusive
+ inherit Lifecycle.counted
inherit Identity.of_id
method to_string = "session"
val storage : S.connection = storage
@@ -13,6 +13,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
method pin state' = Atomic.set state state'
method protocols = Protocols.[Directory.make self; Session.make self]
method list = Ok (BatFingerTree.singleton "branch")
+ method destroy = ()
method find =
function
diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml
index 533893c..09aec90 100644
--- a/lib/kernel/SubstantialRelation.ml
+++ b/lib/kernel/SubstantialRelation.ml
@@ -116,6 +116,13 @@ module Make (S : Abstract.Storage.STORAGE) = struct
let* node = tuple_node tx relation in
TupleSet.mem tx (Concepts.Tuple.hash tuple) node )
+ method modes =
+ Ok
+ Concepts.
+ [ Mode.mode [] Cardinality.Finite;
+ Mode.mode (List.map fst (BatMap.String.bindings description)) (Cardinality.bounded 1)
+ ]
+
method describe () = Ok (Protocols.Schematics.Relation description)
method enumerate = enumerate connection relation
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 06:38:43 +0000