From 8f5a9291647d53dd3a912853f5c230cdcb13cb74 Mon Sep 17 00:00:00 2001 From: Marcos Magueta Date: Wed, 7 Oct 2026 23:29:38 -0300 Subject: scope and source for evaluators --- lib/kernel/Scope.ml | 148 ++++++++++++++++++++++++++++++++++++++++++++++++++ lib/kernel/Scope.mli | 65 ++++++++++++++++++++++ lib/kernel/Source.ml | 82 ++++++++++++++++++---------- lib/kernel/Source.mli | 48 +++++++++++----- 4 files changed, 298 insertions(+), 45 deletions(-) create mode 100644 lib/kernel/Scope.ml create mode 100644 lib/kernel/Scope.mli (limited to 'lib/kernel') diff --git a/lib/kernel/Scope.ml b/lib/kernel/Scope.ml new file mode 100644 index 0000000..cfba6b3 --- /dev/null +++ b/lib/kernel/Scope.ml @@ -0,0 +1,148 @@ +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])) + +(* 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 + +(* the names a directory lists, and what each reaches *) +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) + +(* 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 = 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 moved branch = + condition "serialization-conflict" "The branch moved on while this commit was made; retry it" + ("branch" |=| Concepts.Value.String branch) +end + +let publish 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 + 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..aabdc61 --- /dev/null +++ b/lib/kernel/Scope.mli @@ -0,0 +1,65 @@ +(** 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\[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. If the head moved meanwhile nothing changes, and it fails. *) +val publish : + Protocols.Handle.t -> + branch:string -> + home:home -> + (string * Protocols.Handle.t option) list -> + (unit, Concepts.Condition.condition) result diff --git a/lib/kernel/Source.ml b/lib/kernel/Source.ml index e5de6e8..16d2b04 100644 --- a/lib/kernel/Source.ml +++ b/lib/kernel/Source.ml @@ -1,14 +1,32 @@ -let program ~language text = +let blob text = Concepts.Blob.blob_of_bytes (Bytes.of_string text) + +let stored_text ~language text = + EphemeralRelation.Stored {evaluator= language; code= blob text; name= None} + +let program ~language text = Prototype.mixture [stored_text ~language text] + +let view ~language ~heading text = Prototype.mixture - [ EphemeralRelation.Stored - {evaluator= language; code= Concepts.Blob.blob_of_bytes (Bytes.of_string text)} ] + [ stored_text ~language text; + Protocols.Schematics.make + object + method describe () = Ok (Protocols.Schematics.Relation heading) + end ] + +let stored handle = + EphemeralRelation.stored handle + |> Option.map (fun (evaluator, code, name) -> + evaluator, Bytes.to_string (Concepts.Blob.bytes_of_blob code), name ) -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) +let text handle = Option.map (fun (evaluator, text, _) -> evaluator, text) (stored handle) + +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 language_of evaluator = snd (reference evaluator) module Error = struct open Concepts.Condition @@ -21,12 +39,12 @@ module Error = struct 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) + let no_evaluator evaluator = + condition "no-evaluator" "No evaluator is registered under that name" + ("evaluator" |=| Concepts.Value.String evaluator) end -let evaluator ~language run = +let evaluator ~language ?view run = Protocols.Handle.make object (self) inherit Lifecycle.null @@ -35,34 +53,38 @@ let evaluator ~language run = method protocols : Protocols.Handle.protocol list = [Protocols.Evaluator.make self] method invoke program ~within = - match text program with + match stored program with | None -> Error (Error.not_a_program language) - | Some (given, _) when given <> language -> Error (Error.foreign language given) - | Some (_, source) -> run ~within source + | Some (given, _, _) when language_of given <> language -> + Error (Error.foreign language given) + | Some (_, source, name) -> ( + match name, view with + | Some name, Some view -> view ~within ~name source + | _ -> run ~within source ) end -let evaluators = Path.("system" @/ "evaluator" @/ this) +let evaluators scope = Path.(scope @/ "evaluator" @/ this) -let bind directory ~within language program = +let bind root ~within evaluator program = let open Utilities.Result in - let* evaluator = - Path.lookup directory Path.(language @/ this) - |> Result.map_error (fun _ -> Error.no_evaluator language) + let scope, language = reference evaluator in + let* found = + Result.bind + (Path.lookup root (evaluators scope)) + (fun directory -> Path.lookup directory Path.(language @/ this)) + |> Result.map_error (fun _ -> Error.no_evaluator evaluator) in Fun.protect - ~finally:(fun () -> Protocols.Handle.release evaluator) + ~finally:(fun () -> Protocols.Handle.release found) (fun () -> - let* evaluator = Protocols.Evaluator.require evaluator in - Protocols.Evaluator.invoke evaluator program ~within ) + let* found = Protocols.Evaluator.require found in + Protocols.Evaluator.invoke found program ~within ) -let run root ~language ~within source = - let open Utilities.Result in - let* directory = Path.lookup root evaluators in - bind directory ~within language (program ~language source) +let run root ~language ~within source = bind root ~within language (program ~language source) -let register root ~language evaluator = +let register root ~scope ~language evaluator = let open Utilities.Result in - let* directory = Path.lookup root evaluators in + let* directory = Path.lookup root (evaluators scope) in let* registry = Protocols.Handle.require Protocols.Registry.from directory in let* _ = Protocols.Registry.update registry language None (Some evaluator) in Ok () diff --git a/lib/kernel/Source.mli b/lib/kernel/Source.mli index 0961dcc..b0479f2 100644 --- a/lib/kernel/Source.mli +++ b/lib/kernel/Source.mli @@ -1,28 +1,45 @@ (** 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. *) + without linking that language. -(** a program in [language]. *) + An evaluator is named [scope:language] and registered at + \[scope]\evaluator\[language]; a bare [language] is the system's. *) + +(** a program in [language], to run. *) val program : language:string -> string -> Protocols.Handle.t -(** the language and text a handle carries, if it is a program. *) +(** a program in [language] defining a relation of [heading], to store in + a branch, where reading it runs it. *) +val view : + language:string -> + heading:Protocols.Schematics.relation_description -> + string -> + Protocols.Handle.t + +(** the evaluator 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 against the directory it is given, and refuses anything - else. *) +(** an evaluator name split into its scope and language. *) +val reference : string -> string * string + +(** an evaluator for [language]. A stored relation read from a branch is + given to [view] with its name: what the source defines under that + name, read [within] the branch state. Anything else is given to + [run]. *) val evaluator : language:string -> + ?view: + (within:Protocols.Handle.t -> + name:string -> + string -> + (Protocols.Handle.t, Concepts.Condition.condition) result ) -> (within:Protocols.Handle.t -> string -> (Protocols.Handle.t, Concepts.Condition.condition) result) -> Protocols.Handle.t -(** where the evaluators are registered, from the root: \system\evaluator. *) -val evaluators : Path.t - -(** run [program] through the evaluator of [language] found in - [directory], against [within]. Usable as an - [EphemeralRelation.binding] once [directory] and [within] are given. *) +(** run [program] through the evaluator named [evaluator] under [root], + [within] the given directory. Usable as an [EphemeralRelation.binding] + once [root] and [within] are given. *) val bind : Protocols.Handle.t -> within:Protocols.Handle.t -> @@ -30,8 +47,8 @@ val bind : Protocols.Handle.t -> (Protocols.Handle.t, Concepts.Condition.condition) result -(** run [text] in [language] against [within], with the evaluator - registered under [root]. *) +(** run [text] with the evaluator named [language] under [root], [within] + the given directory. *) val run : Protocols.Handle.t -> language:string -> @@ -39,9 +56,10 @@ val run : string -> (Protocols.Handle.t, Concepts.Condition.condition) result -(** register [evaluator] for [language] under [root]. *) +(** register [evaluator] as \[scope]\evaluator\[language] under [root]. *) val register : Protocols.Handle.t -> + scope:string -> language:string -> Protocols.Handle.t -> (unit, Concepts.Condition.condition) result -- cgit v1.2.3