aboutsummaryrefslogtreecommitdiffstats
path: root/lib/kernel
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/kernel/Journal.ml198
-rw-r--r--lib/kernel/Journal.mli22
-rw-r--r--lib/kernel/Source.ml58
-rw-r--r--lib/kernel/Source.mli32
-rw-r--r--lib/kernel/View.ml44
-rw-r--r--lib/kernel/View.mli21
6 files changed, 375 insertions, 0 deletions
diff --git a/lib/kernel/Journal.ml b/lib/kernel/Journal.ml
new file mode 100644
index 0000000..13782a5
--- /dev/null
+++ b/lib/kernel/Journal.ml
@@ -0,0 +1,198 @@
+module J = Protocols.Journal
+module Bindings = BatMap.String
+
+module Error = struct
+ open Concepts.Condition
+
+ let empty_commit () = condition "empty-commit" "A commit has to change at least one name" empty
+
+ let repeated_name name =
+ condition "repeated-name" "A commit names the same binding twice"
+ ("name" |=| Concepts.Value.String name)
+end
+
+(* A snapshot is named by its bindings, so two snapshots binding the
+ same objects are the same snapshot. *)
+let identity bindings =
+ Bindings.fold
+ (fun name handle acc ->
+ name :: Concepts.Hash.to_raw_string (Protocols.Handle.hash handle) :: acc )
+ bindings []
+ |> String.concat "\000"
+ |> Bytes.of_string
+ |> Concepts.Hash.hash_of_bytes
+
+class snapshot bindings =
+ object (self)
+ inherit Lifecycle.null
+ method to_string = "snapshot"
+ method hash = identity bindings
+ val mutable handle : Protocols.Handle.t option = None
+ method protocols : Protocols.Handle.protocol list = [Protocols.Directory.make self]
+ method list = Ok (Bindings.keys bindings |> BatFingerTree.of_enum)
+
+ method find name =
+ match Bindings.find_opt name bindings with
+ | None -> Ok None
+ | Some bound -> (
+ match Protocols.Derived.from bound, handle with
+ | Some derived, Some me -> Protocols.Derived.within derived me |> Result.map Option.some
+ | _ -> Ok (Protocols.Handle.copy bound) )
+
+ method attach me = handle <- Some me
+ end
+
+let snapshot_of bindings =
+ let o = new snapshot bindings in
+ let handle = Protocols.Handle.make o in
+ o#attach handle; handle
+
+let snapshot bindings = snapshot_of (Bindings.of_list bindings)
+
+type state = {commit: J.commit; bindings: Protocols.Handle.t Bindings.t}
+
+class journal bindings =
+ object (self)
+ inherit Lifecycle.null
+ inherit Identity.of_id
+ method to_string = "journal"
+ val lock = Mutex.create ()
+
+ (* the latest first *)
+ val mutable states =
+ [ { commit=
+ { J.number= 0;
+ snapshot= snapshot_of bindings;
+ changed= Bindings.keys bindings |> BatList.of_enum };
+ bindings } ]
+
+ val mutable guards : (string * J.guard) list = []
+ val mutable observers : (string * J.observer) list = []
+
+ method protocols : Protocols.Handle.protocol list =
+ Protocols.[Directory.make self; Registry.make self; J.make self]
+
+ method head = (List.hd states).commit
+ method history = List.rev_map (fun {commit; _} -> commit) states
+
+ method guard name g =
+ Mutex.protect lock (fun () ->
+ guards <-
+ List.remove_assoc name guards @ Option.fold ~none:[] ~some:(fun g -> [name, g]) g )
+
+ method observe name f =
+ Mutex.protect lock (fun () ->
+ observers <-
+ List.remove_assoc name observers @ Option.fold ~none:[] ~some:(fun f -> [name, f]) f )
+
+ method list = Ok (Bindings.keys (List.hd states).bindings |> BatFingerTree.of_enum)
+
+ method find name =
+ Ok
+ ( Bindings.find_opt name (List.hd states).bindings
+ |> Utilities.Option.fmap Protocols.Handle.copy )
+
+ method update name expected replacement =
+ self#commit [{J.name; expected; replacement}] |> Result.map Option.is_some
+
+ (* Guards run in the order they were installed, and observers after
+ the commit has landed, both while holding the journal, so they
+ see commits one at a time and in order. *)
+ method commit (changes : J.change list) =
+ let open Utilities.Result in
+ let names = List.map (fun (c : J.change) -> c.name) changes in
+ let repeated =
+ List.find_opt (fun n -> List.length (List.filter (String.equal n) names) > 1) names
+ in
+ match changes, repeated with
+ | [], _ -> Error (Error.empty_commit ())
+ | _, Some name -> Error (Error.repeated_name name)
+ | _ ->
+ Mutex.protect lock (fun () ->
+ let current = List.hd states in
+ let expected (c : J.change) =
+ Bindings.find_opt c.name current.bindings = c.expected
+ in
+ if not (List.for_all expected changes) then Ok None
+ else
+ let bindings =
+ List.fold_left
+ (fun bindings (c : J.change) ->
+ match c.replacement with
+ | Some h -> Bindings.add c.name h bindings
+ | None -> Bindings.remove c.name bindings )
+ current.bindings changes
+ in
+ let commit =
+ { J.number= current.commit.number + 1;
+ snapshot= snapshot_of bindings;
+ changed= names }
+ in
+ let proposal = {J.previous= current.commit; proposed= commit} in
+ let* () =
+ List.fold_left
+ (fun acc (_, g) ->
+ let* () = acc in
+ g proposal )
+ (Ok ()) guards
+ in
+ states <- {commit; bindings} :: states;
+ List.iter (fun (_, f) -> f commit) observers;
+ Ok (Some commit) )
+ end
+
+let make ?(bindings = []) () = Protocols.Handle.make (new journal (Bindings.of_list bindings))
+
+let adopt directory =
+ let open Utilities.Result in
+ let* listing = Protocols.Handle.require Protocols.Directory.from directory in
+ let* names = Protocols.Directory.list listing in
+ let* bindings =
+ BatFingerTree.to_list names
+ |> List.map (fun name ->
+ let* found = Protocols.Directory.find listing name in
+ Ok (Option.map (fun h -> name, h) found) )
+ |> Utilities.List.sequence
+ in
+ Ok (make ~bindings:(List.filter_map Fun.id bindings) ())
+
+(* What a name is bound to is read as a copy, which has to stay valid
+ until the swap has compared against it. *)
+let rebind directory bindings =
+ let open Utilities.Result in
+ let* listing = Protocols.Handle.require Protocols.Directory.from directory in
+ let holding names f =
+ let* found =
+ List.map (fun name -> Protocols.Directory.find listing name) names |> Utilities.List.sequence
+ in
+ Fun.protect
+ ~finally:(fun () -> List.iter (Option.iter Protocols.Handle.release) found)
+ (fun () -> f found)
+ in
+ let rec together journal =
+ let* landed =
+ holding (List.map fst bindings) (fun found ->
+ List.map2
+ (fun (name, replacement) expected -> {J.name; expected; replacement})
+ bindings found
+ |> J.commit journal )
+ in
+ match landed with Some _ -> Ok () | None -> together journal
+ in
+ let rec one registry name replacement =
+ let* swapped =
+ holding [name] (fun found ->
+ Protocols.Registry.update registry name (List.hd found) replacement )
+ in
+ if swapped then Ok () else one registry name replacement
+ in
+ match J.from directory, bindings with
+ | _, [] -> Ok ()
+ | Some journal, _ -> together journal
+ | None, _ ->
+ let* registry = Protocols.Handle.require Protocols.Registry.from directory in
+ List.fold_left
+ (fun acc (name, replacement) ->
+ let* () = acc in
+ one registry name replacement )
+ (Ok ()) bindings
diff --git a/lib/kernel/Journal.mli b/lib/kernel/Journal.mli
new file mode 100644
index 0000000..d354e03
--- /dev/null
+++ b/lib/kernel/Journal.mli
@@ -0,0 +1,22 @@
+(** a namespace that keeps its history: each binding it accepts is a
+ commit of [Protocols.Journal]. It answers [Directory] and [Registry]
+ as a plain namespace does, so a subsystem that only knows those
+ commits without knowing it. *)
+
+(** a journal whose first commit, numbered 0, binds [bindings]. *)
+val make : ?bindings:(string * Protocols.Handle.t) list -> unit -> Protocols.Handle.t
+
+(** a journal whose first commit binds whatever [directory] binds now. *)
+val adopt : Protocols.Handle.t -> (Protocols.Handle.t, Concepts.Condition.condition) result
+
+(** a directory of [bindings] that, asked for a derived relation, hands
+ it out read against itself. *)
+val snapshot : (string * Protocols.Handle.t) list -> Protocols.Handle.t
+
+(** bind each name to its handle, or unbind it, whatever it was bound to
+ before: as one commit when [directory] is a journal, and one name at
+ a time when it is a plain namespace. *)
+val rebind :
+ Protocols.Handle.t ->
+ (string * Protocols.Handle.t option) list ->
+ (unit, Concepts.Condition.condition) result
diff --git a/lib/kernel/Source.ml b/lib/kernel/Source.ml
new file mode 100644
index 0000000..b3b7389
--- /dev/null
+++ b/lib/kernel/Source.ml
@@ -0,0 +1,58 @@
+let program ~language text =
+ Prototype.mixture
+ [ EphemeralRelation.Stored
+ {evaluator= language; code= Concepts.Blob.blob_of_bytes (Bytes.of_string text)} ]
+
+let text handle =
+ Protocols.Handle.into handle (function
+ | EphemeralRelation.Stored {evaluator; code} ->
+ Some (evaluator, Bytes.to_string (Concepts.Blob.bytes_of_blob code))
+ | _ -> None )
+ |> Option.map (fun i -> Protocols.Handle.invoke i Fun.id)
+
+module Error = struct
+ open Concepts.Condition
+
+ let not_a_program language =
+ condition "not-a-program" "An evaluator was given something that carries no source"
+ ("language" |=| Concepts.Value.String language)
+
+ let foreign language given =
+ condition "foreign-program" "An evaluator was given source in another language"
+ ("language" |=| Concepts.Value.String language & "given" |=| Concepts.Value.String given)
+
+ let no_evaluator language =
+ condition "no-evaluator" "No evaluator is registered for the language"
+ ("language" |=| Concepts.Value.String language)
+end
+
+let evaluator ~language run =
+ Protocols.Handle.make
+ object (self)
+ inherit Lifecycle.null
+ inherit Identity.of_id
+ method to_string = language ^ "-evaluator"
+ method protocols : Protocols.Handle.protocol list = [Protocols.Evaluator.make self]
+
+ method invoke program =
+ match text program with
+ | None -> Error (Error.not_a_program language)
+ | Some (given, _) when given <> language -> Error (Error.foreign language given)
+ | Some (_, source) -> run source
+ end
+
+let run root ~language source =
+ let open Utilities.Result in
+ let* evaluator =
+ Path.lookup root Path.("evaluator" @/ language @/ this)
+ |> Result.map_error (fun _ -> Error.no_evaluator language)
+ in
+ let* evaluator = Protocols.Evaluator.require evaluator in
+ Protocols.Evaluator.invoke evaluator (program ~language source)
+
+let register root ~language evaluator =
+ let open Utilities.Result in
+ let* evaluators = Path.lookup root Path.("evaluator" @/ this) in
+ let* registry = Protocols.Handle.require Protocols.Registry.from evaluators in
+ let* _ = Protocols.Registry.update registry language None (Some evaluator) in
+ Ok ()
diff --git a/lib/kernel/Source.mli b/lib/kernel/Source.mli
new file mode 100644
index 0000000..1a51da2
--- /dev/null
+++ b/lib/kernel/Source.mli
@@ -0,0 +1,32 @@
+(** programs as source. A program in any language travels the tree as a
+ handle carrying [EphemeralRelation.Stored], with its text as the code,
+ so whoever holds one can run it through the evaluator of its language
+ without linking that language. *)
+
+(** a program in [language]. *)
+val program : language:string -> string -> Protocols.Handle.t
+
+(** the language and text a handle carries, if it is a program. *)
+val text : Protocols.Handle.t -> (string * string) option
+
+(** an evaluator for [language]: it runs the text of a program in that
+ language, and refuses anything else. *)
+val evaluator :
+ language:string ->
+ (string -> (Protocols.Handle.t, Concepts.Condition.condition) result) ->
+ Protocols.Handle.t
+
+(** look up the evaluator of [language] under [root]'s \evaluator and run
+ [text] with it. *)
+val run :
+ Protocols.Handle.t ->
+ language:string ->
+ string ->
+ (Protocols.Handle.t, Concepts.Condition.condition) result
+
+(** register [evaluator] as \evaluator\[language] under [root]. *)
+val register :
+ Protocols.Handle.t ->
+ language:string ->
+ Protocols.Handle.t ->
+ (unit, Concepts.Condition.condition) result
diff --git a/lib/kernel/View.ml b/lib/kernel/View.ml
new file mode 100644
index 0000000..b90afef
--- /dev/null
+++ b/lib/kernel/View.ml
@@ -0,0 +1,44 @@
+type heading = Protocols.Schematics.attribute_description BatMap.String.t
+type rows = (Concepts.Tuple.t list, Concepts.Condition.condition) result
+
+let ephemeral heading enumerate =
+ EphemeralRelation.instantiate heading
+ {EphemeralRelation.name= None; schematics= `Temporary heading; program= None}
+ (fun () ->
+ Result.map
+ (fun tuples -> Generator.cursor_of (fun ~yield -> List.iter yield tuples; Ok ()))
+ (enumerate ()) )
+
+let fixed heading tuples = ephemeral heading (fun () -> Ok tuples)
+
+let computed heading ~current compute =
+ let open Utilities.Result in
+ let now = ephemeral heading (fun () -> current () |> fmap compute) in
+ Prototype.mixture
+ ( Protocols.Derived.make
+ object
+ method within directory = Ok (ephemeral heading (fun () -> compute directory))
+ end
+ :: Protocols.Handle.protocols now )
+
+let read relation =
+ let open Utilities.Result in
+ let* schematics = Protocols.Handle.require Protocols.Schematics.from relation in
+ let* description = Protocols.Schematics.describe schematics in
+ let* heading =
+ match description with
+ | Protocols.Schematics.Relation heading -> Ok heading
+ | _ ->
+ Error
+ Concepts.Condition.(
+ condition "not-a-relation" "The object does not describe itself as a relation"
+ ("object" |=| Concepts.Value.String (Protocols.Handle.to_string relation)) )
+ in
+ let* enumerable = Protocols.Enumerable.require relation in
+ let* cursor = Protocols.Enumerable.enumerate enumerable in
+ Fun.protect
+ ~finally:(fun () -> Protocols.Handle.release cursor)
+ (fun () ->
+ let* scan = Protocols.Cursor.require cursor in
+ let* tuples = Protocols.Cursor.drain scan () in
+ Ok (heading, BatFingerTree.to_list tuples) )
diff --git a/lib/kernel/View.mli b/lib/kernel/View.mli
new file mode 100644
index 0000000..04e75ff
--- /dev/null
+++ b/lib/kernel/View.mli
@@ -0,0 +1,21 @@
+(** relations as values a subsystem hands to the tree. *)
+
+type heading = Protocols.Schematics.attribute_description BatMap.String.t
+type rows = (Concepts.Tuple.t list, Concepts.Condition.condition) result
+
+(** a relation holding [tuples], which never changes. *)
+val fixed : heading -> Concepts.Tuple.t list -> Protocols.Handle.t
+
+(** a relation computed from a directory of relations. Read as it is, it
+ is computed against [current ()] each time; read through a snapshot,
+ it is computed against the snapshot instead (see [Protocols.Derived]),
+ so it is what it was, or would be, at that moment. *)
+val computed :
+ heading ->
+ current:(unit -> (Protocols.Handle.t, Concepts.Condition.condition) result) ->
+ (Protocols.Handle.t -> rows) ->
+ Protocols.Handle.t
+
+(** the heading and tuples of a relation, read whole. *)
+val read :
+ Protocols.Handle.t -> (heading * Concepts.Tuple.t list, Concepts.Condition.condition) result
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 19:26:34 +0000