aboutsummaryrefslogtreecommitdiffstats
path: root/lib/kernel/Scope.ml
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/kernel/Scope.ml148
-rw-r--r--lib/kernel/Scope.mli65
2 files changed, 213 insertions, 0 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 13:45:21 +0000