Init system sketchesinit

1 files changed, 101 insertions, 0 deletions

diff --git a/bin/sandbox.ml b/bin/sandbox.ml
new file mode 100644
index 0000000..2aa3763
--- /dev/null
+++ b/bin/sandbox.ml
@@ -0,0 +1,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."