aboutsummaryrefslogtreecommitdiffstats
path: root/lib/kernel
diff options
context:
space:
mode:
Diffstat (limited to 'lib/kernel')
-rw-r--r--lib/kernel/Branch.ml92
-rw-r--r--lib/kernel/Branch.mli4
-rw-r--r--lib/kernel/BranchManager.ml26
-rw-r--r--lib/kernel/BranchManager.mli8
-rw-r--r--lib/kernel/EphemeralRelation.ml158
-rw-r--r--lib/kernel/Initialization.ml67
-rw-r--r--lib/kernel/Initialization.mli8
-rw-r--r--lib/kernel/Merkle.ml49
-rw-r--r--lib/kernel/Multigroup.ml231
-rw-r--r--lib/kernel/Multigroup.mli22
-rw-r--r--lib/kernel/Path.ml133
-rw-r--r--lib/kernel/Path.mli22
-rw-r--r--lib/kernel/Program.ml74
-rw-r--r--lib/kernel/Prototype.ml45
-rw-r--r--lib/kernel/Prototype.mli20
-rw-r--r--lib/kernel/Scope.ml152
-rw-r--r--lib/kernel/Scope.mli71
-rw-r--r--lib/kernel/SubstantialRelation.ml23
18 files changed, 1048 insertions, 157 deletions
diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml
index b0ba06e..25c2e7b 100644
--- a/lib/kernel/Branch.ml
+++ b/lib/kernel/Branch.ml
@@ -1,9 +1,9 @@
module Make (S : Abstract.Storage.STORAGE) = struct
- (* Branch has a name, a set of multigroups, and a backlink to the previous state
- multigroup has a name and a set of schemas
- schema has a name and a set of relations
+ (* A branch state holds its multigroups and a backlink to the state it
+ succeeded, each multigroup its relations:
- \branch\master\multigroup\universe\schema\sky\relation\planet
+ \system\branch\master\multigroup\universe\relation\planet
+ \system\branch\master\previous\multigroup\universe\relation\planet
*)
module SI = Storage.Make (S)
@@ -70,7 +70,15 @@ module Make (S : Abstract.Storage.STORAGE) = struct
let pointer_of hash = SI.Pointer.make Loader.load (S.Hash hash)
- class branch storage value node =
+ let node_of tx branch =
+ let open Utilities.Result in
+ MultigroupM.find tx branch.multigroups
+ |> fmap (Option.to_result ~none:(Error.incomplete_branch branch.multigroups))
+
+ (* Given [root], the stored programs of this state run through the
+ evaluators registered under it, against this very state, so an
+ earlier state reads as it was. *)
+ class branch ?root storage value node =
object (self)
inherit Lifecycle.null
method to_string = "branch"
@@ -84,15 +92,52 @@ module Make (S : Abstract.Storage.STORAGE) = struct
let* node' =
SI.with_transaction storage (fun tx ->
let* _ = SI.store_blob tx (Representation.to_blob branch'') in
- MultigroupM.find tx branch'.multigroups
- |> fmap (Option.to_result ~none:(Error.incomplete_branch branch'.multigroups)) )
+ node_of tx branch' )
in
- new branch storage branch'' node' |> Protocols.Handle.make |> Result.ok
+ new branch ?root storage branch'' node' |> Protocols.Handle.make |> Result.ok
+
+ method private previous =
+ match branch.previous with
+ | None -> Ok None
+ | Some pointer ->
+ SI.with_read storage (fun tx ->
+ let open Utilities.Result in
+ let* previous = SI.Pointer.deref tx pointer in
+ let* node = node_of tx previous in
+ Ok (Some (Protocols.Handle.make {<branch = previous; node>})) )
method protocols : Protocols.Handle.protocol list =
+ let bind =
+ Option.map
+ (fun root -> {EphemeralRelation.root; within= Protocols.Handle.make {<>}})
+ root
+ in
+ let multigroups =
+ Prototype.mixture_of node (fun make node ->
+ [ MMAddressable.make ~node:(MultigroupM.into node);
+ MMDirectory.make ~storage ~node ~constructor:(M.load ?bind storage);
+ MMAssociative.make ~admit:M.admit ~storage ~node:(MultigroupM.into node)
+ ~constructor:(fun node' -> MultigroupM.from node' |> make |> Result.ok ) ] )
+ in
let open Utilities.Result in
+ let admits (m, multigroup) =
+ Protocols.Handle.releasing multigroup (fun () ->
+ let* admission = Protocols.Admission.require multigroup in
+ let* violations = Protocols.Admission.check admission in
+ Ok
+ (List.map
+ (fun (d, witness) ->
+ Path.(to_string ("multigroup" @/ m @/ "denial" @/ d @/ this)), witness )
+ violations ) )
+ in
Protocols.
[ Addressable.make self;
+ Admission.make
+ object
+ method check =
+ let* named = Prototype.Directory.children multigroups in
+ List.map admits named |> Utilities.List.sequence |> Result.map List.concat
+ end;
Prototype.Associative.(
of_properties
[ ( "multigroup",
@@ -100,28 +145,31 @@ module Make (S : Abstract.Storage.STORAGE) = struct
Handle.require Addressable.from node'
|> Result.map Addressable.address
|> fmap (fun addr -> self#deriving {branch with multigroups= addr}) ) ) ] );
- Prototype.Directory.of_properties
- [ ( "multigroup",
- Prototype.mixture_of node (fun make node ->
- [ MMAddressable.make ~node:(MultigroupM.into node);
- MMDirectory.make ~storage ~node ~constructor:(M.wrap storage);
- MMAssociative.make ~storage ~node:(MultigroupM.into node)
- ~constructor:(fun node' -> MultigroupM.from node' |> make |> Result.ok )
- ] ) ) ] ]
+ Directory.make
+ object
+ method list =
+ Ok
+ (BatFingerTree.of_list
+ ( "multigroup"
+ :: Option.fold ~none:[] ~some:(fun _ -> ["previous"]) branch.previous ) )
+
+ method find =
+ function
+ | "multigroup" -> Ok (Some multigroups)
+ | "previous" -> self#previous
+ | _ -> Ok None
+ end ]
method hash = Representation.to_blob branch |> Concepts.Hash.hash_of_blob
method address = self#hash
end
- let load tx conn addr =
+ let load ?root tx conn addr =
let open Utilities.Result in
let* data = SI.get_req tx (S.Hash addr) in
let* branch = Representation.of_blob data in
- let* node =
- MultigroupM.find tx branch.multigroups
- |> fmap (Option.to_result ~none:(Error.incomplete_branch branch.multigroups))
- in
- Ok (new branch conn branch node |> Protocols.Handle.make)
+ let* node = node_of tx branch in
+ Ok (new branch ?root conn branch node |> Protocols.Handle.make)
let make conn =
let open Utilities.Result in
diff --git a/lib/kernel/Branch.mli b/lib/kernel/Branch.mli
index c08e781..865d68d 100644
--- a/lib/kernel/Branch.mli
+++ b/lib/kernel/Branch.mli
@@ -1,9 +1,13 @@
+(** A branch state: its multigroups, and under [previous] the state it
+ succeeded. Given [root], the stored programs read through it run, by
+ the evaluators registered under [root], against it. *)
module Make (S : Abstract.Storage.STORAGE) : sig
type t
val make : S.connection -> (Protocols.Handle.t, Concepts.Condition.condition) result
val load :
+ ?root:Protocols.Handle.t ->
S.transaction ->
S.connection ->
Concepts.Hash.hash ->
diff --git a/lib/kernel/BranchManager.ml b/lib/kernel/BranchManager.ml
index 3531748..886d100 100644
--- a/lib/kernel/BranchManager.ml
+++ b/lib/kernel/BranchManager.ml
@@ -6,8 +6,21 @@ module Error = struct
"The root hash for the database state is missing from the backend. Either your storage is \
corrupted, or this is a bug in RNT!"
("hash" |=| Concepts.Value.String (Concepts.Hash.to_hum_string head))
+
+ let refused violations =
+ condition "refused" "The state is not admitted: a denial in it holds tuples"
+ (List.fold_left
+ (fun ps (path, witness) ->
+ ps & path |=| Concepts.Value.String (Concepts.Tuple.to_string witness) )
+ empty violations )
end
+let admitted state =
+ let open Utilities.Result in
+ let* admission = Protocols.Admission.require state in
+ let* violations = Protocols.Admission.check admission in
+ if violations = [] then Ok () else Error (Error.refused violations)
+
module Make (S : Abstract.Storage.STORAGE) = struct
module M = Merkle.Make (S) (Merkle.StringKey)
module SI = Storage.Make (S)
@@ -28,7 +41,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
let data = Concepts.Hash.blob_of_hash addr in
S.put tx (S.Label label) data
- class manager storage label head =
+ class manager ?root storage label head =
object (self)
inherit Lifecycle.null
inherit Identity.of_id
@@ -51,11 +64,14 @@ module Make (S : Abstract.Storage.STORAGE) = struct
let* head = Atomic.get head |> M.lookup tx key in
match head with
| None -> Ok None
- | Some head -> B.load tx storage head |> Result.map Option.some )
+ | Some head -> B.load ?root tx storage head |> Result.map Option.some )
+ (* a head moves only to an admitted state, judged before the head is
+ taken, since judging may run stored programs that read storage *)
method update key reference value =
let open Utilities.Result in
let open Protocols in
+ let* () = Option.fold ~none:(Ok ()) ~some:admitted value in
SI.with_transaction storage (fun tx ->
match
Utilities.Atomic.mswap head (fun head ->
@@ -92,14 +108,14 @@ module Make (S : Abstract.Storage.STORAGE) = struct
| Error (Some e) -> Error e )
end
- let make storage label =
+ let make ?root storage label =
let open Utilities.Result in
SI.with_transaction storage (fun tx ->
let* addr = root_for tx label in
match addr with
- | None -> Ok (new manager storage label M.empty |> Protocols.Handle.make)
+ | None -> Ok (new manager ?root storage label M.empty |> Protocols.Handle.make)
| Some addr ->
let* head = M.find tx addr in
let* head = Option.to_result ~none:(Error.invalid_root addr) head in
- Ok (new manager storage label head |> Protocols.Handle.make) )
+ Ok (new manager ?root storage label head |> Protocols.Handle.make) )
end
diff --git a/lib/kernel/BranchManager.mli b/lib/kernel/BranchManager.mli
index a75875f..873aa36 100644
--- a/lib/kernel/BranchManager.mli
+++ b/lib/kernel/BranchManager.mli
@@ -1,3 +1,9 @@
+(** The heads of the branches, persisted under [label]. Branches it hands
+ out run their stored programs by the evaluators under [root]. *)
module Make (S : Abstract.Storage.STORAGE) : sig
- val make : S.connection -> string -> (Protocols.Handle.t, Concepts.Condition.condition) result
+ val make :
+ ?root:Protocols.Handle.t ->
+ S.connection ->
+ string ->
+ (Protocols.Handle.t, Concepts.Condition.condition) result
end
diff --git a/lib/kernel/EphemeralRelation.ml b/lib/kernel/EphemeralRelation.ml
index 1d9267e..c0ec241 100644
--- a/lib/kernel/EphemeralRelation.ml
+++ b/lib/kernel/EphemeralRelation.ml
@@ -7,8 +7,6 @@ type t =
| `Temporary of Protocols.Schematics.attribute_description BatMap.String.t ];
program: program option }
-type Protocols.Handle.protocol += Stored of {evaluator: string; code: Concepts.Blob.t}
-
module Error = struct
open Concepts.Condition
@@ -20,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
@@ -61,7 +63,7 @@ let persisted = function
Some {Persisted.name; schematics; program}
| _ -> None
-class ephemeral_relation ?code description value enumerate inputs =
+class ephemeral_relation ?program ?decide description value modes enumerate inputs =
object (self)
inherit Lifecycle.counted
inherit Identity.of_id
@@ -69,64 +71,134 @@ class ephemeral_relation ?code 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
- Fun.protect
- ~finally:(fun () -> Protocols.Handle.release 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 = Protocols.[Relation.make self; Enumerable.make self; Schematics.make self] in
+ let protocols =
+ Protocols.[Relation.make self; Enumerable.make self; Schematics.make self]
+ @ Option.fold ~none:[] ~some:Protocols.Handle.protocols program
+ in
match persisted relation with
| None -> protocols
| Some record ->
- let stored =
- Option.fold ~none:protocols
- ~some:(fun code -> Stored {evaluator= record.program.evaluator; code} :: protocols)
- code
- in
Protocols.Addressable.make
object
method address = Persisted.Representation.to_blob record |> Concepts.Hash.hash_of_blob
end
- :: stored
+ :: protocols
end
-let instantiate ?(inputs = []) ?code description value enumerate =
- new ephemeral_relation ?code 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 ())))
+
+type binding = {root: Protocols.Handle.t; within: Protocols.Handle.t}
+
+(* The relation a program produced has to outlive the cursor over it. *)
+let enumerate_owned relation =
+ let open Utilities.Result in
+ let owner =
+ object
+ method reference = true
+ method release = Protocols.Handle.release relation
+ method is_managed = true
+ end
+ in
+ match
+ let* enumerable = Protocols.Enumerable.require relation in
+ Protocols.Enumerable.enumerate enumerable
+ with
+ | Error c -> Protocols.Handle.release relation; Error c
+ | Ok cursor ->
+ Ok
+ (Protocols.Handle.make
+ object
+ inherit Lifecycle.retaining cursor owner
+ method to_string = Protocols.Handle.to_string cursor
+ end )
+
+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}
module Make (S : Abstract.Storage.STORAGE) = struct
module SI = Storage.Make (S)
module R = SubstantialRelation.Make (S)
- let restore ~code ({Persisted.name; schematics; program} : Persisted.t) description =
- instantiate ~code description
- {name= Some name; schematics= `Persisted schematics; program= Some program}
- (fun () -> Error (Error.unbound_program name))
-
- let load connection (record : Persisted.t) =
- SI.with_read connection (fun tx ->
- let open Utilities.Result in
- let* description = R.schema_of tx record.schematics in
- let* code = SI.get_req tx (S.Hash record.program.code) in
- Ok (restore ~code record description) )
-
- let persist connection ~name ~evaluator ~code description =
+ let restore ?program ?within ({Persisted.name; schematics; program= pointer} : Persisted.t)
+ description =
+ generated ?program ?within name description
+ {name= Some name; schematics= `Persisted schematics; program= Some pointer}
+
+ let load ?bind connection (record : Persisted.t) =
+ let open Utilities.Result in
+ let* description, source =
+ SI.with_read connection (fun tx ->
+ let* description = R.schema_of tx record.schematics in
+ let* code = SI.get_req tx (S.Hash record.program.code) in
+ Ok (description, Bytes.to_string (Concepts.Blob.bytes_of_blob code)) )
+ in
+ match bind with
+ | None -> Ok (restore record description)
+ | Some {root; within} ->
+ let* program = Program.load root ~evaluator:record.program.evaluator ~source in
+ Ok (restore ~program ~within record description)
+
+ let store tx ~name ~evaluator ~source description =
+ let open Utilities.Result in
+ let* schematics = R.store_schema tx description in
+ let* address = SI.store_blob tx (Concepts.Blob.blob_of_bytes (Bytes.of_string source)) in
+ let record = {Persisted.name; schematics; program= {evaluator; code= address}} in
+ let* _ = SI.store_blob tx (Persisted.Representation.to_blob record) in
+ Ok record
+
+ let persist connection ~name program description =
+ let open Utilities.Result in
+ let* {Program.evaluator; source; _} = Program.require program in
SI.with_transaction connection (fun tx ->
- let open Utilities.Result in
- let* schematics = R.store_schema tx description in
- let* address = SI.store_blob tx code in
- let record = {Persisted.name; schematics; program= {evaluator; code= address}} in
- let* _ = SI.store_blob tx (Persisted.Representation.to_blob record) in
- Ok (restore ~code record description) )
+ let* record = store tx ~name ~evaluator ~source description in
+ Ok (restore ~program record description) )
end
diff --git a/lib/kernel/Initialization.ml b/lib/kernel/Initialization.ml
index 3c8addb..518fe4f 100644
--- a/lib/kernel/Initialization.ml
+++ b/lib/kernel/Initialization.ml
@@ -1,23 +1,62 @@
+module Error = struct
+ open Concepts.Condition
+
+ let taken name =
+ condition "name-taken" "A namespace already binds the name"
+ ("name" |=| Concepts.Value.String name)
+end
+
+let bind namespace (name, handle) =
+ let open Utilities.Result in
+ let* registry = Protocols.Handle.require Protocols.Registry.from namespace in
+ let* bound = Protocols.Registry.update registry name None (Some handle) in
+ if bound then Ok () else Error (Error.taken name)
+
+let namespace entries =
+ let into = Namespace.make () in
+ let open Utilities.Result in
+ let* () =
+ List.fold_left
+ (fun acc entry ->
+ let* () = acc in
+ bind into entry )
+ (Ok ()) entries
+ in
+ Ok into
+
+(* A subsystem's root holds what is its own and not data: its
+ evaluators, and whatever else it registers beside them. *)
+let mount root name =
+ match Path.lookup root Path.(name @/ this) with
+ | Ok mounted -> Ok mounted
+ | Error _ ->
+ let open Utilities.Result in
+ let* mounted = namespace ["evaluator", Namespace.make ()] in
+ let* () = bind root (name, mounted) in
+ Ok mounted
+
module Make (S : Abstract.Storage.STORAGE) = struct
module BM = BranchManager.Make (S)
+ module B = Branch.Make (S)
+ (* The heads of \system's branches, of which there is always a master,
+ are kept under the label rnt-head. *)
let initialize ?(evaluators = []) conn =
let open Utilities.Result in
- let open Protocols in
let root = Namespace.make () in
- let registry = Registry.from root |> Option.get in
- let* branch_manager = BM.make conn "rnt-head" in
- let* _ = Registry.update registry "branch" None (Some branch_manager) in
- let evaluator_namespace = Namespace.make () in
- let evaluator_registry = Registry.from evaluator_namespace |> Option.get in
- let* _ =
- List.fold_left
- (fun acc (name, handle) ->
- let* _ = acc in
- Registry.update evaluator_registry name None (Some handle) )
- (Ok true) evaluators
+ let* evaluator = namespace evaluators in
+ let* branch = BM.make ~root conn "rnt-head" in
+ let* () =
+ if Path.lookup branch Path.("master" @/ this) |> Result.is_ok then Ok ()
+ else Result.bind (B.make conn) (fun empty -> bind branch ("master", empty))
+ in
+ let* system =
+ namespace
+ [ "branch", branch;
+ "evaluator", evaluator;
+ "session", Namespace.make ();
+ "application", Namespace.make () ]
in
- let* _ = Registry.update registry "evaluator" None (Some evaluator_namespace) in
- let* _ = Registry.update registry "session" None (Some (Namespace.make ())) in
+ let* () = bind root ("system", system) in
Ok root
end
diff --git a/lib/kernel/Initialization.mli b/lib/kernel/Initialization.mli
index 926bbd8..a6e6ae0 100644
--- a/lib/kernel/Initialization.mli
+++ b/lib/kernel/Initialization.mli
@@ -1,4 +1,12 @@
+(** a subsystem's root, \[name], holding \[name]\evaluator for the
+ evaluators it registers. Mounting it again gives the one there. *)
+val mount :
+ Protocols.Handle.t -> string -> (Protocols.Handle.t, Concepts.Condition.condition) result
+
module Make (S : Abstract.Storage.STORAGE) : sig
+ (** the root of the object tree, holding \system: its branches, of
+ which there is always a master, the system's [evaluators] by
+ language, the sessions and the applications. *)
val initialize :
?evaluators:(string * Protocols.Handle.t) list ->
S.connection ->
diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml
index af5b19f..4235914 100644
--- a/lib/kernel/Merkle.ml
+++ b/lib/kernel/Merkle.ml
@@ -323,8 +323,6 @@ functor
let* _ = persist tx new_root in
Ok new_root
- let remove tx key node = failwith "TODO" [@@warning "-27"]
-
let rec fold_left tx f acc =
let open Utilities.Result in
function
@@ -342,6 +340,53 @@ functor
let keys tx node =
fold_left tx (fun acc k _ -> BatFingerTree.snoc acc k) BatFingerTree.empty node
+
+ let excise i ft =
+ let fl, fr = BatFingerTree.split_at ft i in
+ BatFingerTree.append fl (BatFingerTree.tail_exn fr)
+
+ (* Like an insert, produces a new tree where the path to the key
+ is copied without it, and a node it leaves empty goes from its
+ parent with the key that separated it. *)
+ let rec remove' tx key node =
+ let open Utilities.Result in
+ match node with
+ | Leaf {keys; values} ->
+ let i, _ = lookup1 keys key in
+ if BatFingerTree.size keys = 1 then Ok None
+ else
+ let leaf = Leaf {keys= excise i keys; values= excise i values} in
+ let* _ = persist tx leaf in
+ Ok (Some leaf)
+ | Trunk {keys; children} ->
+ let i, found = lookup1 keys key in
+ let i = if found then i + 1 else i in
+ let* child = BatFingerTree.get children i |> find' tx in
+ let* child = remove' tx key child in
+ let trunk =
+ match child with
+ | Some child -> Trunk {keys; children= BatFingerTree.set children i (hash_of child)}
+ | None -> Trunk {keys= excise (max 0 (i - 1)) keys; children= excise i children}
+ in
+ let* _ = persist tx trunk in
+ Ok (Some trunk)
+
+ let rec shrink tx = function
+ | Trunk {children; _} when BatFingerTree.size children = 1 ->
+ Utilities.Result.fmap (shrink tx) (find' tx (BatFingerTree.get children 0))
+ | node -> Ok node
+
+ let remove tx key node =
+ let open Utilities.Result in
+ let* present = lookup tx key node in
+ if Option.is_none present then Ok node
+ else
+ let* node = remove' tx key node in
+ match node with
+ | None ->
+ let* _ = persist tx empty in
+ Ok empty
+ | Some node -> shrink tx node
end
module type INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VALUE) -> sig
diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml
index 1417a65..f01a983 100644
--- a/lib/kernel/Multigroup.ml
+++ b/lib/kernel/Multigroup.ml
@@ -3,6 +3,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
module R = SubstantialRelation.Make (S)
module E = EphemeralRelation.Make (S)
+ (* A relation as a multigroup holds it. *)
module Entry = struct
module Stored = EphemeralRelation.Persisted.Representation
@@ -21,17 +22,39 @@ module Make (S : Abstract.Storage.STORAGE) = struct
Stored.of_bencode data |> Result.map (fun relation -> Ephemeral relation)
| _ -> R.Representation.of_bencode data |> Result.map (fun relation -> Substantial relation)
- let load storage = function
+ let load ?bind storage = function
| Substantial relation -> R.load storage relation
- | Ephemeral relation -> E.load storage relation
+ | Ephemeral relation -> E.load ?bind storage relation
+
+ (* A program is stored as itself, to run whenever it is read; any
+ other relation is stored as the tuples it holds now. *)
+ let admit name h =
+ let open Utilities.Result in
+ let address entry = Concepts.Hash.hash_of_blob (encode entry) in
+ match Program.image h with
+ | Some {evaluator; source; _} ->
+ let* description = Protocols.Relation.heading h in
+ Ok
+ (fun tx ->
+ let* record = E.store tx ~name ~evaluator ~source description in
+ Ok (address (Ephemeral record)) )
+ | None ->
+ let* description, tuples = Protocols.Relation.read h in
+ Ok
+ (fun tx ->
+ let* relation = R.store tx description tuples in
+ Ok (address (Substantial relation)) )
end
+ (* A schema is only a name: \schema\[s] is the tree of its relations,
+ with no record of its own. *)
+ module T = Merkle.Make (S) (Merkle.StringKey)
module RelationM = Merkle.Interface (S) (Merkle.StringKey) (Entry)
- module RMAddressable = Prototype.Addressable.OfTree (S) (Merkle.StringKey)
+ module TAddressable = Prototype.Addressable.OfTree (S) (Merkle.StringKey)
+ module TAssociative = Prototype.Associative.OfTree (S) (Merkle.StringKey)
module RMDirectory = Prototype.Directory.OfTree (S) (Merkle.StringKey) (Entry)
- module RMAssociative = Prototype.Associative.OfTree (S) (Merkle.StringKey)
- type t = {relations: RelationM.address}
+ type t = {schemas: T.address; denials: T.address}
module Error = struct
open Concepts.Condition
@@ -42,42 +65,144 @@ module Make (S : Abstract.Storage.STORAGE) = struct
database corrupted?"
empty
- let incomplete_multigroup addr =
+ let incomplete addr =
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))
- end
- module rec Representation : (Concepts.Encoding.Record.S with type t = t) =
- Concepts.Encoding.Record.Make (Body)
+ 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
- and Body : Concepts.Encoding.Record.BODY = struct
+ module Representation = Concepts.Encoding.Record.Make (struct
type nonrec t = t
let tag = '*'
let malformed = Error.malformed_multigroup
- let fields {relations} =
+ let fields {schemas; denials} =
let open Concepts.Encoding in
- ["relations", Value.bencode_of_hash relations]
+ ["schemas", Value.bencode_of_hash schemas; "denials", Value.bencode_of_hash denials]
let of_fields fields =
let open Utilities.Result in
let open Concepts.Encoding in
- let* relations = Bencode.field "relations" fields |> fmap Value.hash_of_bencode in
- Ok {relations}
- end
+ let* schemas = Bencode.field "schemas" fields |> fmap Value.hash_of_bencode in
+ let* denials = Bencode.field "denials" fields |> fmap Value.hash_of_bencode in
+ Ok {schemas; denials}
+ end)
let encode = Representation.to_blob
let decode = Representation.of_blob
- class multigroup conn value node =
+ let node_of tx addr =
+ let open Utilities.Result in
+ T.find tx addr |> fmap (Option.to_result ~none:(Error.incomplete addr))
+
+ (* What [h] holds under [property], each to store once the write has
+ begun, and the tree they make when it has. *)
+ let admissions property admit h =
+ let open Utilities.Result in
+ let* listing = Protocols.Handle.require Protocols.Directory.from h in
+ let* found = Protocols.Directory.find listing property in
+ let* children = Option.fold ~none:(Ok []) ~some:Prototype.Directory.children found in
+ List.map
+ (fun (name, child) ->
+ Prototype.Associative.admission admit name child |> Result.map (fun p -> name, p) )
+ children
+ |> Utilities.List.sequence
+
+ let tree_of tx admissions =
+ let open Utilities.Result in
+ let* _ = T.empty_under tx in
+ T.with_batch tx (fun () ->
+ List.fold_left
+ (fun node (name, store) ->
+ let* node = node in
+ let* addr = store tx in
+ T.insert tx name addr node )
+ (Ok T.empty) admissions )
+
+ let admit_schema _ h =
+ let open Utilities.Result in
+ let* relations = admissions "relation" Entry.admit h in
+ Ok (fun tx -> Result.map T.hash_of (tree_of tx relations))
+
+ let relations ?bind storage node =
+ Prototype.mixture_of node (fun make node ->
+ [ TAddressable.make ~node;
+ RMDirectory.make ~storage ~node:(RelationM.from node)
+ ~constructor:(Entry.load ?bind storage);
+ TAssociative.make ~admit:Entry.admit ~storage ~node ~constructor:(fun node' ->
+ Ok (make node') ) ] )
+
+ let rec schema ?bind storage node =
+ let open Utilities.Result in
+ Prototype.mixture
+ [ TAddressable.make ~node;
+ Prototype.Directory.of_properties ["relation", relations ?bind storage node];
+ Prototype.Associative.(
+ of_properties
+ [ ( "relation",
+ update_only (fun relations' ->
+ let* a = Protocols.Handle.require Protocols.Addressable.from relations' in
+ let* node' =
+ SI.with_read storage (fun tx -> node_of tx (Protocols.Addressable.address a))
+ in
+ Ok (schema ?bind storage node') ) ) ] ) ]
+
+ let schemas ?bind storage node =
+ Prototype.mixture_of node (fun make node ->
+ [ TAddressable.make ~node;
+ Protocols.Directory.make
+ object
+ method list = SI.with_read storage (Fun.flip T.keys node)
+
+ method find name =
+ let open Utilities.Result in
+ SI.with_read storage (fun tx ->
+ let* found = T.lookup tx name node in
+ match found with
+ | None -> Ok None
+ | Some addr ->
+ let* relations = node_of tx addr in
+ Ok (Some (schema ?bind storage relations)) )
+ end;
+ TAssociative.make ~admit:admit_schema ~storage ~node ~constructor:(fun node' ->
+ Ok (make node') ) ] )
+
+ let trees tx {schemas; denials} =
+ let open Utilities.Result in
+ let* schemas = node_of tx schemas in
+ let* denials = node_of tx denials in
+ Ok (schemas, denials)
+
+ let held (name, relation) =
+ let open Utilities.Result in
+ Protocols.Handle.releasing relation (fun () ->
+ 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)
inherit Lifecycle.null
method to_string = "multigroup"
val multigroup = value
val storage = conn
- val node = node (* FIXME: see the comment on Branch.ml *)
+ val schema_tree = schema_tree (* FIXME: see the comment on Branch.ml *)
+ val denial_tree = denial_tree
(* TODO: Add later to the lifecycle management, accounting for
derived instances. Callers must release the previous handle
@@ -85,51 +210,65 @@ module Make (S : Abstract.Storage.STORAGE) = struct
last reference is released. *)
method deriving multigroup' =
let open Utilities.Result in
- let* node' =
+ let* schemas', denials' =
SI.with_transaction storage (fun tx ->
- let* _ = SI.store_blob tx (Representation.to_blob multigroup') in
- RelationM.find tx multigroup'.relations
- |> fmap (Option.to_result ~none:(Error.incomplete_multigroup multigroup'.relations)) )
+ let* _ = SI.store_blob tx (encode multigroup') in
+ trees tx multigroup' )
in
- new multigroup storage multigroup' node' |> Protocols.Handle.make |> Result.ok
+ new multigroup ?bind storage multigroup' schemas' denials'
+ |> Protocols.Handle.make
+ |> Result.ok
+
+ method check =
+ let open Utilities.Result in
+ let* named = Prototype.Directory.children (relations ?bind storage denial_tree) in
+ List.map held named |> Utilities.List.sequence |> Result.map List.concat
method protocols : Protocols.Handle.protocol list =
let open Utilities.Result in
+ let derive f node' =
+ Protocols.Handle.require Protocols.Addressable.from node'
+ |> Result.map Protocols.Addressable.address
+ |> fmap (fun addr -> self#deriving (f addr))
+ in
Protocols.
[ Addressable.make self;
+ Admission.make self;
Prototype.Associative.(
of_properties
- [ ( "relation",
- update_only (fun node' ->
- Handle.require Addressable.from node'
- |> Result.map Addressable.address
- |> fmap (fun addr -> self#deriving {relations= addr}) ) ) ] );
+ [ "schema", update_only (derive (fun addr -> {multigroup with schemas= addr}));
+ "denial", update_only (derive (fun addr -> {multigroup with denials= addr})) ] );
Prototype.Directory.of_properties
- [ ( "relation",
- Prototype.mixture_of node (fun make node ->
- [ RMAddressable.make ~node:(RelationM.into node);
- RMDirectory.make ~storage ~node ~constructor:(Entry.load storage);
- RMAssociative.make ~storage ~node:(RelationM.into node)
- ~constructor:(fun node' -> RelationM.from node' |> make |> Result.ok ) ] )
- ) ] ]
-
- method hash = Representation.to_blob multigroup |> Concepts.Hash.hash_of_blob
+ [ "schema", schemas ?bind storage schema_tree;
+ "denial", relations ?bind storage denial_tree ] ]
+
+ method hash = encode multigroup |> Concepts.Hash.hash_of_blob
method address = self#hash
end
- let wrap conn value =
+ let load ?bind conn value =
let open Utilities.Result in
- let* node =
- SI.with_transaction conn (fun tx -> RelationM.find tx value.relations)
- |> fmap (Option.to_result ~none:(Error.incomplete_multigroup value.relations))
- in
- new multigroup conn value node |> Protocols.Handle.make |> Result.ok
+ let* schemas, denials = SI.with_read conn (fun tx -> trees tx value) in
+ new multigroup ?bind conn value schemas denials |> Protocols.Handle.make |> Result.ok
let make conn =
let open Utilities.Result in
SI.with_transaction conn (fun tx ->
- let* empty = RelationM.empty_under tx in
- let multigroup = {relations= empty} in
- let* _ = SI.store_blob tx (Representation.to_blob multigroup) in
- new multigroup conn multigroup RelationM.empty |> Protocols.Handle.make |> Result.ok )
+ let* empty = T.empty_under tx in
+ let multigroup = {schemas= empty; denials= empty} in
+ let* _ = SI.store_blob tx (encode multigroup) in
+ new multigroup conn multigroup T.empty T.empty |> Protocols.Handle.make |> Result.ok )
+
+ (* Handed over as the tree shows one, a directory holding its schemas
+ under \schema and its denials under \denial, a multigroup not stored
+ yet is stored with them. *)
+ let admit _ h =
+ let open Utilities.Result in
+ let* schemas = admissions "schema" admit_schema h in
+ let* denials = admissions "denial" Entry.admit h in
+ Ok
+ (fun tx ->
+ let* schemas = tree_of tx schemas in
+ let* denials = tree_of tx denials in
+ SI.store_blob tx (encode {schemas= T.hash_of schemas; denials= T.hash_of denials}) )
end
diff --git a/lib/kernel/Multigroup.mli b/lib/kernel/Multigroup.mli
index 2df41e6..fab02df 100644
--- a/lib/kernel/Multigroup.mli
+++ b/lib/kernel/Multigroup.mli
@@ -1,8 +1,22 @@
+(** A multigroup: its schemas, \multigroup\[m]\schema\[s], and its denials,
+ \multigroup\[m]\denial\[d]. *)
module Make (S : Abstract.Storage.STORAGE) : sig
- type t
+ include Merkle.VALUE
- val encode : t -> Concepts.Blob.t
- val decode : Concepts.Blob.t -> (t, Concepts.Condition.condition) result
- val wrap : S.connection -> t -> (Protocols.Handle.t, Concepts.Condition.condition) result
+ val load :
+ ?bind:EphemeralRelation.binding ->
+ S.connection ->
+ t ->
+ (Protocols.Handle.t, Concepts.Condition.condition) result
+
+ (** a multigroup handed over with no address, as a directory holding its
+ schemas under \schema and its denials under \denial, to store once the
+ write has begun. *)
+ val admit :
+ string ->
+ Protocols.Handle.t ->
+ (S.transaction Prototype.Associative.admission, Concepts.Condition.condition) result
+
+ (** an empty one, stored. *)
val make : S.connection -> (Protocols.Handle.t, Concepts.Condition.condition) result
end
diff --git a/lib/kernel/Path.ml b/lib/kernel/Path.ml
index 2e712cc..0814b1c 100644
--- a/lib/kernel/Path.ml
+++ b/lib/kernel/Path.ml
@@ -17,9 +17,14 @@ module Error = struct
let path_not_found path =
condition "path-not-found" "A given path was not found under the specified object"
("path" |=| Concepts.Value.String (to_string path))
+
+ let overlapping_change path =
+ condition "overlapping-change"
+ "A batch of changes both replaced an object and changed inside it"
+ ("path" |=| Concepts.Value.String (to_string path))
end
-let walking f g handle path =
+let walking ?missing f g handle path =
let open Protocols in
let open Utilities.Result in
let rec walk handle = function
@@ -32,7 +37,8 @@ let walking f g handle path =
in
let* elem = Directory.find dir x |> Result.map (Option.map Handle.autorelease) in
match elem with
- | None -> Error (Error.path_not_found path)
+ | None -> (
+ match missing with Some m -> m () | None -> Error (Error.path_not_found path) )
| Some elem -> f x handle (fun () -> walk elem xs) )
in
Handle.with_autorelease (fun () ->
@@ -42,6 +48,13 @@ let walking f g handle path =
let lookup handle path = walking (fun _ _ f -> f ()) Result.ok handle path
+let find handle path =
+ walking
+ ~missing:(fun () -> Ok None)
+ (fun _ _ f -> f ())
+ (fun h -> Ok (Some h))
+ handle path
+
let update handle path key reference value =
let open Utilities.Result in
let open Protocols in
@@ -49,16 +62,116 @@ let update handle path key reference value =
let* registry = Handle.require Registry.from target in
Registry.update registry key reference value
-let assoc handle path key value =
+(* The changes at this object, and those beneath each child they reach. *)
+let split changes =
+ let here, below = List.partition (fun (path, _, _) -> path = []) changes in
+ let segments =
+ List.sort_uniq String.compare (List.map (fun (path, _, _) -> List.hd path) below)
+ in
+ let beneath x =
+ List.filter_map
+ (fun (path, key, value) ->
+ match path with y :: rest when y = x -> Some (rest, key, value) | _ -> None )
+ below
+ in
+ here, List.map (fun x -> x, beneath x) segments
+
+(* What is not there yet is handed over as a directory of what the
+ changes put in it, for its parent to store. *)
+let rec fresh changes =
+ let here, children = split changes in
+ Prototype.(
+ mixture
+ [ Directory.of_properties
+ ( List.filter_map (fun (_, key, value) -> Option.map (fun v -> key, v) value) here
+ @ List.map (fun (x, beneath) -> x, fresh beneath) children ) ] )
+
+let binds changes = List.exists (fun (_, _, value) -> Option.is_some value) changes
+
+(* Changes under the same name are applied to the child together, so
+ every object on the way is derived once however many changes reach
+ it: a batch of changes to a branch is one successor state. *)
+let assoc_all handle changes =
let open Utilities.Result in
- let open Utilities.Fun in
let open Protocols in
- let assoc_on handle key value =
- let* a = Handle.require Associative.from handle in
+ let assoc_on node (key, value) =
+ let* a = Handle.require Associative.from node in
let* a' = Associative.update a key value in
Ok (Handle.from a')
in
- walking
- (fun key dir f -> f () |> fmap (assoc_on dir key |.| Option.some))
- (fun h -> assoc_on h key value)
- handle path
+ let rec apply prefix node changes =
+ let here, below = split changes in
+ let segments = List.map fst below in
+ match List.find_opt (fun (_, key, _) -> List.mem key segments) here with
+ | Some (_, key, _) -> Error (Error.overlapping_change (prefix @ [key]))
+ | None ->
+ let* children =
+ List.map
+ (fun (x, beneath) ->
+ let* dir = Handle.require Directory.from node in
+ let* found = Directory.find dir x in
+ match found with
+ | None when binds beneath -> Ok [x, Some (fresh beneath)]
+ | None -> Ok []
+ | Some child ->
+ Handle.releasing child (fun () -> apply (prefix @ [x]) child beneath)
+ |> Result.map (fun child' -> [x, Some child']) )
+ below
+ |> Utilities.List.sequence
+ |> Result.map List.concat
+ in
+ (* each step derives from the last; only the steps in between are
+ ours to release *)
+ List.fold_left
+ (fun current change ->
+ let* current = current in
+ let* next = assoc_on current change in
+ if current != node then Handle.release current;
+ Ok next )
+ (Ok node)
+ (children @ List.map (fun (_, key, value) -> key, value) here)
+ in
+ apply [] handle changes
+
+let assoc handle path key value = assoc_all handle [path, key, value]
+
+let diff a b =
+ let open Utilities.Result in
+ let open Protocols in
+ let address h = Option.map Addressable.address (Addressable.from h) in
+ let same x y =
+ match address x, address y with
+ | Some p, Some q -> Concepts.Hash.hash_equals p q
+ | _ -> Handle.equal x y
+ in
+ let names h =
+ let* dir = Handle.require Directory.from h in
+ let* names = Directory.list dir in
+ Ok (BatFingerTree.to_list names)
+ in
+ let find h name =
+ let* dir = Handle.require Directory.from h in
+ Directory.find dir name
+ in
+ let rec walk prefix a b =
+ let* left = names a in
+ let* right = names b in
+ List.sort_uniq String.compare (left @ right)
+ |> List.map (fun name ->
+ let path = prefix @ [name] in
+ let* x = find a name in
+ let* y = find b name in
+ Fun.protect
+ ~finally:(fun () -> List.iter Handle.release (Option.to_list x @ Option.to_list y))
+ (fun () ->
+ match x, y with
+ | None, None -> Ok []
+ | Some x, Some y when same x y -> Ok []
+ | Some x, Some y when Directory.from x <> None && Directory.from y <> None ->
+ let* below = walk path x y in
+ Ok (if below = [] then [path] else below)
+ | _ -> Ok [path] ) )
+ |> Utilities.List.sequence
+ |> Result.map List.concat
+ in
+ walk [] a b
diff --git a/lib/kernel/Path.mli b/lib/kernel/Path.mli
index 571e59c..e95505d 100644
--- a/lib/kernel/Path.mli
+++ b/lib/kernel/Path.mli
@@ -4,8 +4,13 @@ val this : t
val ( @/ ) : string -> t -> t
val of_list : string list -> t
val to_list : t -> string list
+val to_string : t -> string
val lookup : Protocols.Handle.t -> t -> (Protocols.Handle.t, Concepts.Condition.condition) result
+(** what [path] reaches, or [None] when some part of it is not there. *)
+val find :
+ Protocols.Handle.t -> t -> (Protocols.Handle.t option, Concepts.Condition.condition) result
+
val update :
Protocols.Handle.t ->
t ->
@@ -14,9 +19,26 @@ val update :
Protocols.Handle.t option ->
(bool, Concepts.Condition.condition) result
+(** [assoc handle path key value] derives [handle] with [key] under
+ [path] bound to [value], or unbound when [None]. *)
val assoc :
Protocols.Handle.t ->
t ->
string ->
Protocols.Handle.t option ->
(Protocols.Handle.t, Concepts.Condition.condition) result
+
+(** every change of [assoc] at once: each object on the way is derived
+ once, so the changes to a branch land as one successor state. An
+ object on the way that is not there yet is handed to its parent as a
+ directory of what the changes put in it. *)
+val assoc_all :
+ Protocols.Handle.t ->
+ (t * string * Protocols.Handle.t option) list ->
+ (Protocols.Handle.t, Concepts.Condition.condition) result
+
+(** the paths, relative to [a] and [b], that differ between them. Equal
+ addresses are not descended, so this costs what changed. Every child
+ is compared, so diff a branch's \multigroup rather than the branch,
+ whose \previous differs whenever anything does. *)
+val diff : Protocols.Handle.t -> Protocols.Handle.t -> (t list, Concepts.Condition.condition) result
diff --git a/lib/kernel/Program.ml b/lib/kernel/Program.ml
new file mode 100644
index 0000000..64a9fcf
--- /dev/null
+++ b/lib/kernel/Program.ml
@@ -0,0 +1,74 @@
+(* A program is an image just like PE, but we represent it as an
+ object. It should have the kind of executable it is, indicating the
+ evaluator needed for it to be executed and a type (generally it can
+ be a tree) that can be interpreted/compiled by said evaluator, and
+ finally the source code in plain text so we can display it for
+ debug. We can persist programs under
+ \system\branch\<b>\multigroup\<m>\program\, but we are not
+ obligated to, they can be merely temporary in memory. *)
+
+module Error = struct
+ open Concepts.Condition
+
+ let unloaded evaluator =
+ condition "unloaded-program" "A program has to be given a root before it can be run"
+ ("evaluator" |=| Concepts.Value.String evaluator)
+
+ let no_evaluator evaluator =
+ condition "no-evaluator" "No evaluator is registered under that name"
+ ("evaluator" |=| Concepts.Value.String evaluator)
+
+ let not_a_program name =
+ condition "not-a-program" "A handle was expected to carry a program and did not"
+ ("object" |=| Concepts.Value.String name)
+end
+
+type kind = Protocols.Evaluator.kind = ..
+type image = {evaluator: string; kind: kind; source: string}
+type Protocols.Handle.protocol += Program of image
+
+let image handle =
+ Protocols.Handle.into handle (function Program image -> Some image | _ -> None)
+ |> Option.map (fun i -> Protocols.Handle.invoke i Fun.id)
+
+let reference evaluator =
+ match String.rindex_opt evaluator ':' with
+ | None -> "system", evaluator
+ | Some i ->
+ String.sub evaluator 0 i, String.sub evaluator (i + 1) (String.length evaluator - i - 1)
+
+let require handle =
+ image handle |> Option.to_result ~none:(Error.not_a_program (Protocols.Handle.to_string handle))
+
+let with_evaluator root evaluator f =
+ let open Utilities.Result in
+ let scope, language = reference evaluator in
+ let* found =
+ Path.lookup root Path.(scope @/ "evaluator" @/ language @/ this)
+ |> Result.map_error (fun _ -> Error.no_evaluator evaluator)
+ in
+ Protocols.Handle.releasing found (fun () -> Result.bind (Protocols.Evaluator.require found) f)
+
+class program ?root image =
+ object (self)
+ inherit Lifecycle.null
+ inherit Identity.of_id
+ method to_string = image.source
+
+ method invoke inputs ~within =
+ let open Utilities.Result in
+ let* root = Option.to_result ~none:(Error.unloaded image.evaluator) root in
+ with_evaluator root image.evaluator (fun evaluator ->
+ Protocols.Evaluator.eval evaluator image.kind inputs ~within )
+
+ method protocols : Protocols.Handle.protocol list =
+ [Program image; Protocols.Executable.make self]
+ end
+
+let make ?root ~evaluator ~source kind =
+ new program ?root {evaluator; kind; source} |> Protocols.Handle.make
+
+let load root ~evaluator ~source =
+ with_evaluator root evaluator (fun found ->
+ Protocols.Evaluator.parse found source
+ |> Result.map (make ~root ~evaluator ~source) )
diff --git a/lib/kernel/Prototype.ml b/lib/kernel/Prototype.ml
index 4c96bc3..ea1083b 100644
--- a/lib/kernel/Prototype.ml
+++ b/lib/kernel/Prototype.ml
@@ -47,24 +47,38 @@ module Associative = struct
let update_only f = function None -> Error (Error.deletion_not_supported ()) | Some x -> f x
+ type 'tx admission = 'tx -> (Concepts.Hash.hash, Concepts.Condition.condition) result
+
+ (* A value with no address yet is [admit]ted: it is read here, before
+ the write begins, since reading it may itself need storage, and
+ stored by the write. *)
+ let admission admit key h =
+ match Protocols.Addressable.from h with
+ | Some a ->
+ let addr = Protocols.Addressable.address a in
+ Ok (fun _ -> Ok addr)
+ | None -> admit key h
+
module OfTree (S : Abstract.Storage.STORAGE) (K : Merkle.KEY with type t = string) = struct
module Tree = Merkle.Make (S) (K)
module SI = Storage.Make (S)
- let make ~storage ~constructor ~node =
+ let make ~admit ~storage ~constructor ~node =
Protocols.Associative.make
@@ object
method update key value =
- (* TODO: read-only transactions *)
+ let open Utilities.Result in
+ let* store =
+ match value with
+ | None -> Ok None
+ | Some h -> admission admit key h |> Result.map Option.some
+ in
SI.with_transaction storage (fun tx ->
- let open Utilities.Result in
- let open Protocols in
let* node' =
- match value with
+ match store with
| None -> Tree.remove tx key node
- | Some h ->
- let* addressable = Handle.require Addressable.from h in
- let addr = Addressable.address addressable in
+ | Some store ->
+ let* addr = store tx in
Tree.insert tx key addr node
in
constructor node' )
@@ -81,6 +95,17 @@ module Directory = struct
method find k = Ok (BatMap.find_opt k props)
end
+ let children directory =
+ let open Utilities.Result in
+ let* listing = Protocols.Handle.require Protocols.Directory.from directory in
+ let* names = Protocols.Directory.list listing in
+ BatFingerTree.to_list names
+ |> List.map (fun name ->
+ let* found = Protocols.Directory.find listing name in
+ Ok (Option.map (fun child -> name, child) found) )
+ |> Utilities.List.sequence
+ |> Result.map (List.filter_map Fun.id)
+
module OfTree
(S : Abstract.Storage.STORAGE)
(K : Merkle.KEY with type t = string)
@@ -92,10 +117,10 @@ module Directory = struct
let make ~storage ~constructor ~node =
Protocols.Directory.make
@@ object
- method list = SI.with_transaction storage (Fun.flip Tree.keys node)
+ method list = SI.with_read storage (Fun.flip Tree.keys node)
method find k =
- SI.with_transaction storage (fun tx -> Tree.lookup tx k node)
+ SI.with_read storage (fun tx -> Tree.lookup tx k node)
|> Utilities.Result.fmap (function
| None -> Ok None
| Some x -> constructor x |> Result.map Option.some )
diff --git a/lib/kernel/Prototype.mli b/lib/kernel/Prototype.mli
index db22b63..9c446fc 100644
--- a/lib/kernel/Prototype.mli
+++ b/lib/kernel/Prototype.mli
@@ -6,6 +6,10 @@ val mixture : Protocols.Handle.protocol list -> Protocols.Handle.t
module Directory : sig
val of_properties : (string * Protocols.Handle.t) list -> Protocols.Handle.protocol
+ (** the names a directory lists, and what each reaches. *)
+ val children :
+ Protocols.Handle.t -> ((string * Protocols.Handle.t) list, Concepts.Condition.condition) result
+
module OfTree
(S : Abstract.Storage.STORAGE)
(K : Merkle.KEY with type t = string)
@@ -32,10 +36,26 @@ module Associative : sig
Protocols.Handle.t option ->
(Protocols.Handle.t, Concepts.Condition.condition) result
+ (** how a value is stored once a write has begun, giving its address. *)
+ type 'tx admission = 'tx -> (Concepts.Hash.hash, Concepts.Condition.condition) result
+
+ (** a value with an address is stored as that address; [admit] reads
+ one with none, before the write begins, into an admission. *)
+ val admission :
+ (string -> Protocols.Handle.t -> ('tx admission, Concepts.Condition.condition) result) ->
+ string ->
+ Protocols.Handle.t ->
+ ('tx admission, Concepts.Condition.condition) result
+
module OfTree (S : Abstract.Storage.STORAGE) (K : Merkle.KEY with type t = string) : sig
module Tree : module type of Merkle.Make (S) (K)
+ (** a value bound under a key is stored as its [admission]. *)
val make :
+ admit:
+ (string ->
+ Protocols.Handle.t ->
+ (S.transaction admission, Concepts.Condition.condition) result ) ->
storage:S.connection ->
constructor:(Tree.node -> (Protocols.Handle.t, Concepts.Condition.condition) result) ->
node:Tree.node ->
diff --git a/lib/kernel/Scope.ml b/lib/kernel/Scope.ml
new file mode 100644
index 0000000..23698ba
--- /dev/null
+++ b/lib/kernel/Scope.ml
@@ -0,0 +1,152 @@
+type home = {multigroup: string; schema: string}
+
+class type implementation = object
+ method branch : Protocols.Handle.t
+ method home : home
+ method previous : (Protocols.Handle.t option, Concepts.Condition.condition) result
+ method catalog : (string list, Concepts.Condition.condition) result
+end
+
+type Protocols.Handle.protocol += Scope of implementation
+
+let require handle =
+ Protocols.Handle.into handle (function Scope i -> Some i | _ -> None)
+ |> Option.to_result
+ ~none:
+ Concepts.Condition.(
+ condition "not-a-scope" "A handle was expected to be a branch state read from a home"
+ empty )
+
+let relations {multigroup; schema} =
+ Path.("multigroup" @/ multigroup @/ "schema" @/ schema @/ "relation" @/ this)
+
+let path home relation = Path.(of_list (to_list (relations home) @ [relation]))
+let denial multigroup = Path.("multigroup" @/ multigroup @/ "denial" @/ this)
+
+(* A name leaves out, from the left, what it shares with its home. *)
+let resolve home text =
+ match String.split_on_char ':' text with
+ | names when List.mem "" names -> None
+ | [r] -> Some (home, r)
+ | [s; r] -> Some ({home with schema= s}, r)
+ | [m; s; r] -> Some ({multigroup= m; schema= s}, r)
+ | _ -> None
+
+let locate home text = Option.map (fun (h, r) -> path h r) (resolve home text)
+
+let attribute home relation text =
+ match List.rev (String.split_on_char ':' text) with
+ | [a] -> Some a
+ | a :: rest when resolve home (String.concat ":" (List.rev rest)) = resolve home relation ->
+ Some a
+ | _ -> None
+
+(* every relation of a branch state, as multigroup:schema:relation *)
+let catalog_of branch =
+ let open Utilities.Result in
+ let name prefix last = String.concat ":" (List.rev (last :: prefix)) in
+ let rec down prefix handle properties =
+ let* level = Path.find handle Path.(List.hd properties @/ this) in
+ match level, List.tl properties with
+ | None, _ -> Ok []
+ | Some level, [] ->
+ let* listing = Protocols.Handle.require Protocols.Directory.from level in
+ let* names = Protocols.Directory.list listing in
+ Ok (List.map (name prefix) (BatFingerTree.to_list names))
+ | Some level, rest ->
+ let* named = Prototype.Directory.children level in
+ List.map (fun (n, child) -> down (n :: prefix) child rest) named
+ |> Utilities.List.sequence
+ |> Result.map List.concat
+ in
+ down [] branch ["multigroup"; "schema"; "relation"]
+
+let rec make branch home =
+ Prototype.mixture
+ [ Protocols.Directory.make
+ object
+ method list =
+ let open Utilities.Result in
+ let* found = Path.find branch (relations home) in
+ match found with
+ | None -> Ok BatFingerTree.empty
+ | Some found ->
+ let* listing = Protocols.Handle.require Protocols.Directory.from found in
+ Protocols.Directory.list listing
+
+ (* what is not a relation's name names no relation here *)
+ method find text =
+ match resolve home text with
+ | None -> Ok None
+ | Some (h, r) -> Path.find branch (path h r)
+ end;
+ Scope
+ object
+ method branch = branch
+ method home = home
+
+ method previous =
+ let open Utilities.Result in
+ let* previous = Path.find branch Path.("previous" @/ this) in
+ Ok (Option.map (fun p -> make p home) previous)
+
+ method catalog = catalog_of branch
+ end ]
+
+let heads = Path.("system" @/ "branch" @/ this)
+
+let of_root root ~branch home =
+ let open Utilities.Result in
+ let* state = Path.lookup root Path.("system" @/ "branch" @/ branch @/ this) in
+ Ok (make state home)
+
+let branch i = Protocols.Handle.invoke i (fun o -> o#branch)
+let home i = Protocols.Handle.invoke i (fun o -> o#home)
+let previous i = Protocols.Handle.invoke i (fun o -> o#previous)
+let catalog i = Protocols.Handle.invoke i (fun o -> o#catalog)
+
+module Error = struct
+ open Concepts.Condition
+
+ let malformed name =
+ condition "malformed-name"
+ "A relation is named relation, schema:relation or multigroup:schema:relation"
+ ("name" |=| Concepts.Value.String name)
+
+ let malformed_denial name =
+ condition "malformed-name" "A denial is named denial or multigroup:denial"
+ ("name" |=| Concepts.Value.String name)
+
+ let moved branch =
+ condition "serialization-conflict" "The branch moved on while this commit was made; retry it"
+ ("branch" |=| Concepts.Value.String branch)
+end
+
+let publish ?(denials = []) root ~branch ~home bindings =
+ let open Utilities.Result in
+ let* changes =
+ List.map
+ (fun (name, v) ->
+ match resolve home name with
+ | Some (h, r) -> Ok (relations h, r, v)
+ | None -> Error (Error.malformed name) )
+ bindings
+ |> Utilities.List.sequence
+ in
+ let* denied =
+ List.map
+ (fun (name, v) ->
+ match String.split_on_char ':' name with
+ | [d] when d <> "" -> Ok (denial home.multigroup, d, v)
+ | [m; d] when m <> "" && d <> "" -> Ok (denial m, d, v)
+ | _ -> Error (Error.malformed_denial name) )
+ denials
+ |> Utilities.List.sequence
+ in
+ let changes = changes @ denied in
+ if List.is_empty changes then Ok ()
+ else
+ let* state = Path.lookup root Path.("system" @/ "branch" @/ branch @/ this) in
+ let* next = Path.assoc_all state changes in
+ let* landed = Path.update root heads branch (Some state) (Some next) in
+ if landed then Ok () else Error (Error.moved branch)
diff --git a/lib/kernel/Scope.mli b/lib/kernel/Scope.mli
new file mode 100644
index 0000000..83b3309
--- /dev/null
+++ b/lib/kernel/Scope.mli
@@ -0,0 +1,71 @@
+(** A branch state read from a home: a [Directory] of relations where
+ [R] names the home schema's, [s:R] a schema's of the home multigroup,
+ and [m:s:R] anyone's in the branch state. It lists the home schema. *)
+
+type home = {multigroup: string; schema: string}
+
+class type implementation = object
+ (** the branch state read *)
+ method branch : Protocols.Handle.t
+
+ method home : home
+
+ (** the same home in the state before, if there is one *)
+ method previous : (Protocols.Handle.t option, Concepts.Condition.condition) result
+
+ (** every relation of the branch state, as [m:s:R] *)
+ method catalog : (string list, Concepts.Condition.condition) result
+end
+
+type Protocols.Handle.protocol += Scope of implementation
+
+val make : Protocols.Handle.t -> home -> Protocols.Handle.t
+
+(** [home] in the head of \system\branch\[branch]. *)
+val of_root :
+ Protocols.Handle.t ->
+ branch:string ->
+ home ->
+ (Protocols.Handle.t, Concepts.Condition.condition) result
+
+val require :
+ Protocols.Handle.t ->
+ (implementation Protocols.Handle.interface, Concepts.Condition.condition) result
+
+val branch : implementation Protocols.Handle.interface -> Protocols.Handle.t
+val home : implementation Protocols.Handle.interface -> home
+
+val previous :
+ implementation Protocols.Handle.interface ->
+ (Protocols.Handle.t option, Concepts.Condition.condition) result
+
+val catalog :
+ implementation Protocols.Handle.interface -> (string list, Concepts.Condition.condition) result
+
+(** \multigroup\[m]\schema\[s]\relation, from a branch state. *)
+val relations : home -> Path.t
+
+(** \multigroup\[m]\schema\[s]\relation\[relation], from a branch state. *)
+val path : home -> string -> Path.t
+
+(** where [text] names a relation, read from [home], from a branch state. *)
+val locate : home -> string -> Path.t option
+
+(** the attribute [text] names of the relation named [relation], both read
+ from [home]: bare, or qualified with a name of that relation. *)
+val attribute : home -> string -> string -> string option
+
+(** bind each named relation to its value, or unbind it on [None], in the
+ head of \system\branch\[branch], as one successor state. A multigroup
+ or schema not there yet is made, and a value with no address is
+ stored as a schema stores it: a program as itself, a relation as its
+ tuples. [denials] are named [d], in
+ \denial of the home multigroup, or [m:d], in that of [m]. If the head moved meanwhile, or a multigroup does not
+ admit the state, nothing changes, and it fails. *)
+val publish :
+ ?denials:(string * Protocols.Handle.t option) list ->
+ Protocols.Handle.t ->
+ branch:string ->
+ home:home ->
+ (string * Protocols.Handle.t option) list ->
+ (unit, Concepts.Condition.condition) result
diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml
index 57bb79e..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
@@ -134,6 +141,22 @@ module Make (S : Abstract.Storage.STORAGE) = struct
|> Result.map (fun description ->
new substantial_relation connection relation description |> Protocols.Handle.make )
+ let store tx description tuples =
+ let open Utilities.Result in
+ let* schematics = store_schema tx description in
+ let* _ = TupleSet.empty_under tx in
+ let* node =
+ TupleSet.with_batch tx (fun () ->
+ List.fold_left
+ (fun node tuple ->
+ let* node = node in
+ TupleSet.insert tx (Concepts.Tuple.hash tuple) tuple node )
+ (Ok TupleSet.empty) tuples )
+ in
+ let relation = {schematics; tuples= TupleSet.hash_of node} in
+ let* _ = SI.store_blob tx (encode relation) in
+ Ok relation
+
let instantiate connection ~schematics =
let open Utilities.Result in
let* relation =
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-06 11:25:54 +0000