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
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
[@@@warning "-26-27-32-34-37-69"]
open Rnt
type ('a, 'b) service = { name: string; id: ('a * 'b) Type.Id.t }
let service name = { name; id = Type.Id.make () }
type ('a, 'b) component =
{ provides: ('a, 'b) service;
value: 'a;
mount: 'a -> 'b -> (('a, 'b) component, Concepts.Condition.condition) result;
unmount: 'a -> 'b -> (('a, 'b) component, Concepts.Condition.condition) result;
requires: ('a, 'b) service BatSet.t;
extends: 'a extension BatSet.t }
and 'a extension =
Extension: { target: ('c, 'd) service;
apply: 'a -> ('d, Concepts.Condition.condition) result } -> 'a extension
type entry = Entry: ('a, 'b) component -> entry
let entry_id (Entry { provides = { id; _ }; _ }) = Type.Id.uid id
let entry_dependencies (Entry { extends; _ }) =
BatSet.enum extends
|> BatEnum.map (fun (Extension { target = { id; _ }; _ }) -> Type.Id.uid id)
let toposort es =
let components =
BatFingerTree.enum es
|> BatEnum.map (fun entry -> (entry_id entry), entry)
|> BatMap.of_enum
in
let edges =
BatMap.enum components
|> BatEnum.map (fun (id, e) -> entry_dependencies e |> BatEnum.map (fun e -> id, e))
|> BatEnum.flatten
|> BatFingerTree.of_enum
in
let in_edges =
edges
|> Utilities.FingerTree.group (fun (_, t1) (_, t2) -> t1 - t2)
|> BatFingerTree.map (fun es ->
let _, t = BatFingerTree.head_exn es in
t, BatFingerTree.map (fun (x, y) -> y, x) es)
|> BatFingerTree.enum
|> BatMap.of_enum
in
let degree_of v = BatMap.find_opt v in_edges |> Option.fold ~none:0 ~some:BatFingerTree.size in
(* let queue = *)
(* BatMap.values in_edges *)
(* |> BatEnum.filter (fun v -> degree_of v) *)
(* in *)
failwith "TODO"
let instantiate : entry BatFingerTree.t -> (entry BatFingerTree.t, Concepts.Condition.condition) result =
fun es ->
let es' = toposort es in
failwith "TODO"
(* to instantiate the component tree:
- sort the list of components such that the dependents come before their dependencies, with the leaves coming first
- fold over this list, applying extensions, then merging the resulting extensions into the current set of extensions
- at the end, if the set of extensions contains anything other than the root, there are unmet dependencies on the tree
*)
open Protocols
let root = service "root"
type subsystem = { name : string; root : Handle.t }
let subsystem_manager : (Handle.t, subsystem) service = service "subsystem-manager"
type health = Healthy | Unhealthy
type health_check = unit -> health
let health_manager : (unit, health_check) service = service "health-manager"
let sakura : (unit, unit) component =
{ provides = service "sakura";
value = ();
mount = (fun _ _ -> failwith "not extensible");
unmount = (fun _ _ -> failwith "not extensible");
requires = BatSet.empty;
extends = BatSet.of_list [Extension { target = subsystem_manager;
apply = (fun h ->
let root = failwith "nop" in
Ok { name = "sakura";
root = root })};
Extension { target = health_manager;
apply = (fun _ -> Ok (fun () -> Healthy))}] }
(* type ('a, 'b) service = Root *)
(* let root : (unit, unit) service = Root *)
let () = print_endline "hello."
|
