blob: 54bb76d3f891c48289c4123b75ac7e3160017bad (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
|
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
Utilities.List.foldm_left (fun () -> bind into) () entries |> Result.map (fun () -> 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 root = Namespace.make () in
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* () = bind root ("system", system) in
Ok root
end
|
