path: root/bin/sandbox.ml

[@@@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."